diff --git a/DESCRIPTION b/DESCRIPTION index 9b6c6ee0..16e43631 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,11 @@ Package: OhdsiShinyModules Type: Package Title: Repository of Shiny Modules for OHDSI Result Viewers -Version: 2.1.5.9000 -Author: Jenna Reps +Version: 3.0.0 +Authors@R: c( + person("Jenna", "Reps", email = "jreps@its.jnj.com", role = c("aut", "cre")), + person("Nathan", "Hall", role = c("aut")), + person("Jamie", "Gibert", role = c("aut"))) Maintainer: Jenna Reps Description: Install this package to access useful shiny modules for building shiny apps to explore results using the OHDSI tools . License: Apache License 2.0 @@ -24,6 +27,7 @@ Imports: htmltools, lubridate, methods, + openxlsx, ParallelLogger, plotly, purrr, @@ -56,7 +60,6 @@ Suggests: testthat, withr Remotes: - ohdsi/CirceR, ohdsi/ReportGenerator, ohdsi/ResultModelManager RoxygenNote: 7.3.1 diff --git a/NAMESPACE b/NAMESPACE index 37b82f11..97074e8f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,18 +4,10 @@ export(LargeDataTable) export(aboutHelperFile) export(aboutServer) export(aboutViewer) -export(characterizationAggregateFeaturesServer) -export(characterizationAggregateFeaturesViewer) -export(characterizationDechallengeRechallengeServer) -export(characterizationDechallengeRechallengeViewer) export(characterizationHelperFile) export(characterizationIncidenceServer) export(characterizationIncidenceViewer) export(characterizationServer) -export(characterizationTableServer) -export(characterizationTableViewer) -export(characterizationTimeToEventServer) -export(characterizationTimeToEventViewer) export(characterizationViewer) export(cohortCountsView) export(cohortDefinitionsView) @@ -30,9 +22,6 @@ export(cohortMethodAttritionServer) export(cohortMethodAttritionViewer) export(cohortMethodCovariateBalanceServer) export(cohortMethodCovariateBalanceViewer) -export(cohortMethodDiagnosticsSummaryServer) -export(cohortMethodDiagnosticsSummaryViewer) -export(cohortMethodHelperFile) export(cohortMethodKaplanMeierServer) export(cohortMethodKaplanMeierViewer) export(cohortMethodPopulationCharacteristicsServer) @@ -43,12 +32,8 @@ export(cohortMethodPropensityModelServer) export(cohortMethodPropensityModelViewer) export(cohortMethodPropensityScoreDistServer) export(cohortMethodPropensityScoreDistViewer) -export(cohortMethodResultSummaryServer) -export(cohortMethodResultSummaryViewer) -export(cohortMethodServer) export(cohortMethodSystematicErrorServer) export(cohortMethodSystematicErrorViewer) -export(cohortMethodViewer) export(cohortOverlapView) export(compareCohortCharacterizationView) export(conceptsInDataSourceView) @@ -65,9 +50,9 @@ export(databaseInformationView) export(datasourcesHelperFile) export(datasourcesServer) export(datasourcesViewer) -export(evidenceSynthesisHelperFile) -export(evidenceSynthesisServer) -export(evidenceSynthesisViewer) +export(estimationHelperFile) +export(estimationServer) +export(estimationViewer) export(getEnabledCdReports) export(getExampleConnectionDetails) export(getLogoImage) @@ -110,8 +95,7 @@ export(phevaluatorViewer) export(reportHelperFile) export(reportServer) export(reportViewer) -export(sccsHelperFile) -export(sccsServer) -export(sccsView) export(timeDistributionsView) export(visitContextView) +importFrom(dplyr,"%>%") +importFrom(rlang,.data) diff --git a/NEWS.md b/NEWS.md index 33d8bf19..f880d780 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,15 @@ +OhdsiShinyModules v2.2.1 +======================== +- Fixed issue in DatabaseConnector check for pooled connections of sqlite databases on cohort diagnotiscs load (from main hotfix) + +OhdsiShinyModules v2.2.0 +======================== +- Combined cohort method, sccs and evidence synthesis into one estimation module with shared target and outcome ids +- Characterizations now share the target id +- Updated tests to get them all working +- Cleaned R check (but cohort incidence still has many notes) + + OhdsiShinyModules v2.1.5 ======================== Fixed bug of orphan concepts report not displaying diff --git a/R/OhdsiShinyModules.R b/R/OhdsiShinyModules.R index 37522c46..4aaeef44 100644 --- a/R/OhdsiShinyModules.R +++ b/R/OhdsiShinyModules.R @@ -20,8 +20,8 @@ #' #' @description A selection of shiny modules for exploring standardized OHDSI results #' -#' @docType package #' @name OhdsiShinyModules +#' @keywords internal #' @importFrom dplyr %>% #' @importFrom rlang .data - +"_PACKAGE" \ No newline at end of file diff --git a/R/about-main.R b/R/about-main.R index 487aa0a2..f5225ad7 100644 --- a/R/about-main.R +++ b/R/about-main.R @@ -21,7 +21,7 @@ #' #' @details #' Returns the location of the about helper file -#' +#' @family {About} #' @return #' string location of the about helper file #' @@ -38,7 +38,7 @@ aboutHelperFile <- function() { #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {About} #' @return #' The user interface to the home page module #' @@ -100,7 +100,7 @@ targetedValueBox <- function( #' @param connectionHandler a connection to the database with the results #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' @param config the config from the app.R file that contains a list of which modules to include -#' +#' @family {About} #' @return #' The server for the shiny app home #' diff --git a/R/characterization-aggregateFeatures.R b/R/characterization-aggregateFeatures.R deleted file mode 100644 index da24c1aa..00000000 --- a/R/characterization-aggregateFeatures.R +++ /dev/null @@ -1,867 +0,0 @@ -# @file characterization-aggregateFeatures.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 module viewer for exploring aggregate feature results -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the description aggregate feature module -#' -#' @export -characterizationAggregateFeaturesViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - - - - - # module that does input selection for a single row DF - inputSelectionViewer( - id = ns("input-selection") - ), - - # COV: RUN_ID DATABASE_ID COHORT_DEFINITION_ID COVARIATE_ID SUM_VALUE AVERAGE_VALUE - # COV REF: RUN_ID DATABASE_ID COVARIATE_ID COVARIATE_NAME ANALYSIS_ID CONCEPT_ID - # settings: RUN_ID DATABASE_ID COVARIATE_SETTING_JSON RISK_WINDOW_START START_ANCHOR RISK_WINDOW_END END_ANCHOR - # cohort_details: RUN_ID DATABASE_ID COHORT_DEFINITION_ID TARGET_COHORT_ID OUTCOME_COHORT_ID COHORT_TYPE - # analysis_ref: RUN_ID DATABASE_ID ANALYSIS_ID ANALYSIS_NAME DOMAIN_ID START_DAY END_DAY IS_BINARY MISSING_MEANS_ZERO - # cov cont: RUN_ID DATABASE_ID COHORT_DEFINITION_ID COVARIATE_ID COUNT_VALUE MIN_VALUE MAX_VALUE AVERAGE_VALUE STANDARD_DEVIATION MEDIAN_VALUE P_10_VALUE P_25_VALUE P_75_VALUE P_90_VALUE - # add table with options to select T, O and TAR - - # add UI to pick database/type 1 and database/type 2 - - shiny::conditionalPanel( - condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection")), - - shinydashboard::tabBox( - width = "100%", - # Title can include an icon - title = shiny::tagList(shiny::icon("gear"), "Table and Plots"), - shiny::tabPanel("Binary Feature Table", - resultTableViewer(ns('binaryTable')) - ), - shiny::tabPanel("Continuous Feature Table", - resultTableViewer(ns('continuousTable')) - ), - shiny::tabPanel("Binary Feature Plot", - shinycssloaders::withSpinner( - plotly::plotlyOutput(ns("binaryPlot")) - ) - ), - shiny::tabPanel("Continuous Feature Plot", - shinycssloaders::withSpinner( - plotly::plotlyOutput(ns("continuousPlot")) - ) - ) - ) - ) - ) -} - - -#' The module server for exploring aggregate features results -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the prediction result database -#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix -#' -#' @return -#' The server to the description aggregate features module -#' -#' @export -characterizationAggregateFeaturesServer <- function( - id, - connectionHandler, - resultDatabaseSettings -) { - shiny::moduleServer( - id, - function(input, output, session) { - - # get the possible options - options <- getAggregateFeatureOptions( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - # get databases - databases <- getAggregateFeatureDatabases( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - # input selection component - inputSelected <- inputSelectionServer( - id = "input-selection", - inputSettingList = list( - createInputSetting( - rowNumber = 1, - columnWidth = 4, - varName = 'targetIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Target: ', - choices = options$targets, - selected = options$targets[1], - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - createInputSetting( - rowNumber = 1, - columnWidth = 4, - varName = 'outcomeIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Outcome: ', - choices = options$outcomes, - selected = options$outcomes[1], - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) - , - createInputSetting( - rowNumber = 1, - columnWidth = 4, - varName = 'tarIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Time at risk: ', - choices = options$tars, - selected = options$tars[1], - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) - , - createInputSetting( - rowNumber = 2, - columnWidth = 6, - varName = 'database', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Database: ', - choices = databases, - selected = databases[1], - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) - , - createInputSetting( - rowNumber = 2, - columnWidth = 3, - varName = 'firstO', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Restrict to first O: ', - choices = c(T,F), - selected = T, - multiple = F - ) - ) - , - createInputSetting( - rowNumber = 2, - columnWidth = 3, - varName = 'index', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Index: ', - choices = c('T', 'O'), - selected = 'T', - multiple = F - ) - ) - ) - ) - - allData <- shiny::reactive({ - characterizationGetAggregateData( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetId = inputSelected()$targetIds, - outcomeId = inputSelected()$outcomeIds, - riskWindowStart = options$tarList[[which(options$tars == ifelse(is.null(inputSelected()$tarIds),options$tars[1],inputSelected()$tarIds))]]$riskWindowStart, - riskWindowEnd = options$tarList[[which(options$tars == ifelse(is.null(inputSelected()$tarIds),options$tars[1],inputSelected()$tarIds))]]$riskWindowEnd, - startAnchor = options$tarList[[which(options$tars == ifelse(is.null(inputSelected()$tarIds),options$tars[1],inputSelected()$tarIds))]]$startAnchor, - endAnchor = options$tarList[[which(options$tars == ifelse(is.null(inputSelected()$tarIds),options$tars[1],inputSelected()$tarIds))]]$endAnchor, - database = inputSelected()$database, - firstO = inputSelected()$firstO, - index = inputSelected()$index - ) - }) - - output$binaryPlot <- plotly::renderPlotly( - characterizationFeaturePlot( - data = allData()$binary, - valueColumn = 'averageValue' - ) - ) - output$continuousPlot <- plotly::renderPlotly( - characterizationFeaturePlot( - data = allData()$continuous, - valueColumn = 'averageValue' - ) - ) - - binaryData <- shiny::reactive({ - characterizationFeatureTable( - data = allData()$binary - ) - }) - - continuousData <- shiny::reactive({ - characterizationFeatureTable( - data = allData()$continuous - ) - }) - - binTableOutputs <- resultTableServer( - id = "binaryTable", - df = binaryData, - colDefsInput = list( - covariateName = reactable::colDef( - name = "Covariate Name", - filterable = T - ), - comp1T = reactable::colDef( - name = "T without O mean", - format = reactable::colFormat(digits = 2, percent = T) - ), - comp1sdT = reactable::colDef( - name = "T without O stdev", - format = reactable::colFormat(digits = 2) - ), - comp2T = reactable::colDef( - name = "T with O mean", - format = reactable::colFormat(digits = 2, percent = T) - ), - comp2sdT = reactable::colDef( - name = "T with O stdev", - format = reactable::colFormat(digits = 2) - ), - comp1O = reactable::colDef( - name = "O without T mean", - format = reactable::colFormat(digits = 2, percent = T) - ), - comp1sdO = reactable::colDef( - name = "O without T stdev", - format = reactable::colFormat(digits = 2) - ), - comp2O = reactable::colDef( - name = "O with T mean", - format = reactable::colFormat(digits = 2, percent = T) - ), - comp2sdO = reactable::colDef( - name = "O with T stdev", - format = reactable::colFormat(digits = 2) - ), - analysisName = reactable::colDef( # not sure this will work now - filterInput = function(values, name) { - shiny::tags$select( - # Set to undefined to clear the filter - onchange = sprintf("Reactable.setFilter('desc-bin-select', '%s', event.target.value || undefined)", name), - # "All" has an empty value to clear the filter, and is the default option - shiny::tags$option(value = "", "All"), - lapply(unique(values), shiny::tags$option), - "aria-label" = sprintf("Filter %s", name), - style = "width: 100%; height: 28px;" - ) - } - ), - standardizedMeanDiff = reactable::colDef( - format = reactable::colFormat(digits = 2) - ) - ), - addActions = NULL - ) - - conTableOutputs <- resultTableServer( - id = "continuousTable", - df = continuousData, - colDefsInput = list( - covariateName = reactable::colDef( - name = "Covariate Name", - filterable = T - ), - comp1T = reactable::colDef( - name = "T without O mean", - format = reactable::colFormat(digits = 2) - ), - comp1sdT = reactable::colDef( - name = "T without O stdev", - format = reactable::colFormat(digits = 2) - ), - comp2T = reactable::colDef( - name = "T with O mean", - format = reactable::colFormat(digits = 2) - ), - comp2sdT = reactable::colDef( - name = "T with O stdev", - format = reactable::colFormat(digits = 2) - ), - comp1O = reactable::colDef( - name = "O without T mean", - format = reactable::colFormat(digits = 2) - ), - comp1sdO = reactable::colDef( - name = "O without T stdev", - format = reactable::colFormat(digits = 2) - ), - comp2O = reactable::colDef( - name = "O with T mean", - format = reactable::colFormat(digits = 2) - ), - comp2sdO = reactable::colDef( - name = "O with T stdev", - format = reactable::colFormat(digits = 2) - ), - analysisName = reactable::colDef( - filterInput = function(values, name) { - shiny::tags$select( - # Set to undefined to clear the filter - onchange = sprintf("Reactable.setFilter('desc-cont-select', '%s', event.target.value || undefined)", name), - # "All" has an empty value to clear the filter, and is the default option - shiny::tags$option(value = "", "All"), - lapply(unique(values), shiny::tags$option), - "aria-label" = sprintf("Filter %s", name), - style = "width: 100%; height: 28px;" - ) - } - ), - standardizedMeanDiff = reactable::colDef( - format = reactable::colFormat(digits = 2) - ) - ), - addActions = NULL - ) - - #elementId = "desc-cont-select" - - - - return(invisible(NULL)) - } - ) -} - - -getAggregateFeatureOptions <- function( - connectionHandler, - resultDatabaseSettings -){ - - - shiny::withProgress(message = 'Getting feature comparison options', value = 0, { - - sql <- "SELECT DISTINCT t.COHORT_NAME as TARGET, cd.TARGET_COHORT_ID, - o.COHORT_NAME as outcome, cd.OUTCOME_COHORT_ID, - s.RISK_WINDOW_START, s.START_ANCHOR, s.RISK_WINDOW_END, s.END_ANCHOR - FROM @schema.@c_table_prefixCOHORT_DETAILS cd - inner join @schema.@c_table_prefixSETTINGS s - on cd.run_id = s.run_id and cd.database_id = s.database_id - inner join @schema.@cg_table_prefixCOHORT_DEFINITION t - on cd.TARGET_COHORT_ID = t.COHORT_DEFINITION_ID - inner join @schema.@cg_table_prefixCOHORT_DEFINITION o - on cd.OUTCOME_COHORT_ID = o.COHORT_DEFINITION_ID - WHERE cd.TARGET_COHORT_ID != 0 AND cd.OUTCOME_COHORT_ID != 0;" - - shiny::incProgress(1/2, detail = paste("Extracting options")) - - options <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix - ) - - shiny::incProgress(2/2, detail = paste("Finished")) - - }) - - targets <- unique(options$targetCohortId) - names(targets) <- unique(options$target) - - outcomes <- unique(options$outcomeCohortId) - names(outcomes) <- unique(options$outcome) - - options <- unique( - options %>% - dplyr::select( - "riskWindowStart", - "riskWindowEnd", - "startAnchor", - "endAnchor" - ) - ) - - tarList <- lapply( - 1:nrow(options), - function(i){ - list( - riskWindowStart = options$riskWindowStart[i], - riskWindowEnd = options$riskWindowEnd[i], - startAnchor = options$startAnchor[i], - endAnchor = options$endAnchor[i] - ) - }) - - tars <- unlist( - lapply( - 1:nrow(options), - function(i){ - paste0( - '(',options$startAnchor[i],' + ', options$riskWindowStart[i], - ') - (', options$endAnchor[i],' + ', options$riskWindowEnd[i], - ')' - ) - }) - ) - - return( - list( - targets = targets, - outcomes = outcomes, - tars = tars, - tarList = tarList - ) - ) -} - -getAggregateFeatureDatabases <- function( - connectionHandler, - resultDatabaseSettings -){ - - shiny::withProgress(message = 'Finding databases', value = 0, { - sql <- "SELECT DISTINCT s.DATABASE_ID, d.CDM_SOURCE_ABBREVIATION as database_name - FROM @schema.@c_table_prefixCOHORT_DETAILS cd - inner join @schema.@database_table d - on cd.database_id = d.database_id - inner join @schema.@c_table_prefixSETTINGS s - on s.database_id = d.database_id - and s.run_id = cd.run_id;" - - shiny::incProgress(1/2, detail = paste("Extracting databases")) - - - databases <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix, - database_table = resultDatabaseSettings$databaseTable - ) - - shiny::incProgress(2/2, detail = paste("Finished")) - - } - ) - - dbs <- databases$databaseId - names(dbs) <- databases$databaseName - - return(dbs) -} - -# pulls all data for a target and outcome -# edited to only use Ts and TnOs -characterizationGetAggregateData <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - outcomeId, - riskWindowStart, - riskWindowEnd, - startAnchor, - endAnchor, - database, - firstO, - index -){ - - if(is.null(targetId)){ - return(NULL) - } - - #get types based on index and first - outcomeType <- ifelse(firstO, 'firstO', 'O') - firstPart <- ifelse(index == 'T', 'T', outcomeType) - secondPart <- ifelse(index == 'T',outcomeType, 'T') - - type1 <- firstPart - type2 <- paste0(firstPart, 'n', secondPart) - - # if type is TnOc TnfirstOc the extract T minus TnO / TnOfirst - - shiny::withProgress(message = 'Getting Feature Comparison Data', value = 0, { - sql <- "SELECT s.RUN_ID, cd.COHORT_DEFINITION_ID - FROM @schema.@c_table_prefixSETTINGS s - inner join - @schema.@c_table_prefixCOHORT_DETAILS cd - on cd.database_id = s.database_id and - cd.run_id = s.run_id - WHERE cd.TARGET_COHORT_ID = @target_id and cd.OUTCOME_COHORT_ID = @outcome_id - and s.RISK_WINDOW_START = @risk_window_start and s.START_ANCHOR = '@start_anchor' - and s.RISK_WINDOW_END = @risk_window_end and s.END_ANCHOR = '@end_anchor' - and s.DATABASE_ID = '@database_id' and cd.COHORT_TYPE = '@type';" - - settingsFirst <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix, - target_id = ifelse(type1 %in% c('firstO','O'), 0, targetId), - outcome_id = ifelse(type1 %in% c('T', 'allT'), 0, outcomeId), - risk_window_start = riskWindowStart, - start_anchor = startAnchor, - risk_window_end = riskWindowEnd, - end_anchor = endAnchor, - database_id = database, - type = type1 - ) - - shiny::incProgress(1/5, detail = paste("Got first runId and cohortId")) - - - sql <- "SELECT s.RUN_ID, cd.COHORT_DEFINITION_ID - FROM @schema.@c_table_prefixSETTINGS s - inner join - @schema.@c_table_prefixCOHORT_DETAILS cd - on cd.database_id = s.database_id and - cd.run_id = s.run_id - WHERE cd.TARGET_COHORT_ID = @target_id and cd.OUTCOME_COHORT_ID = @outcome_id - and s.RISK_WINDOW_START = @risk_window_start and s.START_ANCHOR = '@start_anchor' - and s.RISK_WINDOW_END = @risk_window_end and s.END_ANCHOR = '@end_anchor' - and s.DATABASE_ID = '@database_id' and cd.COHORT_TYPE = '@type';" - - settingsSecond <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix, - target_id = ifelse(type2 %in% c('firstO','O'), 0, targetId), - outcome_id = ifelse(type2 %in% c('T', 'allT'), 0, outcomeId), - risk_window_start = riskWindowStart, - start_anchor = startAnchor, - risk_window_end = riskWindowEnd, - end_anchor = endAnchor, - database_id = database, - type = type2 - ) - - if(nrow(settingsSecond) == 0){ - print('no second setting') - settingsSecond <- settingsFirst - } - - shiny::incProgress(2/5, detail = paste("Got second runId and CohortId")) - - sql <- "SELECT - case when t.covariate_id is NULL then tno.covariate_id else t.covariate_id end covariate_id, - t.sum_value - tno.sum_value as comp1_count, - tno.sum_value as comp2_count, - case when (t.sum_value - tno.sum_value)*1.0/(cc.row_count - cctno.row_count) is NULL then 0 else (t.sum_value - tno.sum_value)*1.0/(cc.row_count - cctno.row_count) end as comp1_@index, - case when tno.average_value is NULL then 0 else tno.average_value end as comp2_@index, - sqrt( (t.sum_value - tno.sum_value)*1.0/(cc.row_count - cctno.row_count) * (1-( (t.sum_value - tno.sum_value)*1.0/(cc.row_count - cctno.row_count) )) ) as comp1sd_@index, - sqrt( (tno.average_value)*(1-(tno.average_value))) as comp2sd_@index, - cov_ref.COVARIATE_NAME, - an_ref.ANALYSIS_NAME - - FROM - - (select * FROM @schema.@c_table_prefixCOVARIATES - where - DATABASE_ID = '@database_id' and - COHORT_DEFINITION_ID = @cohort_def_1 and - RUN_ID in (@run_id_1) - ) t - full join - (select * FROM @schema.@c_table_prefixCOVARIATES - where - DATABASE_ID = '@database_id' and - COHORT_DEFINITION_ID = @cohort_def_2 and - RUN_ID in (@run_id_2) - ) tno - - on - t.covariate_id = tno.covariate_id - and t.run_id = tno.run_id - - INNER JOIN - @schema.@c_table_prefixCOHORT_COUNTS cc - on cc.cohort_definition_id = t.cohort_definition_id - and cc.run_id = t.run_id - and cc.database_id = t.database_id - - INNER JOIN - @schema.@c_table_prefixCOHORT_COUNTS cctno - on cctno.cohort_definition_id = tno.cohort_definition_id - and cctno.run_id = tno.run_id - and cctno.database_id = tno.database_id - - INNER JOIN - @schema.@c_table_prefixCOVARIATE_REF cov_ref - ON cov_ref.covariate_id = t.covariate_id - and cov_ref.run_id = case when t.run_id is NULL then tno.run_id else t.run_id end - and cov_ref.database_id = t.database_id - - INNER JOIN - @schema.@c_table_prefixANALYSIS_REF an_ref - ON an_ref.analysis_id = cov_ref.analysis_id - and an_ref.run_id = cov_ref.run_id - and an_ref.database_id = cov_ref.database_id - - ;" - - shiny::incProgress(3/5, detail = paste("Getting binary data")) - - binary <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix, - cohort_def_1 = settingsFirst$cohortDefinitionId[1], - cohort_def_2 = settingsSecond$cohortDefinitionId[1], - database_id = database, - run_id_1 = paste(settingsFirst$runId, collapse = ','), - run_id_2 = paste(settingsSecond$runId, collapse = ','), - index = index - ) - - shiny::incProgress(4/5, detail = paste("Getting continuous data")) - - sql <- "SELECT - case when t.covariate_id is NULL then tno.covariate_id else t.covariate_id end covariate_id, - t.count_value - tno.count_value as comp1_count, - tno.count_value as comp2_count, - case when (t.count_value*t.average_value - tno.count_value*tno.average_value)*1.0/(cc.row_count-tnocc.row_count) is NULL then 0 else (t.count_value*t.average_value - tno.count_value*tno.average_value)*1.0/(cc.row_count-tnocc.row_count) end as comp1_@index, - case when tno.average_value is NULL then 0 else tno.average_value end as comp2_@index, - sqrt( (square(t.standard_deviation)*cc.row_count - square(tno.standard_deviation)*tnocc.row_count)/ (cc.row_count - tnocc.row_count)) as comp1sd_@index, - tno.standard_deviation as comp2sd_@index, - cov_ref.COVARIATE_NAME, - an_ref.ANALYSIS_NAME - - FROM - - (select * FROM @schema.@c_table_prefixCOVARIATES_continuous - where - DATABASE_ID = '@database_id' and - COHORT_DEFINITION_ID = @cohort_def_1 and - RUN_ID in (@run_id_1) - ) t - full join - (select * FROM @schema.@c_table_prefixCOVARIATES_continuous - where - DATABASE_ID = '@database_id' and - COHORT_DEFINITION_ID = @cohort_def_2 and - RUN_ID in (@run_id_2) - ) tno - - on - t.covariate_id = tno.covariate_id - and t.run_id = tno.run_id - - INNER JOIN - @schema.@c_table_prefixCOHORT_COUNTS cc - on cc.cohort_definition_id = t.cohort_definition_id - and cc.run_id = t.run_id - and cc.database_id = t.database_id - - INNER JOIN - @schema.@c_table_prefixCOHORT_COUNTS tnocc - on tnocc.cohort_definition_id = tno.cohort_definition_id - and tnocc.run_id = tno.run_id - and tnocc.database_id = tno.database_id - - INNER JOIN - @schema.@c_table_prefixCOVARIATE_REF cov_ref - ON cov_ref.covariate_id = t.covariate_id - and cov_ref.run_id = case when t.run_id is NULL then tno.run_id else t.run_id end - and cov_ref.database_id = t.database_id - - INNER JOIN - @schema.@c_table_prefixANALYSIS_REF an_ref - ON an_ref.analysis_id = cov_ref.analysis_id - and an_ref.run_id = cov_ref.run_id - and an_ref.database_id = cov_ref.database_id - - ;" - - continuous <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix, - cohort_def_1 = settingsFirst$cohortDefinitionId[1], - cohort_def_2 = settingsSecond$cohortDefinitionId[1], - database_id = database, - run_id_1 = paste(settingsFirst$runId, collapse = ','), - run_id_2 = paste(settingsSecond$runId, collapse = ','), - index = index - ) - - shiny::incProgress(5/5, detail = paste("Finished")) - } - ) - - return(list( - binary = binary, - continuous = continuous - )) -} - -characterizationFeaturePlot <- function( - data, - valueColumn = 'averageValue' -){ - - if(is.null(data)){ - return(NULL) - } - - # selecting the column anmes that has _index appended to it - comp1Name <- paste0('comp1', c('O', 'T'))[paste0('comp1', c('O', 'T')) %in% colnames(data)] - comp2Name <- paste0('comp2', c('O', 'T'))[paste0('comp2', c('O', 'T')) %in% colnames(data)] - data$comp1 <- data[,comp1Name] - data$comp2 <- data[,comp2Name] - - maxval <- max(max(data$comp1),max(data$comp2)) - - plot <- plotly::plot_ly( - data = data, - x = ~.data$comp1, - y = ~.data$comp2, - showlegend = F - ) %>% - plotly::add_markers(color=factor(data$analysisName), - hoverinfo = 'text', - text = ~paste( - '\n',descGetType(data$covariateName), - '\n',descGetName(data$covariateName), - '\n',descGetTime(data$covariateName) - ), - showlegend = T - ) %>% - plotly::add_trace(x= c(0,maxval), y = c(0,maxval),mode = 'lines', - line = list(dash = "dash"), color = I('black'), - type='scatter', showlegend = FALSE) %>% - plotly::layout(#title = 'Prevalance of baseline predictors in persons with and without outcome', - xaxis = list(title = "Prevalance in selection 1"), - yaxis = list(title = "Prevalance in selection 2"), - #legend = l, showlegend = T, - legend = list(orientation = 'h', y = -0.3), showlegend = T) - - - return(plot) -} - -descGetType <- function(x){ - return(unlist(lapply(strsplit(x = x, split = ' during'), function(y){y[1]}))) -} - -descGetName <- function(x){ - return(unlist(lapply(strsplit(x = x, split = ': '), function(y){y[length(y)]}))) -} - -descGetTime <- function(x){ - part1 <- unlist(lapply(strsplit(x = x, split = ' during '), function(y){y[2]})) - return(unlist(lapply(strsplit(x = part1, split = ': '), function(y){y[1]}))) -} - - -characterizationFeatureTable <- function( - data -){ - - if(is.null(data)){ - return(NULL) - } - - # selecting the column that as _index appended to it - comp1Name <- paste0('comp1', c('O', 'T'))[paste0('comp1', c('O', 'T')) %in% colnames(data)] - comp2Name <- paste0('comp2', c('O', 'T'))[paste0('comp2', c('O', 'T')) %in% colnames(data)] - comp1sdName <- paste0('comp1sd', c('O', 'T'))[paste0('comp1sd', c('O', 'T')) %in% colnames(data)] - comp2sdName <- paste0('comp2sd', c('O', 'T'))[paste0('comp2sd', c('O', 'T')) %in% colnames(data)] - - if(sum(is.null(data[comp1sdName]))>0){ - data[comp1sdName][is.null(data[comp1sdName])] <- 0 - } - if(sum(is.null(data[comp2sdName]))>0){ - data[comp2sdName][is.null(data[comp2sdName])] <- 0 - } - - data <- data %>% - dplyr::mutate( - standardizedMeanDiff = (.data[[comp1Name]] - .data[[comp2Name]])/(sqrt((.data[[comp1sdName]]^2 + .data[[comp2sdName]]^2))) - ) %>% - dplyr::select( - "covariateName", - "analysisName", - comp1Name, - comp1sdName, - comp2Name, - comp2sdName, - "standardizedMeanDiff" - ) - - if(sum(is.null(data$standardizedMeanDiff))>0){ - data$standardizedMeanDiff[is.null(data$standardizedMeanDiff)] <- 0 - } - - if(sum(!is.finite(data$standardizedMeanDiff))>0){ - data$standardizedMeanDiff[!is.finite(data$standardizedMeanDiff)] <- 0 - } - - return(data) -} diff --git a/R/characterization-caseSeries.R b/R/characterization-caseSeries.R new file mode 100644 index 00000000..9a3ef0f4 --- /dev/null +++ b/R/characterization-caseSeries.R @@ -0,0 +1,743 @@ +# @file characterization-aggregateFeatures.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. + + + +characterizationCaseSeriesViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::div( + + # module that does input selection for a single row DF + shiny::uiOutput(ns("inputs")), + + shiny::conditionalPanel( + condition = 'input.generate != 0', + ns = ns, + + inputSelectionDfViewer(id = ns('inputSelected'), title = 'Selected'), + + shinydashboard::tabBox( + width = "100%", + # Title can include an icon + title = shiny::tagList(shiny::icon("gear"), "Case Series"), + shiny::tabPanel("Binary Feature Table", + resultTableViewer(ns('binaryTable')) + ), + shiny::tabPanel("Continuous Feature Table", + resultTableViewer(ns('continuousTable')) + ) + ) + ) + ) + +} + + + +characterizationCaseSeriesServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + targetId, #reactive + outcomeId #reactive +) { + shiny::moduleServer( + id, + function(input, output, session) { + + # get databases + options <- shiny::reactive({ + characterizationGetCaseSeriesOptions( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = targetId(), + outcomeId = outcomeId() + ) + }) + + output$inputs <- shiny::renderUI({ # need to make reactive? + + shiny::div( + shiny::selectInput( + inputId = session$ns('databaseId'), + label = 'Database: ', + choices = options()$databaseIds, + selected = options()$databaseIds[1], + multiple = F + ), + + shiny::selectInput( + inputId = session$ns('tarInd'), + label = 'Time-at-risk: ', + choices = options()$tarInds, + selected = options()$tarInds[1], + multiple = F + ), + + shiny::actionButton( + inputId = session$ns('generate'), + label = 'Generate' + ) + ) + + }) + + # save the selections + selected <- shiny::reactiveVal(NULL) + + shiny::observeEvent(input$generate, { + + selected(data.frame( + database = names(options()$databaseIds)[which(input$databaseId == options()$databaseIds)], + time_at_risk = names(options()$tarInds)[which(input$tarInd == options()$tarInds)] + )) + + inputSelectionDfServer( + id = 'inputSelected', + dataFrameRow = selected, + ncol = 1 + ) + + allData <- characterizationGetCaseSeriesData( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = targetId(), + outcomeId = outcomeId(), + databaseId = input$databaseId, + tar = options()$tarList[[which(options()$tarInds == input$tarInd)]] + ) + + binTableOutputs <- resultTableServer( + id = "binaryTable", + df = allData$binary, + details = data.frame( + database = names(options()$databaseIds)[which(input$databaseId == options()$databaseIds)], + tar = names(options()$tarInds)[which(input$tarInd == options()$tarInds)], + target = options()$targetName, + outcome = options()$outcomeName, + description = "Case series binary features before target index, during exposure and after outcome index" + ), + downloadedFileName = 'case_series_binary', + colDefsInput = colDefsBinary( + elementId = session$ns('binary-table-filter') + ), # function below + addActions = NULL, + elementId = session$ns('binary-table-filter') + ) + + conTableOutputs <- resultTableServer( + id = "continuousTable", + df = allData$continuous, + details = data.frame( + database = names(options()$databaseIds)[which(input$databaseId == options()$databaseIds)], + tar = names(options()$tarInds)[which(input$tarInd == options()$tarInds)], + target = options()$targetName, + outcome = options()$outcomeName, + description = "Case series continuous features before target index, during exposure and after outcome index" + ), + downloadedFileName = 'case_series_continuous', + colDefsInput = colDefsContinuous( + elementId = session$ns('continuous-table-filter') + ), # function below + addActions = NULL, + elementId = session$ns('continuous-table-filter') + ) + + }) + + return(invisible(NULL)) + } + ) +} + + +characterizationGetCaseSeriesOptions <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + outcomeId +){ + + sql <- "SELECT distinct s.database_id, d.CDM_SOURCE_ABBREVIATION as database_name, + s.setting_id, + s.RISK_WINDOW_START, s.RISK_WINDOW_END, + s.START_ANCHOR, s.END_ANCHOR, + ct1.cohort_name as target_name, + ct2.cohort_name as outcome_name + + from + @schema.@c_table_prefixsettings s + inner join @schema.@database_meta_table d + on s.database_id = d.database_id + inner join @schema.@c_table_prefixcohort_details cd + on s.setting_id = cd.setting_id + and s.database_id = cd.database_id + and cd.target_cohort_id = @target_id + and cd.outcome_cohort_id = @outcome_id + and cd.cohort_type = 'Cases' + + inner join + @schema.@cg_table_prefixcohort_definition ct1 + on + ct1.cohort_definition_id = cd.target_cohort_id + + inner join + @schema.@cg_table_prefixcohort_definition ct2 + on + ct2.cohort_definition_id = cd.outcome_cohort_id + + + ;" + + options <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + target_id = targetId, + outcome_id = outcomeId, + database_meta_table = resultDatabaseSettings$databaseTable, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix + ) + + outcomeName <- unique(options$outcomeName) + targetName <- unique(options$targetName) + + db <- unique(options$databaseId) + names(db) <- unique(options$databaseName) + + tar <- unique(options[,c('startAnchor','riskWindowStart', 'endAnchor', 'riskWindowEnd')]) + tarList <- lapply(1:nrow(tar), function(i) as.list(tar[i,])) + #tar <- unique(options$settingId) + tarInds <- 1:nrow(tar) + names(tarInds) <- unique(paste0('(', tar$startAnchor, ' + ', tar$riskWindowStart, ') - (', + tar$endAnchor, ' + ', tar$riskWindowEnd, ')' + )) + + return( + list( + databaseIds = db, + tarInds = tarInds, + tarList = tarList, + outcomeName = outcomeName, + targetName = targetName + ) + ) + +} + + +characterizationGetCaseSeriesData <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + outcomeId, + databaseId, + tar +){ + + shiny::withProgress(message = 'Getting case series data', value = 0, { + shiny::incProgress(1/4, detail = paste("Extracting binary")) + + sql <- "SELECT + case + when cov.cohort_type = 'CasesBefore' then 'Before' + when cov.cohort_type = 'CasesBetween' then 'During' + when cov.cohort_type = 'CaseAfter' then 'After' + end as type, + cr.covariate_name, + s.min_prior_observation, s.outcome_washout_days, + s.case_post_outcome_duration, s.case_pre_target_duration, + cov.covariate_id, cov.sum_value, cov.average_value + from + @schema.@c_table_prefixcovariates cov + inner join @schema.@c_table_prefixcovariate_ref cr + on cov.setting_id = cr.setting_id and + cov.database_id = cr.database_id and + cov.covariate_id = cr.covariate_id + + inner join @schema.@c_table_prefixsettings s + on cov.setting_id = s.setting_id + and cov.database_id = s.database_id + + where cov.target_cohort_id = @target_id + and cov.outcome_cohort_id = @outcome_id + and cov.cohort_type in ('CasesBetween','CasesAfter','CasesBefore') + --and cov.setting_id = @setting_id + and s.risk_window_start = @risk_window_start + and s.risk_window_end = @risk_window_end + and s.start_anchor = '@start_anchor' + and s.end_anchor = '@end_anchor' + and cov.database_id = '@database_id' + and cr.analysis_id in (109, 110, 217, 218, 305, 417, 418, 505, 605, 713, 805, 926, 927) + ;" + + binary <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + target_id = targetId, + outcome_id = outcomeId, + risk_window_start = tar$riskWindowStart, + risk_window_end = tar$riskWindowEnd, + start_anchor = tar$startAnchor, + end_anchor = tar$endAnchor, + database_id = databaseId + ) + + # now process into table + binary <- caseSeriesTable( + data = binary + ) + + shiny::incProgress(3/4, detail = paste("Extracting continuous")) + + sql <- "SELECT + case + when cov.cohort_type = 'CasesBefore' then 'Before' + when cov.cohort_type = 'CasesBetween' then 'During' + when cov.cohort_type = 'CasesAfter' then 'After' + end as type, + cr.covariate_name, + s.min_prior_observation, s.outcome_washout_days, + s.case_post_outcome_duration, s.case_pre_target_duration, + cov.covariate_id, + cov.count_value, cov.min_value, cov.max_value, cov.average_value, + cov.standard_deviation, cov.median_value, cov.p_10_value, + cov.p_25_value, cov.p_75_value, cov.p_90_value + from + @schema.@c_table_prefixcovariates_continuous cov + inner join @schema.@c_table_prefixcovariate_ref cr + on cov.setting_id = cr.setting_id and + cov.database_id = cr.database_id and + cov.covariate_id = cr.covariate_id + + inner join @schema.@c_table_prefixsettings s + on cov.setting_id = s.setting_id + and cov.database_id = s.database_id + + where cov.target_cohort_id = @target_id + and cov.outcome_cohort_id = @outcome_id + and cov.cohort_type in ('CasesBetween','CasesAfter','CasesBefore') + and s.risk_window_start = @risk_window_start + and s.risk_window_end = @risk_window_end + and s.start_anchor = '@start_anchor' + and s.end_anchor = '@end_anchor' + and cov.database_id = '@database_id' + and cr.analysis_id in (109, 110, 217, 218, 305, 417, 418, 505, 605, 713, 805, 926, 927) + ;" + + # TODO - how to remove prior outcomes?? + continuous <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + target_id = targetId, + outcome_id = outcomeId, + risk_window_start = tar$riskWindowStart, + risk_window_end = tar$riskWindowEnd, + start_anchor = tar$startAnchor, + end_anchor = tar$endAnchor, + database_id = databaseId + ) + + shiny::incProgress(4/4, detail = paste("Done")) + + }) + + return( + list( + binary = binary, + continuous = continuous + ) + ) +} + + +# now process into table +caseSeriesTable <- function( + data +){ + + # Before Index Cases + beforeData <- data %>% + dplyr::filter(.data$type == 'Before') + Nbefore <- getCountFromFE( + sumValue = beforeData$sumValue, + averageValue = beforeData$averageValue + ) + + # After Index Cases + afterData <- data %>% + dplyr::filter(.data$type == 'After') + Nafter <- getCountFromFE( + sumValue = afterData$sumValue, + averageValue = afterData$averageValue + ) + + # During Index Cases + duringData <- data %>% + dplyr::filter(.data$type == 'During') + Nduring <- getCountFromFE( + sumValue = duringData$sumValue, + averageValue = duringData$averageValue + ) + + beforeData <- beforeData %>% + dplyr::mutate( + sumValueBefore = .data$sumValue, + averageValueBefore = .data$averageValue, + ) %>% + dplyr::select("covariateName", "covariateId", 'minPriorObservation', 'outcomeWashoutDays','casePostOutcomeDuration', 'casePreTargetDuration', "sumValueBefore", "averageValueBefore") + + afterData <-afterData %>% + dplyr::mutate( + sumValueAfter = .data$sumValue, + averageValueAfter = .data$averageValue, + ) %>% + dplyr::select("covariateName", "covariateId", 'minPriorObservation', 'outcomeWashoutDays','casePostOutcomeDuration', 'casePreTargetDuration', "sumValueAfter", "averageValueAfter") + + duringData <- duringData %>% + dplyr::mutate( + sumValueDuring = .data$sumValue, + averageValueDuring = .data$averageValue, + ) %>% + dplyr::select("covariateName", "covariateId", 'minPriorObservation', 'outcomeWashoutDays','casePostOutcomeDuration', 'casePreTargetDuration', "sumValueDuring", "averageValueDuring") + + + + allResults <- beforeData %>% + dplyr::full_join( + y = duringData, + by = c("covariateName", "covariateId", 'minPriorObservation', 'outcomeWashoutDays','casePostOutcomeDuration', 'casePreTargetDuration') + ) %>% + dplyr::full_join( + y = afterData, + by = c("covariateName", "covariateId", 'minPriorObservation', 'outcomeWashoutDays','casePostOutcomeDuration', 'casePreTargetDuration') + ) + + return(allResults) +} + +colDefsBinary <- function( + elementId + ){ + result <- list( + covariateName = reactable::colDef( + header = withTooltip("Covariate Name", + "Name of the covariate"), + filterable = T, + minWidth = 300 + ), + covariateId = reactable::colDef( + show = F + ), + minPriorObservation = reactable::colDef( + header = withTooltip("Min Prior Observation", + "Minimum prior observation time (days)"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + outcomeWashoutDays = reactable::colDef( + header = withTooltip("Outcome Washout Days", + "Number of days for the outcome washout"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + casePostOutcomeDuration = reactable::colDef( + header = withTooltip("Days Post-outcome Covariate Window", + "Number of days after the outcome we look for the covariate"), + filterable = T + ), + casePreTargetDuration = reactable::colDef( + header = withTooltip("Days Pre-exposure Covariate Window", + "Number of days before the exposure we look for the covariate"), + filterable = T + ), + sumValueBefore = reactable::colDef( + header = withTooltip("# Cases with Feature Pre-exposure", + "Number of cases with the covariate prior to exposure"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F), + cell = function(value) { + if(is.null(value)){return('< min threshold')} + if(is.na(value)){return('< min threshold')} + if (value >= 0) value else paste0('<', abs(value)) + } + ), + averageValueBefore = reactable::colDef( + header = withTooltip("% of Cases with Feature Pre-exposure", + "Percent of cases with the covariate prior to exposure"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = T) + ), + sumValueDuring = reactable::colDef( + header = withTooltip("# of Cases with Feature Between Exposure & Outcome", + "Number of cases with the covariate between the exposure and outcome"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F), + cell = function(value) { + if(is.null(value)){return('< min threshold')} + if(is.na(value)){return('< min threshold')} + if (value >= 0) value else paste0('<', abs(value)) + } + ), + averageValueDuring = reactable::colDef( + header = withTooltip("% of Cases with Feature Between Exposure & Outcome", + "Percent of cases with the covariate between the exposure and outcome"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = T) + ), + sumValueAfter = reactable::colDef( + header = withTooltip("# of Cases with Feature Post-outcome", + "Number of cases with the covariate after the outcome"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F), + cell = function(value) { + if(is.null(value)){return('< min threshold')} + if(is.na(value)){return('< min threshold')} + if (value >= 0) value else paste0('<', abs(value)) + } + ), + averageValueAfter = reactable::colDef( + header = withTooltip("% of Cases with Feature Post-outcome", + "Percent of cases with the covariate after the outcome"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = T) + ), + + analysisName = reactable::colDef( + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ) + ) + return(result) +} + +colDefsContinuous <- function( + elementId + ){ + result <- list( + cohortDefinitionId = reactable::colDef( + header = withTooltip("Cohort ID", + "Unique identifier of the cohort"), + filterable = T + ), + type = reactable::colDef( + header = withTooltip("Time of Cases Relative to Index", + "Time period relative to index date for cases for the covariate"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + covariateName = reactable::colDef( + header = withTooltip("Covariate Name", + "Name of the covariate"), + filterable = T, + minWidth = 300 + ), + covariateId = reactable::colDef( + show = F + ), + minPriorObservation = reactable::colDef( + header = withTooltip("Min Prior Observation", + "Minimum prior observation time (days)"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + outcomeWashoutDays = reactable::colDef( + header = withTooltip("Outcome Washout Days", + "Number of days for the outcome washout"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + casePostOutcomeDuration = reactable::colDef( + header = withTooltip("Days Post-outcome Covariate Window", + "Number of days after the outcome we look for the covariate"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + casePreTargetDuration = reactable::colDef( + header = withTooltip("Days Pre-exposure Covariate Window", + "Number of days before the exposure we look for the covariate"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + countValue = reactable::colDef( + header = withTooltip("# Cases with Feature", + "Number of cases with the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F), + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), + minValue = reactable::colDef( + header = withTooltip("Min Value", + "Minimum value of the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + maxValue = reactable::colDef( + header = withTooltip("Max Value", + "Maximum value of the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + averageValue = reactable::colDef( + header = withTooltip("Average Value", + "Average value of the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + standardDeviation = reactable::colDef( + header = withTooltip("SD", + "Standard deviation of the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + medianValue = reactable::colDef( + header = withTooltip("Median Value", + "Median value of the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + p10Value = reactable::colDef( + header = withTooltip("10th %tile", + "10th percentile value of the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + p25Value = reactable::colDef( + header = withTooltip("25th %tile", + "25th percentile value of the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + p75Value = reactable::colDef( + header = withTooltip("75th %tile", + "75th percentile value of the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + p90Value = reactable::colDef( + header = withTooltip("90th %tile", + "90th percentile value of the covariate"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ) + ) + return(result) +} + + + +getCountFromFE <- function( + sumValue, + averageValue +){ + + Ns <- sumValue/averageValue + if(sum(is.finite(Ns)) > 0 ){ + maxN <- max(Ns[is.finite(Ns)]) + } else{ + message('Issue calculating N') + maxN <- 0 + } + return(maxN) +} diff --git a/R/characterization-cohorts.R b/R/characterization-cohorts.R index 3452a52a..20ab24c6 100644 --- a/R/characterization-cohorts.R +++ b/R/characterization-cohorts.R @@ -17,214 +17,273 @@ # limitations under the License. -#' The module viewer for exploring 1 or more cohorts features -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the description cohorts features -#' -#' @export -characterizationTableViewer <- function(id) { +# view two cohorts and compare +characterizationCohortComparisonViewer <- function(id) { ns <- shiny::NS(id) - shiny::div( - - # infoHelperViewer( - # id = "helper", - # helpLocation= system.file("characterization-www", "help-targetViewer.html", package = utils::packageName()) - # ), - - + # module that does input selection for a single row DF - inputSelectionViewer( - id = ns("input-selection") - ), - - shiny::conditionalPanel( - condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection")), + shiny::div( - # add basic table - resultTableViewer(id = ns('mainTable')) - + # UI for inputs + # summary table + shinydashboard::box( + collapsible = TRUE, + title = "Options", + width = "100%", + shiny::uiOutput(ns("inputs")) + ), + + # displayed inputs + shiny::conditionalPanel( + condition = "input.generate != 0", + ns = ns, + + inputSelectionDfViewer(id = ns('inputSelected'), title = 'Selected'), + + # add basic table + shiny::tabsetPanel( + type = 'pills', + shiny::tabPanel( + title = 'Counts', + resultTableViewer(id = ns('countTable'), boxTitle = 'Counts') + ), + shiny::tabPanel( + title = 'Binary', + resultTableViewer(id = ns('mainTable'), boxTitle = 'Binary') + ), + shiny::tabPanel( + title = 'Continuous', + resultTableViewer(id = ns('continuousTable'), boxTitle = 'Continuous') + ) + ) + + ) ) - ) } -#' The module server for exploring 1 or more cohorts features -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the prediction result database -#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix -#' -#' @return -#' The server to the cohorts features server -#' -#' @export -characterizationTableServer <- function( + +characterizationCohortComparisonServer <- function( id, connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + options, + parents, + parentIndex, # reactive + subTargetId # reactive ) { shiny::moduleServer( id, function(input, output, session) { - inputVals <- getDecCohortsInputs( - connectionHandler, - resultDatabaseSettings - ) + inputVals <- shiny::reactive({characterizationGetCohortsInputs( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = subTargetId + )}) - # input selection component - inputSelected <- inputSelectionServer( - id = "input-selection", - inputSettingList = list( - createInputSetting( - rowNumber = 1, - columnWidth = 6, - varName = 'targetIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Target: ', - choices = inputVals$cohortIds, - selected = inputVals$cohortIds, - 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 = 'databaseIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Database: ', - choices = inputVals$databaseIds, - selected = inputVals$databaseIds[1], - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) + + # initial comp chilren + comparatorOptions <- characterizationGetChildren(options, 1) + output$inputs <- shiny::renderUI({ + + shiny::div( + shinyWidgets::pickerInput( + inputId = session$ns('comparatorGroup'), + label = 'Comparator Group: ', + choices = parents, + selected = parents[1], + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + #virtualScroll = 50, + #container = "div.tabbable", + dropupAuto = FALSE ) ), - createInputSetting( - rowNumber = 2, - columnWidth = 6, - varName = 'analysisIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Covariate Type: ', - choices = inputVals$analysisIds, - selected = inputVals$analysisIds[1], - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) + shiny::selectInput( + inputId = session$ns('comparatorId'), + label = 'Comparator: ', + choices = comparatorOptions, + selected = comparatorOptions[1], + multiple = F + ), + + shinyWidgets::pickerInput( + inputId = session$ns('databaseId'), + label = 'Database: ', + choices = inputVals()$databaseIds, + selected = inputVals()$databaseIds[1], + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + dropupAuto = F, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 500 ) - + ), + + shiny::actionButton( + inputId = session$ns('generate'), + label = 'Generate' + ) ) + + }) + + # update comparatorId + comparatorGroups <- shiny::reactiveVal() + comparatorIndex <- shiny::reactiveVal(1) + shiny::observeEvent(input$comparatorGroup,{ + comparatorIndex(which(input$comparatorGroup == parents)) + result <- characterizationGetChildren(options, comparatorIndex()) + comparatorGroups(result) + shiny::updateSelectInput( + session = session, + inputId = 'comparatorId', + label = 'Comparator: ', + choices = result, + selected = result[1] + ) + }) + + + # show selected inputs to user + inputSelectionDfServer( + id = 'inputSelected', + dataFrameRow = selected, + ncol = 1 ) - columns <- shiny::reactive({ + #get results + selected <- shiny::reactiveVal() + shiny::observeEvent(input$generate,{ - result <- list( - covariateId = reactable::colDef( - header = withTooltip("Covariate ID", - "Unique identifier of the covariate") - ), - covariateName = reactable::colDef( - header = withTooltip( - "Covariate Name", - "The name of the covariate" - ) - ), - analysisName = reactable::colDef( - header = withTooltip( - "Covariate Class", - "Class/type of the covariate" - ) + targetGroups <- characterizationGetChildren(options, parentIndex()) + + runTables <- TRUE + + if(is.null(subTargetId()) | is.null(input$comparatorId)){ + runTables <- FALSE + } + if(is.null(input$databaseId)){ + runTables <- FALSE + } + + if(subTargetId() == input$comparatorId){ + runTables <- FALSE + shiny::showNotification('Must select different cohorts') + } + + # ADDED + subTargetIds <- unlist(lapply(options[[parentIndex()]]$children, function(x){x$subsetId})) + subTargetNames <- unlist(lapply(options[[parentIndex()]]$children, function(x){x$subsetName})) + + selected( + data.frame( + Comparator = names(comparatorGroups())[which(comparatorGroups() == input$comparatorId)], + Database = names(inputVals()$databaseIds)[input$databaseId == inputVals()$databaseIds] ) ) - if(is.null(inputSelected()$targetIds) | is.null(inputSelected()$databaseIds)){ - return(result) - } else{ - temp <- expand.grid(inputSelected()$targetIds,inputSelected()$databaseIds) - temp[,2] <- as.double(as.character(temp[,2])) - - for(i in 1:nrow(temp)){ - - targetName = names(inputVals$cohortIds)[temp[i,1] == inputVals$cohortIds] - databaseName = names(inputVals$databaseIds)[temp[i,2] == inputVals$databaseIds] - - result[[length(result) + 1]] <- reactable::colDef( - header = withTooltip( - paste0("Count-", temp[i,1], '-',temp[i,2]), - paste0("The number of patients in database ", databaseName, ' and target ', targetName, ' who has the covariate') - ) - ) - - names(result)[length(result)] <- paste0('countT', temp[i,1], 'D', ifelse(temp[i,2] <0, 'n', ''), abs(temp[i,2]) ) - - result[[length(result) + 1]] <- reactable::colDef( - header = withTooltip( - paste0("Mean-", temp[i,1], '-', temp[i,2]), - paste0("The mean covariate value for patients in database ", databaseName, ' and target ', targetName) - ), - format = reactable::colFormat( - digits = 3 - ) - ) - names(result)[length(result)] <- paste0('averageT', temp[i,1], 'D', ifelse(temp[i,2] <0, 'n', ''), abs(temp[i,2]) ) - - } - return(result) + selection1 <- subTargetId() + + if(length(selection1) == 0){ + runTables <- FALSE + shiny::showNotification('No results for section 1') } - }) - - #get results - resultTable <- shiny::reactive({ - getCohortData( + selection2 <- input$comparatorId + + if(length(selection2) == 0){ + runTables <- FALSE + shiny::showNotification('No results for section 2') + } + + + if(runTables){ + resultTable <- characterizatonGetCohortData( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetIds = inputSelected()$targetIds, - databaseIds = inputSelected()$databaseIds, - analysisIds = inputSelected()$analysisIds + targetIds = c(selection1,selection2), + databaseIds = input$databaseId, + minThreshold = 0.01, + addSMD = T ) - }) - - resultTableServer( - id = 'mainTable', - df = resultTable, - colDefsInput = columns() - ) + + countTable <- characterizatonGetCohortCounts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = c(selection1,selection2), + databaseIds = input$databaseId + ) + + continuousTable <- characterizatonGetCohortComparisonDataContinuous( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = c(selection1,selection2), + databaseIds = input$databaseId + ) + + resultTableServer( + id = 'mainTable', + df = resultTable, + details = data.frame( + Target = names(targetGroups)[which(targetGroups == subTargetId())], + Comparator = names(comparatorGroups())[which(comparatorGroups() == input$comparatorId)], + Database = names(inputVals()$databaseIds)[input$databaseId == inputVals()$databaseIds], + Analysis = 'Cohort comparison within database' + ), + downloadedFileName = 'cohort_comparison_binary', + colDefsInput = characterizationCohortsColumns( + addExtras = T, + elementId = session$ns('main-table-filter') + ), + elementId = session$ns('main-table-filter') + ) + + resultTableServer( + id = 'continuousTable', + df = continuousTable, + details = data.frame( + Target = names(targetGroups)[which(targetGroups == subTargetId())], + Comparator = names(comparatorGroups())[which(comparatorGroups() == input$comparatorId)], + Database = names(inputVals()$databaseIds)[input$databaseId == inputVals()$databaseIds], + Analysis = 'Cohort comparison within database' + ), + downloadedFileName = 'cohort_comparison_cont', + colDefsInput = characterizationCohortsColumnsContinuous( + addExtras = T, + elementId = session$ns('continuous-table-filter') + ), + elementId = session$ns('continuous-table-filter') + ) + + resultTableServer( + id = 'countTable', + df = countTable, + details = data.frame( + Target = names(targetGroups)[which(targetGroups == subTargetId())], + Comparator = names(comparatorGroups())[which(comparatorGroups() == input$comparatorId)], + Database = names(inputVals()$databaseIds)[input$databaseId == inputVals()$databaseIds], + Analysis = 'Cohort comparison within database' + ), + downloadedFileName = 'cohort_comparison_count', + colDefsInput = characteriationCountTableColDefs( + elementId = session$ns('count-table-filter') + ), + elementId = session$ns('count-table-filter') + )} + + }) return(invisible(NULL)) @@ -233,168 +292,722 @@ characterizationTableServer <- function( } -getCohortData <- function( +characterizationCohortsColumns <- function( + addExtras = F, + elementId + ){ + + res <- list( + covariateName = reactable::colDef( + header = withTooltip( + "Covariate Name", + "The name of the covariate" + ), + minWidth = 300 + ), + covariateId = reactable::colDef( + show = F, + header = withTooltip("Covariate ID", + "Unique identifier of the covariate") + ), + minPriorObservation = reactable::colDef( + header = withTooltip( + "Min Prior Obs", + "The minimum prior observation a patient in the target + population must have to be included."), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + SMD = reactable::colDef( + header = withTooltip("SMD", + "Standardized mean difference between the target and comparator percentages"), + format = reactable::colFormat(digits = 3) + ), + absSMD = reactable::colDef( + header = withTooltip("absSMD", + "Absolute standardized mean difference between the target and comparator percentages"), + format = reactable::colFormat(digits = 3), + filterable = TRUE, + filterMethod = reactable::JS("function(rows, columnId, filterValue) { + return rows.filter(function(row) { + return row.values[columnId] >= filterValue + }) + }"), + filterInput = function(values, name) { + oninput <- sprintf("Reactable.setFilter('%s', '%s', this.value)", elementId, name) + shiny::tags$input( + type = "range", + min = floor(min(values, na.rm = T)), + max = ceiling(max(values, na.rm = T)), + value = floor(min(values, na.rm = T)), + oninput = oninput, + onchange = oninput, # For IE11 support + "aria-label" = sprintf("Filter by minimum %s", name) + ) + } + ), + analysisName = reactable::colDef( + header = withTooltip( + "Covariate Class", + "Class/type of the covariate" + ) + ) + ) + + if(addExtras){ + res <- append( + res, + list( + sumValue_1 = reactable::colDef( + header = withTooltip("Target Sum", + "The total sum of the covariate for the target cohort."), + cell = function(value) { + if (value >= 0) value else '< min threshold' + } + ), + sumValue_2 = reactable::colDef( + header = withTooltip("Compatator Sum", + "The total sum of the covariate for the comparator cohort."), + cell = function(value) { + if (value >= 0) value else '< min threshold' + } + ), + averageValue_1 = reactable::colDef( + header = withTooltip("Target %", + "The percentage of the target cohort who had the covariate prior to index."), + cell = function(value) { + if (value >= 0) paste0(round(value*100, digits = 3),'%') else '< min threshold' + } + ), + averageValue_2 = reactable::colDef( + header = withTooltip("Comparator %", + "The percentage of the comparator cohort who had the covariate prior to index"), + cell = function(value) { + if (value >= 0) paste0(round(value*100, digits = 3),'%') else '< min threshold' + } + ) + ) + ) + } + return(res) +} + +characteriationCountTableColDefs <- function( + elementId + ){ + result <- list( + selection = reactable::colDef( + filterable = T + ), + cohortName = reactable::colDef( + header = withTooltip("Cohort", + "Name of the cohort"), + filterable = T + ), + minPriorObservation = reactable::colDef( + header = withTooltip( + "Min Prior Obs", + "The minimum prior observation a patient in the target + population must have to be included."), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + rowCount = reactable::colDef( + header = withTooltip("Record Count", + "Count of the number of records"), + filterable = T + ), + personCount = reactable::colDef( + header = withTooltip("Person Count", + "Count of the number of persons"), + filterable = T + ) + ) + return(result) +} + +characterizationCohortsColumnsContinuous <- function( + addExtras = F, + elementId + ){ + res <- list( + covariateName = reactable::colDef( + header = withTooltip( + "Covariate Name", + "The name of the covariate" + ), + filterable = T, + minWidth = 300, + ), + databaseName = reactable::colDef( + header = withTooltip( + "Database", + "The name of the database" + ), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + covariateId = reactable::colDef( + show = F, + header = withTooltip("Covariate ID", + "Unique identifier of the covariate") + ), + minPriorObservation = reactable::colDef( + header = withTooltip( + "Min Prior Obs", + "The minimum prior observation a patient in the target + population must have to be included."), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + outcomeWashoutPeriod = reactable::colDef( + show = F + ), + countValue = reactable::colDef( + header = withTooltip("Count", + "Number of people with the covariate in the cohort."), + cell = function(value) { + if (value >= 0) value else '< min threshold' + }, + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + averageValue = reactable::colDef( + header = withTooltip("Mean", + "The mean value of the covariate in the cohort"), + cell = function(value) { + if (value >= 0) round(value, digits = 3) else '< min threshold' + } + ), + standardDeviation = reactable::colDef( + header = withTooltip("StDev", + "The standard deviation value of the covariate in the cohort"), + cell = function(value) { + if (value >= 0) round(value, digits = 3) else '< min threshold' + } + ), + medianValue = reactable::colDef( + header = withTooltip("Median", + "The median value of the covariate in the cohort."), + cell = function(value) { + round(value, digits = 3) + } + ), + minValue = reactable::colDef( + header = withTooltip("Min Value", + "Minimum value of the covariate in the cohort"), + format = reactable::colFormat(digits = 3) + ), + maxValue = reactable::colDef( + header = withTooltip("Max Value", + "Maximum value the covariate in the cohort"), + format = reactable::colFormat(digits = 3) + ), + p25Value = reactable::colDef( + header = withTooltip("25th %tile", + "25th percentile value of the covariate in the cohort"), + format = reactable::colFormat(digits = 3) + ), + p75Value = reactable::colDef( + header = withTooltip("75th %tile", + "75th percentile value of the covariate in the cohort"), + format = reactable::colFormat(digits = 3) + ), + p10Value = reactable::colDef( + header = withTooltip("10th %tile", + "10th percentile value of the covariate in the cohort"), + format = reactable::colFormat(digits = 3) + ), + p90Value = reactable::colDef( + header = withTooltip("90th %tile", + "90th percentile value of the covariate in the cohort"), + format = reactable::colFormat(digits = 3) + ) + ) + + if(addExtras){ + res <- append( + res, + list( + SMD = reactable::colDef( + header = withTooltip("SMD", + "Standardized mean difference"), + format = reactable::colFormat(digits = 3) + ), + absSMD = reactable::colDef( + header = withTooltip("absSMD", + "Absolute standardized mean difference"), + format = reactable::colFormat(digits = 3) + ), + countValue_1 = reactable::colDef( + header = withTooltip("Target Count", + "Number of people with the covariate for the target cohort."), + cell = function(value) { + if (value >= 0) value else '< min threshold' + } + ), + countValue_2 = reactable::colDef( + header = withTooltip("Comparator Count", + "Number of people with the covariate for the comparator cohort."), + cell = function(value) { + if (value >= 0) value else '< min threshold' + } + ), + averageValue_1 = reactable::colDef( + header = withTooltip("Target Mean", + "The mean of the covariate for the target cohort."), + cell = function(value) { + if (value >= 0) round(value, digits = 3) else '< min threshold' + } + ), + averageValue_2 = reactable::colDef( + header = withTooltip("Comparator Mean", + "The mean of the covariate for the comparator cohort."), + cell = function(value) { + if (value >= 0) round(value, digits = 3) else '< min threshold' + } + ), + standardDeviation_1 = reactable::colDef( + header = withTooltip("Target StDev", + "The standard deviation of the covariate for the target cohort."), + cell = function(value) { + if (value >= 0) round(value, digits = 3) else '< min threshold' + } + ), + standardDeviation_2 = reactable::colDef( + header = withTooltip("Comparator StDev", + "The standard deviation of the covariate for the comparator cohort."), + cell = function(value) { + if (value >= 0) round(value, digits = 3) else '< min threshold' + } + ), + medianValue_1 = reactable::colDef( + header = withTooltip("Target Median", + "The median of the covariate for the target cohort."), + cell = function(value) { + round(value, digits = 3) + } + ), + medianValue_2 = reactable::colDef( + header = withTooltip("Comparator Median", + "The median of the covariate for the comparator cohort."), + cell = function(value) { + round(value, digits = 3) + } + ), + minValue_2 = reactable::colDef( + header = withTooltip("Comparator Min Value", + "Minimum value of the comparator cohort"), + format = reactable::colFormat(digits = 3) + ), + minValue_1 = reactable::colDef( + header = withTooltip("Target Min Value", + "Minimum value of the target cohort"), + format = reactable::colFormat(digits = 3) + ), + maxValue_2 = reactable::colDef( + header = withTooltip("Comparator Max Value", + "Maximum value of the comparator cohort"), + format = reactable::colFormat(digits = 3) + ), + maxValue_1 = reactable::colDef( + header = withTooltip("Target Max Value", + "Maximum value of the target cohort"), + format = reactable::colFormat(digits = 3) + ), + p25Value_2 = reactable::colDef( + header = withTooltip("Comparator 25th %tile", + "25th percentile value of the comparator cohort"), + format = reactable::colFormat(digits = 3) + ), + p25Value_1 = reactable::colDef( + header = withTooltip("Target 25th %tile", + "25th percentile value of the target cohort"), + format = reactable::colFormat(digits = 3) + ), + p75Value_2 = reactable::colDef( + header = withTooltip("Comparator 75th %tile", + "75th percentile value of the comparator cohort"), + format = reactable::colFormat(digits = 3) + ), + p75Value_1 = reactable::colDef( + header = withTooltip("Target 75th %tile", + "75th percentile value of the target cohort"), + format = reactable::colFormat(digits = 3) + ) + ) + ) + } + + return(res) +} + + +characterizatonGetCohortCounts <- function( connectionHandler, resultDatabaseSettings, targetIds, - databaseIds, - analysisIds + databaseIds ){ - if(is.null(targetIds) | is.null(databaseIds)){ - return(NULL) + start <- Sys.time() + result <- connectionHandler$queryDb( + sql = " +select distinct + cc.target_cohort_id as cohort_definition_id, + cc.min_prior_observation, + cc.row_count, + cc.person_count, + d.cdm_source_abbreviation as database_name, + d.database_id, + cg.cohort_name + from + @schema.@database_table d + inner join + @schema.@c_table_prefixcohort_counts cc + on d.database_id = cc.database_id + inner join + @schema.@cg_table_prefixcohort_definition cg + on cg.cohort_definition_id = cc.target_cohort_id + + where + cc.target_cohort_id in (@target_ids) + and cc.cohort_type = 'Target' + AND cc.database_id in (@database_ids) + ; + ", + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + target_ids = paste0(targetIds, collapse= ','), + database_ids = paste0("'",databaseIds,"'",collapse= ','), + database_table = resultDatabaseSettings$databaseTable + ) + end <- Sys.time() - start + message(paste0('Extracting ', nrow(result) ,' cohort count rows took: ', round(end, digits = 2), ' ', units(end))) + + if(length(targetIds)>1){ + result <- merge( + x = result, + y = data.frame( + selection = c('Target','Comparator'), + cohortDefinitionId = targetIds + ), + by = 'cohortDefinitionId' + ) + } else{ + result$selection <- result$databaseName } - combinations <- expand.grid(targetIds, databaseIds) - combinations[,2] <- as.double(as.character(combinations[,2])) + result <- result %>% dplyr::select( + 'selection', + 'cohortName', + 'minPriorObservation', + 'rowCount', + 'personCount' + ) -sql <- paste0( -"select ref.covariate_id, ref.covariate_name, an.analysis_name,", - -paste( - lapply(1:nrow(combinations), function(i){ - paste0( -"max(case when temp.selection_id = ",i," then temp.sum_value else 0 end) as count_t",combinations[i,1],'_d',ifelse(combinations[i,2] <0, 'n', ''),abs(combinations[i,2]),",", -"max(case when temp.selection_id = ",i," then temp.average_value else 0 end) as average_t",combinations[i,1],'_d',ifelse(combinations[i,2] <0, 'n', ''),abs(combinations[i,2]) -)}), collapse = ','), - -" from @schema.@c_table_prefixcovariate_ref ref - inner join @schema.@c_table_prefixanalysis_ref an - on an.RUN_ID = ref.RUN_ID and - an.analysis_id = ref.analysis_id and - ref.analysis_id in (@analysis_ids) + return(result) +} - left join -( ", - +characterizatonGetCohortData <- function( + connectionHandler, + resultDatabaseSettings, + targetIds, + databaseIds, + minThreshold = 0.01, + addSMD = F +){ -paste( - lapply(1:nrow(combinations), function(i){ - paste0( - " - select - co",i,".run_id, co",i,".COVARIATE_ID, co",i,".SUM_VALUE, co",i,".AVERAGE_VALUE, - ",i," as selection_id - from - @schema.@c_table_prefixCOVARIATES co",i," - inner join - (select * from @schema.@c_table_prefixcohort_details - where DATABASE_ID = '@database",i,"' and - TARGET_COHORT_ID = @target",i," and COHORT_TYPE = 'T' - ) as cd",i," - on co",i,".COHORT_DEFINITION_ID = cd",i,".COHORT_DEFINITION_ID - and co",i,".DATABASE_ID = cd",i,".DATABASE_ID" - ) - - }), collapse = ' union '), - -") temp -on ref.run_id = temp.run_id and -ref.covariate_id = temp.covariate_id + if(is.null(targetIds) | is.null(databaseIds)){ + warning('Ids cannot be NULL') + return(NULL) + } -group by -ref.covariate_id, ref.covariate_name, an.analysis_name -" + shiny::withProgress(message = 'characterizatonGetCohortData', value = 0, { + + shiny::incProgress(1/4, detail = paste("Setting types")) + + types <- data.frame( + type = 1:(length(targetIds)*length(databaseIds)), + cohortDefinitionId = rep(targetIds, length(databaseIds)), + databaseId = rep(databaseIds, length(targetIds)) + ) + + shiny::incProgress(2/4, detail = paste("Extracting data")) + + sql <- "select ref.covariate_name, + s.min_prior_observation, + cov.target_cohort_id as cohort_definition_id, + cov.* from + @schema.@c_table_prefixCOVARIATES cov + inner join + @schema.@c_table_prefixcovariate_ref ref + on cov.covariate_id = ref.covariate_id + and cov.setting_id = ref.setting_id + and cov.database_id = ref.database_id + inner join + @schema.@c_table_prefixsettings s + on s.database_id = cov.database_id + and s.setting_id = cov.setting_id + + where + cov.target_cohort_id in (@target_ids) + and cov.cohort_type = 'Target' + AND cov.database_id in (@database_ids) + AND cov.average_value >= @min_threshold;" + + start <- Sys.time() + # settings.min_characterization_mean needed? + res <- connectionHandler$queryDb( + sql = sql, + target_ids = paste0(targetIds, collapse = ','), + database_ids = paste0("'",databaseIds,"'", collapse = ','), + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + min_threshold = minThreshold + ) + end <- Sys.time() - start + shiny::incProgress(3/4, detail = paste("Extracted data")) + message(paste0('Extracting ', nrow(res) ,' characterization cohort rows took: ', round(end, digits = 2), ' ', units(end))) + + # add the first/section type + res <- merge(res, types, by = c('cohortDefinitionId','databaseId')) + + # pivot + result <- tidyr::pivot_wider( + data = res, + id_cols = c('covariateName', 'covariateId','minPriorObservation'), + names_from = 'type', + values_from = c('sumValue', 'averageValue'), + values_fn = mean, + values_fill = -1 + ) + + if(addSMD == T){ + # TODO get min_characterization_mean from settings table + # minCharacterizationMean <- minThreshold + # add SMD + if(sum(c('averageValue_1','averageValue_2') %in% colnames(result)) == 2){ + convertMissing <- function(vec){sapply(vec, function(x) ifelse(x==-1, minThreshold, x))} + + Ns <- c() + for(minPriorObservation in unique(result$minPriorObservation)){ + ind <- result$minPriorObservation == minPriorObservation + Ns <- rbind(Ns, + data.frame( + minPriorObservation = minPriorObservation, + N_1 = max(result$sumValue_1[ind]/result$averageValue_1[ind], na.rm = T), + N_2 = max(result$sumValue_2[ind]/result$averageValue_2[ind], na.rm = T) + ) + ) + } + result <- merge(result, Ns, by = 'minPriorObservation') + result$firstVar <- ((convertMissing(result$averageValue_1)-1)^2*result$sumValue_1 + (convertMissing(result$averageValue_1)-0)^2*(result$N_1-result$sumValue_1))/result$N_1 + result$secondVar <- ((convertMissing(result$averageValue_2)-1)^2*result$sumValue_2 + (convertMissing(result$averageValue_2)-0)^2*(result$N_2-result$sumValue_2))/result$N_2 + result$SMD <- (convertMissing(result$averageValue_1) - convertMissing(result$averageValue_2))/(sqrt((result$firstVar+result$secondVar)/2)) + result$absSMD <- abs(result$SMD) + result <- result %>% dplyr::select(-"firstVar",-"secondVar", -"N_1", -"N_2") + + } else{ + shiny::showNotification('Unable to add SMD due to missing columns') + } + } + shiny::incProgress(4/4, detail = paste("Done")) + }) + + return(result) +} -) +characterizatonGetCohortComparisonDataContinuous <- function( + connectionHandler, + resultDatabaseSettings, + targetIds, + databaseIds, + pivot = T +){ - inputs <- c( - as.character(combinations$Var2), - as.character(combinations$Var1), - resultDatabaseSettings$schema, - resultDatabaseSettings$cTablePrefix, - paste0(analysisIds, collapse = ',') - ) - names(inputs) <- c( - paste0('database', 1:nrow(combinations)), - paste0('target', 1:nrow(combinations)), - 'schema', - 'c_table_prefix', - 'analysis_ids' - ) - inputs <- as.list(inputs) - inputs$sql <- sql + if(is.null(targetIds) | is.null(databaseIds)){ + warning('Ids cannot be NULL') + return(NULL) + } + targetIds <- unique(targetIds) + databaseIds <- unique(databaseIds) - result <- do.call(connectionHandler$queryDb, inputs) - -return(result) + shiny::withProgress(message = 'characterizatonGetCohortDataContinuous', value = 0, { + + shiny::incProgress(1/4, detail = paste("Setting types")) + + types <- data.frame( + type = 1:(length(targetIds)*length(databaseIds)), + cohortDefinitionId = rep(targetIds, length(databaseIds)), + databaseId = rep(databaseIds, length(targetIds)) + ) + + shiny::incProgress(2/4, detail = paste("Extracting data")) + + sql <- "select ref.covariate_name, + s.min_prior_observation, + cov.target_cohort_id as cohort_definition_id, + cov.*, + d.CDM_SOURCE_ABBREVIATION as database_name + + from + @schema.@c_table_prefixCOVARIATES_continuous cov + inner join + @schema.@c_table_prefixcovariate_ref ref + on cov.covariate_id = ref.covariate_id + and cov.setting_id = ref.setting_id + and cov.database_id = ref.database_id + inner join + @schema.@c_table_prefixsettings s + on cov.setting_id = s.setting_id + and cov.database_id = s.database_id + inner join @schema.@database_meta_table d + on s.database_id = d.database_id + + where + cov.target_cohort_id in (@target_ids) + and cov.cohort_type = 'Target' + AND cov.database_id in (@database_ids);" + + start <- Sys.time() + # settings.min_characterization_mean needed? + res <- connectionHandler$queryDb( + sql = sql, + target_ids = paste0(targetIds, collapse = ','), + database_ids = paste0("'",databaseIds,"'", collapse = ','), + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + database_meta_table = resultDatabaseSettings$databaseTable + ) + end <- Sys.time() - start + shiny::incProgress(3/4, detail = paste("Extracted data")) + message(paste0('Extracting ', nrow(res) ,' continuous characterization cohort rows took: ', round(end, digits = 2), ' ', units(end))) + + # add the first/section type + res <- merge(res, types, by = c('cohortDefinitionId','databaseId')) + + if(pivot){ + # if pivot + res <- tidyr::pivot_wider( + data = res, + id_cols = c('covariateName', 'covariateId','minPriorObservation'), + names_from = 'type', + values_from = c('countValue', 'averageValue', 'standardDeviation', 'medianValue','minValue', 'maxValue', 'p25Value','p75Value'), + values_fn = mean, + values_fill = -1 + ) + + # if both have results then add SMD + if(length(unique(res$type)) == 2){ + res <- res %>% + dplyr::mutate( + SMD = (.data$averageValue_1-.data$averageValue_2)/(sqrt((.data$standardDeviation_1^2 + .data$standardDeviation_2^2)/2)) + ) %>% + dplyr::mutate( + absSMD = abs(.data$SMD) + ) + } + } else{ + # if multiple databases make the type the databaseName + res$type <- res$databaseName + res <- res %>% dplyr::select(-"cohortDefinitionId", -"databaseId", -"type", + -"settingId", -"targetCohortId", -"outcomeCohortId", + -"cohortType") %>% + dplyr::relocate("databaseName", .after = "covariateName") + } + + shiny::incProgress(4/4, detail = paste("Done")) + }) + + return(res) } - - -getDecCohortsInputs <- function( +characterizationGetCohortsInputs <- function( connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + targetId # reactive ) { - #shiny::withProgress(message = 'Getting target comparison inputs', value = 0, { - - - sql <- - ' select distinct c.cohort_definition_id, c.cohort_name from - @schema.@cg_table_prefixcohort_definition c - inner join - (select distinct TARGET_COHORT_ID as id - from @schema.@c_table_prefixcohort_details - ) ids - on ids.id = c.cohort_definition_id - ;' - - #shiny::incProgress(1/4, detail = paste("Extracting targetIds")) - - idVals <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix - ) - ids <- idVals$cohortDefinitionId - names(ids) <- idVals$cohortName - - #shiny::incProgress(2/4, detail = paste("Extracted targetIds")) - - sql <- 'select d.database_id, d.cdm_source_abbreviation as database_name - from @schema.@database_table d;' + sql <- "select distinct + d.database_id, d.cdm_source_abbreviation as database_name + from @schema.@database_table d - #shiny::incProgress(3/4, detail = paste("Extracting databaseIds")) + inner join + @schema.@c_table_prefixcohort_details cd + on d.database_id = cd.database_id + where cd.target_cohort_id = @target_id + and cd.cohort_type = 'Target' + ;" database <- connectionHandler$queryDb( sql = sql, schema = resultDatabaseSettings$schema, - database_table = resultDatabaseSettings$databaseTable + database_table = resultDatabaseSettings$databaseTable, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + target_id = targetId() ) databaseIds <- database$databaseId names(databaseIds) <- database$databaseName - - sql <- 'select distinct analysis_id, analysis_name - from @schema.@c_table_prefixanalysis_ref order by analysis_name desc;' - - #shiny::incProgress(3/4, detail = paste("Extracting databaseIds")) - - analyses <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix - ) - analysisIds <- analyses$analysisId - names(analysisIds) <- analyses$analysisName - - - #shiny::incProgress(4/4, detail = paste("Done")) - - # }) - return( list( - cohortIds = ids, - databaseIds = databaseIds, - analysisIds = analysisIds + databaseIds = databaseIds ) ) - -} +} \ No newline at end of file diff --git a/R/characterization-database.R b/R/characterization-database.R new file mode 100644 index 00000000..46b3b31e --- /dev/null +++ b/R/characterization-database.R @@ -0,0 +1,320 @@ +# @file characterization-timeToEvent.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. + + +# view two cohorts and compare +characterizationDatabaseComparisonViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::div( + + # UI for inputs + # summary table + shinydashboard::box( + collapsible = TRUE, + title = "Options", + width = "100%", + shiny::uiOutput(ns("inputs")) + ), + + # displayed inputs + shiny::conditionalPanel( + condition = "input.generate != 0", + ns = ns, + + inputSelectionDfViewer(id = ns('inputSelected'), title = 'Selected'), + + # add basic table + shiny::tabsetPanel( + type = 'pills', + shiny::tabPanel( + title = 'Counts', + resultTableViewer(id = ns('countTable'), boxTitle = 'Counts') + ), + shiny::tabPanel( + title = 'Binary', + resultTableViewer(id = ns('mainTable'), boxTitle = 'Binary') + ), + shiny::tabPanel( + title = 'Continuous', + resultTableViewer(id = ns('continuousTable'), boxTitle = 'Continuous') + ) + ) + ) + ) +} + + + +characterizationDatabaseComparisonServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + options, + parents, + parentIndex, # reactive + subTargetId # reactive +) { + shiny::moduleServer( + id, + function(input, output, session) { + + # TODO react to subTargetId + inputVals <- shiny::reactive({ + characterizationGetCohortsInputs( + connectionHandler, + resultDatabaseSettings, + targetId = subTargetId + )}) + + output$inputs <- shiny::renderUI({ + + shiny::div( + shiny::selectInput( + inputId = session$ns('databaseIds'), + label = 'Databases: ', + choices = inputVals()$databaseIds, + selected = inputVals()$databaseIds[1], + multiple = T + ), + + shiny::sliderInput( + inputId = session$ns('minThreshold'), + label = 'Covariate Threshold', + min = 0, + max = 1, + value = 0.01, + step = 0.01, + ticks = F + ), + + shiny::actionButton( + inputId = session$ns('generate'), + label = 'Generate' + ) + ) + + }) + + + # show selected inputs to user + inputSelectionDfServer( + id = 'inputSelected', + dataFrameRow = selected, + ncol = 1 + ) + + #get results + selected <- shiny::reactiveVal() + shiny::observeEvent(input$generate,{ + + if(is.null(input$databaseIds)){ + shiny::showNotification('No databases selected') + return(NULL) + } + if(length(input$databaseIds) == 0 ){ + shiny::showNotification('No databases selected') + return(NULL) + } + + selectedDatabases <- paste0( + names(inputVals()$databaseIds)[which(inputVals()$databaseIds %in% input$databaseIds)], + collapse = ',' + ) + + selected( + data.frame( + Databases = selectedDatabases, + `Minimum Covariate Threshold` = input$minThreshold + ) + ) + + + #get results + results <- list( + table = data.frame(), + databaseNames = data.frame( + id = 1, + databaseName = 'None' + ) + ) + continuousTable <- data.frame() + countTable <- data.frame() + + if(length(input$databaseIds) > 0){ + + countTable <- characterizatonGetCohortCounts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = subTargetId(), + databaseIds = input$databaseIds + ) + + result <- characterizatonGetDatabaseComparisonData( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = subTargetId(), + databaseIds = input$databaseIds, + minThreshold = input$minThreshold + ) + + continuousTable <- characterizatonGetCohortComparisonDataContinuous( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = subTargetId(), + databaseIds = input$databaseIds, + pivot = F + ) + + } else{ + shiny::showNotification('No results') + } + + + databaseNames <- result$databaseNames + + meanColumns <- lapply(1:nrow(databaseNames), function(i){ + reactable::colDef( + header = withTooltip( + paste0(databaseNames$databaseName[i], ' %'), + paste0("The percentage of the target population in database ", databaseNames$databaseName[i], ' who had the covariate prior.') + ), + cell = function(value) { + if (value >= 0) paste0(round(value*100, digits = 3),' %') else '< min threshold' + } + ) + }) + names(meanColumns) <- unlist(lapply(1:nrow(databaseNames), function(i) paste0('averageValue_',databaseNames$id[i]))) + + sumColumns <- lapply(1:nrow(databaseNames), function(i){ + reactable::colDef( + header = withTooltip( + paste0(databaseNames$databaseName[i], " Count"), + paste0("The number of people in the target cohort in database ", databaseNames$databaseName[i], ' who have the covariate prior.') + ), + cell = function(value) { + if (value >= 0) value else '< min threshold' + } + ) + }) + names(sumColumns) <- unlist(lapply(1:nrow(databaseNames), function(i) paste0('sumValue_',databaseNames$id[i]))) + + targetGroups <- characterizationGetChildren(options, parentIndex()) + + resultTableServer( + id = 'countTable', + df = countTable, + details = data.frame( + Target = names(targetGroups)[which(targetGroups == subTargetId())], + Databases = selectedDatabases, + `Minimum Covariate Threshold` = input$minThreshold, + Analysis = 'Cohort comparison across databases' + ), + downloadedFileName = 'database_comparison_counts', + colDefsInput = characteriationCountTableColDefs( + elementId = session$ns('count-table-filter') + ), + elementId = session$ns('count-table-filter') + ) + resultTableServer( + id = 'mainTable', + df = result$table, + details = data.frame( + Target = names(targetGroups)[which(targetGroups == subTargetId())], + Databases = selectedDatabases, + `Minimum Covariate Threshold` = input$minThreshold, + Analysis = 'Cohort comparison across databases' + ), + downloadedFileName = 'database_comparison_binary', + colDefsInput = append( + characterizationCohortsColumns( + elementId = session$ns('main-table-filter') + ), + append( + sumColumns, + meanColumns + ) + ), + elementId = session$ns('main-table-filter') + ) + + resultTableServer( + id = 'continuousTable', + df = continuousTable, + details = data.frame( + Target = names(targetGroups)[which(targetGroups == subTargetId())], + Databases = selectedDatabases, + `Minimum Covariate Threshold` = input$minThreshold, + Analysis = 'Cohort comparison across databases' + ), + downloadedFileName = 'database_comparison_cont', + colDefsInput = characterizationCohortsColumnsContinuous( + elementId = session$ns('continuous-table-filter') + ), + elementId = session$ns('continuous-table-filter') + ) + }) + + + return(invisible(NULL)) + + }) + +} + +characterizatonGetDatabaseComparisonData <- function( + connectionHandler, + resultDatabaseSettings, + targetIds, + databaseIds, + minThreshold +){ + + result <- characterizatonGetCohortData( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + databaseIds = databaseIds, + minThreshold = minThreshold, + addSMD = length(databaseIds) == 2 + ) + + databaseNames <- connectionHandler$queryDb( + sql = "select cdm_source_abbreviation as database_name, database_id + from @schema.@database_table;", + schema = resultDatabaseSettings$schema, + database_table = resultDatabaseSettings$databaseTable + ) + + databaseNames <- merge( + databaseNames, + data.frame( + id = 1:length(databaseIds), + databaseId = databaseIds + ), + by = 'databaseId' + ) + + return( + list( + table = result, + databaseNames = databaseNames + ) + ) + +} diff --git a/R/characterization-dechallengeRechallenge.R b/R/characterization-dechallengeRechallenge.R index 3a356aea..57e7b4a4 100644 --- a/R/characterization-dechallengeRechallenge.R +++ b/R/characterization-dechallengeRechallenge.R @@ -17,160 +17,254 @@ # limitations under the License. -#' The module viewer for exploring Dechallenge Rechallenge results -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the description Dechallenge Rechallenge module -#' -#' @export characterizationDechallengeRechallengeViewer <- function(id) { ns <- shiny::NS(id) shiny::div( - - - # input component module - inputSelectionViewer(id = ns('input-selection')), - - shiny::conditionalPanel( - condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection")), - - resultTableViewer(ns('tableResults')) + shiny::uiOutput(ns('warning')), - - ) + shinydashboard::box( + status = 'info', + width = '100%', + solidHeader = TRUE, + resultTableViewer(ns('tableResults')) + ) ) } - -#' The module server for exploring Dechallenge Rechallenge results -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the prediction result database -#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix -#' -#' @return -#' The server to the Dechallenge Rechallenge module -#' -#' @export characterizationDechallengeRechallengeServer <- function( id, connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + targetId, + outcomeId ) { shiny::moduleServer( id, function(input, output, session) { - - # get the possible target ids - bothIds <- dechalRechalGetIds( - connectionHandler, - resultDatabaseSettings - ) - # input selection component - inputSelected <- inputSelectionServer( - id = "input-selection", - inputSettingList = list( - createInputSetting( - rowNumber = 1, - columnWidth = 6, - varName = 'targetId', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Target: ', - choices = bothIds$targetIds, - #choicesOpt = list(style = rep_len("color: black;", 999)), - selected = bothIds$targetIds[1], - 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 = 'outcomeId', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Outcome: ', - choices = bothIds$outcomeIds, - #choicesOpt = list(style = rep_len("color: black;", 999)), - selected = bothIds$outcomeIds[1], - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) + options <- shiny::reactive({ + characterizationGetCaseSeriesOptions( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = targetId(), + outcomeId = outcomeId() ) - ) + }) + + # fetch data when targetId changes allData <-shiny::reactive({ getDechalRechalInputsData( - targetId = inputSelected()$targetId, - outcomeId = inputSelected()$outcomeId, + targetId = targetId(), + outcomeId = outcomeId(), connectionHandler = connectionHandler, resultDatabaseSettings ) }) + + + # warning when not unique + targetUniquePeople <- shiny::reactive({ + isCohortUniquePeople( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + cohortId = targetId() + ) + }) + + outcomeUniquePeople <- shiny::reactive({ + isCohortUniquePeople( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + cohortId = outcomeId() + ) + }) + + output$warning <- shiny::renderUI( + if(targetUniquePeople() || outcomeUniquePeople()){ + shinydashboard::box( + status = 'warning', + width = '100%', + title = shiny::span( shiny::icon("triangle-exclamation"),'Warnings'), + solidHeader = TRUE, + shiny::p( + ifelse(targetUniquePeople(), + 'WARNING: The target cohort does not have multiple records per person, so observing rechallenge attempts not possible.', + '') + ), + shiny::p( + ifelse(outcomeUniquePeople(), + 'WARNING: The outcome cohort does not have multiple records per person, so observing rechallenge attempts not possible.', + '') + ) + ) + } else{ + shiny::renderUI(shiny::div()) + } + ) - #databases(allData$databaseId) - #dechallengeStopInterval(allData$dechallengeStopInterval) - #dechallengeEvaluationWindow(allData$dechallengeEvaluationWindow) - - tableOutputs <- resultTableServer( - id = "tableResults", - df = allData, - colDefsInput = list( - targetCohortDefinitionId = reactable::colDef(show = F), - databaseId = reactable::colDef(show = F), - outcomeCohortDefinitionId = reactable::colDef(show = F), - - databaseName = reactable::colDef(name = 'Database'), - + + characteriationDechalRechalColDefs <- function(){ + result <- list( + databaseName = reactable::colDef( + header = withTooltip("Database", + "Name of the database"), + filterable = T + ), + databaseId = reactable::colDef( + show = F + ), + targetCohortDefinitionId = reactable::colDef( + show = F + ), + outcomeCohortDefinitionId = reactable::colDef( + show = F + ), + dechallengeStopInterval = reactable::colDef( + header = withTooltip("Dechallenge Stop Interval", + "An integer specifying the how much time to add to the cohort_end when determining whether the event starts during cohort and ends after"), + filterable = T + ), + dechallengeEvaluationWindow = reactable::colDef( + header = withTooltip("Dechallenge Evaluation Window", + "A period of time evaluated for outcome recurrence after discontinuation of exposure, among patients with challenge outcomes"), + filterable = T + ), + numExposureEras = reactable::colDef( + header = withTooltip("# of Exposure Eras", + "Distinct number of exposure events (i.e. drug eras) in a given target cohort"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), + numPersonsExposed = reactable::colDef( + header = withTooltip("# of Exposed Persons", + "Distinct nuber of people exposed in target cohort. A person must have at least 1 day exposure to be included"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), + numCases = reactable::colDef( + header = withTooltip("# of Cases", + "Distinct number of persons in outcome cohort. A person must have at least 1 day of observation time to be included"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), + dechallengeAttempt = reactable::colDef( + header = withTooltip("# of Dechallenge Attempts", + "Distinct count of people with observable time after discontinuation of the exposure era during which the challenge outcome occurred"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), + dechallengeFail = reactable::colDef( + header = withTooltip("# of Dechallenge Fails", + "Among people with challenge outcomes, the distinct number of people with outcomes during dechallengeEvaluationWindow"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), + dechallengeSuccess = reactable::colDef( + header = withTooltip("# of Dechallenge Successes", + "Among people with challenge outcomes, the distinct number of people without outcomes during the dechallengeEvaluationWindow"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), + rechallengeAttempt = reactable::colDef( + header = withTooltip("# of Rechallenge Attempts", + "Number of people with a new exposure era after the occurrence of an outcome during a prior exposure era"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), + rechallengeFail = reactable::colDef( + header = withTooltip("# of Rechallenge Fails", + "Number of people with a new exposure era during which an outcome occurred, after the occurrence of an outcome during a prior exposure era"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), + rechallengeSuccess = reactable::colDef( + header = withTooltip("# of Rechallenge Successes", + "Number of people with a new exposure era during which an outcome did not occur, after the occurrence of an outcome during a prior exposure era"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else abs(value) + } + ), pctDechallengeAttempt = reactable::colDef( + header = withTooltip("% of Dechallenge Attempts", + "Percent of people with observable time after discontinuation of the exposure era during which the challenge outcome occurred"), + filterable = T, + #format = reactable::colFormat(digits = 2, percent = T), format = reactable::colFormat(digits = 2, percent = T) ), pctDechallengeSuccess = reactable::colDef( + header = withTooltip("% of Dechallenge Success", + "Among people with challenge outcomes, the percent of people with outcomes during dechallengeEvaluationWindow"), + filterable = T, format = reactable::colFormat(digits = 2, percent = T) ), pctDechallengeFail = reactable::colDef( + header = withTooltip("% of Dechallenge Fail", + "Among people with challenge outcomes, the percent of people without outcomes during the dechallengeEvaluationWindow"), + filterable = T, format = reactable::colFormat(digits = 2, percent = T) ), pctRechallengeAttempt = reactable::colDef( + header = withTooltip("% of Rechallenge Attempts", + "Percent of people with a new exposure era after the occurrence of an outcome during a prior exposure era"), + filterable = T, format = reactable::colFormat(digits = 2, percent = T) ), pctRechallengeSuccess = reactable::colDef( + header = withTooltip("% of Rechallenge Success", + "Percent of people with a new exposure era during which an outcome occurred, after the occurrence of an outcome during a prior exposure era"), + filterable = T, format = reactable::colFormat(digits = 2, percent = T) ), pctRechallengeFail = reactable::colDef( + header = withTooltip("% of Rechallenge Fail", + "Percent of people with a new exposure era during which an outcome did not occur, after the occurrence of an outcome during a prior exposure era"), + filterable = T, format = reactable::colFormat(digits = 2, percent = T) ) - ), + ) + return(result) + } + + tableOutputs <- resultTableServer( + id = "tableResults", + df = allData, + details = data.frame( + target = options()$targetName, + outcome = options()$outcomeName, + Analysis = 'Exposed Cases Summary - Dechallenge-Rechallenge' + ), + downloadedFileName = 'dechallege-rechallenge', + colDefsInput = characteriationDechalRechalColDefs(), addActions = c('fails') ) @@ -179,8 +273,8 @@ characterizationDechallengeRechallengeServer <- function( if(!is.null(tableOutputs$actionType())){ if(tableOutputs$actionType() == 'fails'){ result <- getDechalRechalFailData( - targetId = inputSelected()$targetId, - outcomeId = inputSelected()$outcomeId, + targetId = targetId(), + outcomeId = outcomeId(), databaseId = allData()$databaseId[tableOutputs$actionIndex()$index], # update? dechallengeStopInterval = allData()$dechallengeStopInterval[tableOutputs$actionIndex()$index], dechallengeEvaluationWindow = allData()$dechallengeEvaluationWindow[tableOutputs$actionIndex()$index], @@ -201,7 +295,7 @@ characterizationDechallengeRechallengeServer <- function( ) ) } else{ - showNotification("No fails to display") + shiny::showNotification("No fails to display") } } } @@ -223,6 +317,7 @@ characterizationDechallengeRechallengeServer <- function( ) } +# can delete? dechalRechalGetIds <- function( connectionHandler, resultDatabaseSettings @@ -372,6 +467,33 @@ getDechalRechalFailData <- function( } +isCohortUniquePeople <- function( + connectionHandler, + resultDatabaseSettings, + cohortId +) { + + sql <- "SELECT + cc.database_id, cc.cohort_id, cc.cohort_entries, cc.cohort_subjects + FROM @schema.@cg_table_prefixCOHORT_COUNT cc + where cc.cohort_id = @cohort_id + ;" + res <- tryCatch({connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + cohort_id = cohortId + )}, error = function(e){return(NULL)} + ) + + # if table is missing the warning will not happen + if(is.null(res)){ + return(T) + }else{ + return(sum(res$cohortEntries == res$cohortSubjects) == nrow(res)) + } +} + plotDechalRechal <- function( dechalRechalData, i = 1 diff --git a/R/characterization-incidence.R b/R/characterization-incidence.R index 07a6a58f..60a2d20b 100644 --- a/R/characterization-incidence.R +++ b/R/characterization-incidence.R @@ -38,43 +38,6 @@ as_ggplot <- function(x){ } -# is_null_unit <- function (x) -# { -# if (!grid::is.unit(x)) { -# return(FALSE) -# } -# all(grid::unitType(x) == "null") -# } -# -# force_panelsizes <- function(rows = NULL, cols = NULL, respect = NULL, total_width = NULL, total_height = NULL) { -# if (!is.null(rows) & !grid::is.unit(rows)) { -# rows <- grid::unit(rows, "null") -# } -# if (!is.null(cols) & !grid::is.unit(cols)) { -# cols <- grid::unit(cols, "null") -# } -# if (!is.null(total_width)) { -# if (grid::is.unit(cols) && !is_null_unit(cols)) { -# stop("Cannot set {.arg total_width} when {.arg cols} is not relative.") -# } -# if (!grid::is.unit(total_width)) { -# stop("{.arg total_width} must be a {.cls unit} object.") -# } -# rlang::arg_match0(grid::unitType(total_width), c("cm", "mm", "inches", "points")) -# } -# if (!is.null(total_height)) { -# if (grid::is.unit(rows) && !is_null_unit(rows)) { -# stop("Cannot set {.arg total_height} when {.arg rows} is not relative.") -# } -# if (!grid::is.unit(total_height)) { -# stop("{.arg total_height} must be a {.cls unit} object.") -# } -# rlang::arg_match0(grid::unitType(total_height), c("cm", "mm", "inches", "points")) -# } -# structure(list(rows = rows, cols = cols, respect = respect, total_width = total_width, total_height = total_height), class = "forcedsize") -# } - - # Define the custom age sorting function custom_age_sort <- function(age_categories) { # Extract the largest integer from each category @@ -87,29 +50,19 @@ custom_age_sort <- function(age_categories) { return(custom_order) } -base_breaks <- function(n = 10){ - function(x) { - axisTicks(log10(range(x, na.rm = TRUE)), log = TRUE, n = n) - } -} - break_setter = function(n = 5) { function(lims) {pretty(x = as.numeric(lims), n = n)} } - - - - #' The module viewer for exploring incidence results #' #' @details #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {Characterization} #' @return #' The user interface to the description incidence module #' @@ -117,16 +70,12 @@ break_setter = function(n = 5) { characterizationIncidenceViewer <- function(id) { ns <- shiny::NS(id) shiny::div( - - - inputSelectionViewer( - id = ns("input-selection-results") - ), + shiny::uiOutput(ns("inputOptions")), shiny::conditionalPanel( condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection-results")), + ns = ns, shiny::tabsetPanel( type = 'pills', @@ -281,7 +230,11 @@ characterizationIncidenceViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix -#' +#' @param parents a list of parent cohorts +#' @param parentIndex an integer specifying the parent index of interest +#' @param outcomes a reactive object specifying the outcomes of interest +#' @param targetIds a reactive vector of integer specifying the targetIds of interest +#' @family {Characterization} #' @return #' The server to the prediction incidence module #' @@ -289,523 +242,442 @@ characterizationIncidenceViewer <- function(id) { characterizationIncidenceServer <- function( id, connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + #options, # this gets overwritten in code below - why here? + parents, + parentIndex, # reactive + outcomes, # reactive + targetIds # reactive ) { shiny::moduleServer( id, function(input, output, session) { - ## ns <- session$ns - - options <- getIncidenceOptions( # written using getTargetOutcomes - connectionHandler, - resultDatabaseSettings - ) - - sortedAges <- custom_age_sort(options$ageGroupName) - - # Extract the integers from each TAR string - tarIntegers <- as.integer(gsub("[^0-9]", "", options$tar)) - # Sort the vector based on the extracted integers - sortedTars <- options$tar[order(tarIntegers)] - - # input selection component - inputSelectedResults <- inputSelectionServer( - id = "input-selection-results", - inputSettingList = list( - createInputSetting( - rowNumber = 1, - columnWidth = 12, - varName = 'firsttext', - inputReturn = T, - uiFunction = 'shiny::div', - uiInputs = list( - "Select Your Results", - style = "font-weight: bold; font-size: 20px; text-align: center; margin-bottom: 20px;" - ) - ), - createInputSetting( - rowNumber = 2, - columnWidth = 4, - varName = 'targetIds', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Target: ', - choices = options$targetIds, - selected = options$targetIds[1], #default should be just one (the first) - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - createInputSetting( - rowNumber = 2, - columnWidth = 4, - varName = 'outcomeIds', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Outcome: ', - choices = options$outcomeIds, - selected = options$outcomeIds[1], #default should be just one (the first) - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - - createInputSetting( - rowNumber = 2, - columnWidth = 4, - varName = 'incidenceRateDbFilter', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Database:', - choices = options$cdmSourceAbbreviations, - selected = options$cdmSourceAbbreviations, - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - - # third row - createInputSetting( - rowNumber = 3, - columnWidth = 3, - varName = 'incidenceRateAgeFilter', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - collapse = T, - uiInputs = list( - label = 'Filter By Age Group: ', - choices = sortedAges, - selected = sortedAges, - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - - - createInputSetting( - rowNumber = 3, - columnWidth = 3, - varName = 'incidenceRateGenderFilter', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - collapse = T, - uiInputs = list( - label = 'Filter By Sex: ', - choices = sort(options$genderName, decreasing = F), - selected = options$genderName, - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - - createInputSetting( - rowNumber = 3, - columnWidth = 3, - varName = 'incidenceRateCalendarFilter', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - collapse = T, - uiInputs = list( - label = 'Filter By Start Year: ', - choices = sort(options$startYear, decreasing = T), - selected = options$startYear, - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - - createInputSetting( - rowNumber = 3, - columnWidth = 3, - varName = 'incidenceRateTarFilter', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Select Time at risk (TAR)', - choices = sortedTars, - selected = sortedTars[1], - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) + + ciOptions <- getIncidenceOptions(connectionHandler, resultDatabaseSettings) + + output$inputOptions <- shiny::renderUI({ + shinydashboard::box( + collapsible = TRUE, + title = "Options", + width = "100%", + + shiny::div( + "Select Your Results", + style = "font-weight: bold; font-size: 20px; text-align: center; margin-bottom: 20px;" + ), + + shiny::selectInput( + inputId = session$ns('outcomeIds'), + label = 'Outcome: ', + choices = outcomes(), + selected = 1, + multiple = T, + selectize = TRUE, + width = NULL, + size = NULL + ), + + shinyWidgets::pickerInput( + inputId = session$ns('databaseSelector'), + label = 'Filter By Database: ', + choices = ciOptions$databases, + selected = ciOptions$databases, + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ), + + shinyWidgets::pickerInput( + inputId = session$ns('ageIds'), + label = 'Filter By Age Group: ', + choices = ciOptions$ageGroup, + selected = ciOptions$ageGroup, + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ), + + shinyWidgets::pickerInput( + inputId = session$ns('sexIds'), + label = 'Filter By Sex: ', + choices = ciOptions$sex, + selected = ciOptions$sex, + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ), + + shinyWidgets::pickerInput( + inputId = session$ns('startYears'), + label = 'Filter By Start Year: ', + choices = ciOptions$startYear, + selected = ciOptions$startYear, + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ), + + shinyWidgets::pickerInput( + inputId = session$ns('tars'), + label = 'Select Time at risk (TAR)', + choices = ciOptions$tar, + selected = ciOptions$tar[1], + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 ) + ), + + shiny::actionButton( + inputId = session$ns('generate'), + label = 'Generate', + icon = shiny::icon('redo') ) ) - - # 4th row text - inputSelectedCustomPlot <- inputSelectionServer( - id = "input-selection-custom-plot", - inputSettingList = list( - createInputSetting( - rowNumber = 4, - columnWidth = 12, - varName = 'secondtext', - inputReturn = T, - uiFunction = 'shiny::div', - uiInputs = list( - "Configure Your Plot", - style = "font-weight: bold; font-size: 20px; text-align: center; margin-bottom: 20px; margin-top: 20px; " - ) - ), - - # plotting settings 5th row - - createInputSetting( - rowNumber = 5, - columnWidth = 3, - varName = 'plotYAxis', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Y Axis (Numeric) ', - choices = options$irPlotNumericChoices, - selected = "incidenceRateP100py", - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) + }) + + outcomeIds <- shiny::reactiveVal(NULL) + incidenceRateTarFilter <- shiny::reactiveVal(NULL) + incidenceRateCalendarFilter <- shiny::reactiveVal(NULL) + incidenceRateAgeFilter <- shiny::reactiveVal(NULL) + incidenceRateGenderFilter <- shiny::reactiveVal(NULL) + incidenceRateDbFilter <- shiny::reactiveVal(NULL) + shiny::observeEvent(input$generate,{ + incidenceRateTarFilter(names(ciOptions$tar)[(ciOptions$tar == input$tars)]) # filter needs actual value + incidenceRateCalendarFilter(input$startYears) + incidenceRateAgeFilter(input$ageIds) + incidenceRateGenderFilter(input$sexIds) + incidenceRateDbFilter(input$databaseSelector) + outcomeIds(input$outcomeIds) + }) + + + inputSelectedCustomPlot <- inputSelectionServer( + id = "input-selection-custom-plot", + inputSettingList = list( + createInputSetting( + rowNumber = 4, + columnWidth = 12, + varName = 'secondtext', + inputReturn = T, + uiFunction = 'shiny::div', + uiInputs = list( + "Configure Your Plot", + style = "font-weight: bold; font-size: 20px; text-align: center; margin-bottom: 20px; margin-top: 20px; " + ) + ), + + # plotting settings 5th row + + createInputSetting( + rowNumber = 5, + columnWidth = 3, + varName = 'plotYAxis', + uiFunction = 'shinyWidgets::pickerInput', + updateFunction = 'shinyWidgets::updatePickerInput', + uiInputs = list( + label = 'Y Axis (Numeric) ', + choices = ciOptions$irPlotNumericChoices, + selected = "incidenceRateP100py", + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 ) - ), - - createInputSetting( - rowNumber = 5, - columnWidth = 3, - varName = 'plotXAxis', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'X Axis (Categorical) ', - choices = options$irPlotCategoricalChoices, - selected = "startYear", - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) + ) + ), + + createInputSetting( + rowNumber = 5, + columnWidth = 3, + varName = 'plotXAxis', + uiFunction = 'shinyWidgets::pickerInput', + updateFunction = 'shinyWidgets::updatePickerInput', + uiInputs = list( + label = 'X Axis (Categorical) ', + choices = ciOptions$irPlotCategoricalChoices, + selected = "startYear", + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 ) - ), - - createInputSetting( - rowNumber = 5, - columnWidth = 3, - varName = 'plotXTrellis', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Row Trellis (Categorical) ', - choices = options$irPlotCategoricalChoices, - selected = "targetName", - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) + ) + ), + + createInputSetting( + rowNumber = 5, + columnWidth = 3, + varName = 'plotXTrellis', + uiFunction = 'shinyWidgets::pickerInput', + updateFunction = 'shinyWidgets::updatePickerInput', + uiInputs = list( + label = 'Row Trellis (Categorical) ', + choices = ciOptions$irPlotCategoricalChoices, + selected = "targetName", + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 ) - ), - - createInputSetting( - rowNumber = 5, - columnWidth = 3, - varName = 'plotYTrellis', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Column Trellis (Categorical)', - choices = options$irPlotCategoricalChoices, - selected = "outcomeName", - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) + ) + ), + + createInputSetting( + rowNumber = 5, + columnWidth = 3, + varName = 'plotYTrellis', + uiFunction = 'shinyWidgets::pickerInput', + updateFunction = 'shinyWidgets::updatePickerInput', + uiInputs = list( + label = 'Column Trellis (Categorical)', + choices = ciOptions$irPlotCategoricalChoices, + selected = "outcomeName", + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 ) - ), - - # row 6 - - createInputSetting( - rowNumber = 6, - columnWidth = 3, - varName = 'plotColor', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Color (Categorical)', - choices = options$irPlotCategoricalChoices, - selected = "cdmSourceAbbreviation", - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) + ) + ), + + # row 6 + + createInputSetting( + rowNumber = 6, + columnWidth = 3, + varName = 'plotColor', + uiFunction = 'shinyWidgets::pickerInput', + updateFunction = 'shinyWidgets::updatePickerInput', + uiInputs = list( + label = 'Color (Categorical)', + choices = ciOptions$irPlotCategoricalChoices, + selected = "cdmSourceAbbreviation", + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 ) - ), - createInputSetting( - rowNumber = 6, - columnWidth = 3, - varName = 'plotSize', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Plot Point Size (Numeric)', - choices = options$irPlotNumericChoices, - selected = "outcomes", - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) + ) + ), + createInputSetting( + rowNumber = 6, + columnWidth = 3, + varName = 'plotSize', + uiFunction = 'shinyWidgets::pickerInput', + updateFunction = 'shinyWidgets::updatePickerInput', + uiInputs = list( + label = 'Plot Point Size (Numeric)', + choices = ciOptions$irPlotNumericChoices, + selected = "outcomes", + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 ) - ), - createInputSetting( - rowNumber = 6, - columnWidth = 3, - varName = 'plotShape', - uiFunction = 'shinyWidgets::pickerInput', - updateFunction = 'shinyWidgets::updatePickerInput', - uiInputs = list( - label = 'Plot Point Shape (Categorical)', - choices = options$irPlotCategoricalChoices, - selected = "genderName", - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - dropupAuto = TRUE, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) + ) + ), + createInputSetting( + rowNumber = 6, + columnWidth = 3, + varName = 'plotShape', + uiFunction = 'shinyWidgets::pickerInput', + updateFunction = 'shinyWidgets::updatePickerInput', + uiInputs = list( + label = 'Plot Point Shape (Categorical)', + choices = ciOptions$irPlotCategoricalChoices, + selected = "genderName", + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + dropupAuto = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 ) - ), - - createInputSetting( - rowNumber = 6, - columnWidth = 3, - varName = 'irYscaleFixed', - uiFunction = 'shiny::checkboxInput', - uiInputs = list( - label = "Use same y-axis scale across plots?" - ) ) - + ), - + createInputSetting( + rowNumber = 6, + columnWidth = 3, + varName = 'irYscaleFixed', + uiFunction = 'shiny::checkboxInput', + uiInputs = list( + label = "Use same y-axis scale across plots?" ) + ) ) + ) - filteredData <- shiny::reactive( - { - if (is.null(inputSelectedResults()$targetIds) | - is.null(inputSelectedResults()$outcomeIds) | - is.null(inputSelectedResults()$incidenceRateDbFilter) - ) { - return(data.frame()) - } - - else if(inputSelectedResults()$targetIds==inputSelectedResults()$outcomeIds && - length(inputSelectedResults()$targetIds)==1 && length(inputSelectedResults()$outcomeIds)==1 - ){ - shiny::validate("Target and outcome cohorts must differ from each other. Make a different selection.") - } - - else { - getIncidenceData(targetIds = inputSelectedResults()$targetIds, - outcomeIds = inputSelectedResults()$outcomeIds, - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) %>% + extractedData <- shiny::reactiveVal() + shiny::observeEvent(input$generate , + { + if (is.null(targetIds()) | + is.null(outcomeIds()) + ) { + shiny::validate("Please wait...") + } + + else if(targetIds()[1] == outcomeIds()[1] && + length(targetIds())==1 && length(outcomeIds())==1 + ){ + shiny::validate("Target and outcome cohorts must differ from each other. Make a different selection.") + } + + else { + result <- getIncidenceData(targetIds = targetIds(), + outcomeIds = outcomeIds(), + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + extractedData(result) + } + } + ) + + filteredData <- shiny::reactive({ + shiny::req(nrow(extractedData() > 0)) + if(nrow(extractedData()) > 0){ + extractedData() %>% dplyr::relocate("tar", .before = "outcomes") %>% dplyr::mutate(incidenceProportionP100p = as.numeric(.data$incidenceProportionP100p), incidenceRateP100py = as.numeric(.data$incidenceRateP100py), dplyr::across(dplyr::where(is.numeric), round, 4), - targetIdShort = paste("C", .data$targetCohortDefinitionId, sep = "-"), - outcomeIdShort = paste("C", .data$outcomeCohortDefinitionId, sep = "-")) %>% - dplyr::filter(.data$ageGroupName %in% !!inputSelectedResults()$incidenceRateAgeFilter & - .data$genderName %in% !!inputSelectedResults()$incidenceRateGenderFilter & - .data$startYear %in% !!inputSelectedResults()$incidenceRateCalendarFilter & - .data$cdmSourceAbbreviation %in% !!inputSelectedResults()$incidenceRateDbFilter + targetNameShort = paste("C", .data$targetCohortDefinitionId, sep = "-"), + outcomeNameShort = paste("C", .data$outcomeCohortDefinitionId, sep = "-")) %>% + dplyr::filter(.data$ageGroupId %in% !! incidenceRateAgeFilter() & + .data$genderId %in% !! incidenceRateGenderFilter() & + .data$startYear %in% !! incidenceRateCalendarFilter() & + .data$tar %in% incidenceRateTarFilter() & + .data$cdmSourceAbbreviation %in% !! incidenceRateDbFilter() ) %>% - dplyr::relocate("targetIdShort", .after = "targetName") %>% - dplyr::relocate("outcomeIdShort", .after = "outcomeName") - } + dplyr::relocate("targetName", .after = "cdmSourceAbbreviation") %>% + dplyr::relocate("outcomeName", .after = "targetName") %>% + dplyr::relocate("targetNameShort", .after = "targetName") %>% + dplyr::relocate("outcomeNameShort", .after = "outcomeName") } - ) - - filteredDataAggregateForPlot <- shiny::reactive( - { - if (is.null(inputSelectedResults()$targetIds) | - is.null(inputSelectedResults()$outcomeIds) | - is.null(inputSelectedResults()$incidenceRateDbFilter) - ) { - return(data.frame()) - } - - else if(inputSelectedResults()$targetIds==inputSelectedResults()$outcomeIds && - length(inputSelectedResults()$targetIds)==1 && length(inputSelectedResults()$outcomeIds)==1 - ){ - shiny::validate("Target and outcome cohorts must differ from each other. Make a different selection.") - } - - else { - getIncidenceData(targetIds = inputSelectedResults()$targetIds, - outcomeIds = inputSelectedResults()$outcomeIds, - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) %>% - dplyr::relocate("tar", .before = "outcomes") %>% - dplyr::mutate(incidenceProportionP100p = as.numeric(.data$incidenceProportionP100p), - incidenceRateP100py = as.numeric(.data$incidenceRateP100py), - dplyr::across(dplyr::where(is.numeric), round, 4), - targetIdShort = paste("C", .data$targetCohortDefinitionId, sep = "-"), - outcomeIdShort = paste("C", .data$outcomeCohortDefinitionId, sep = "-")) %>% - dplyr::filter(.data$cdmSourceAbbreviation %in% !!inputSelectedResults()$incidenceRateDbFilter) %>% - dplyr::relocate("targetIdShort", .after = "targetName") %>% - dplyr::relocate("outcomeIdShort", .after = "outcomeName") + }) - } + filteredDataAggregateForPlot <- shiny::reactive({ + if(nrow(extractedData()) > 0){ + extractedData() %>% + dplyr::relocate("tar", .before = "outcomes") %>% + dplyr::mutate(incidenceProportionP100p = as.numeric(.data$incidenceProportionP100p), + incidenceRateP100py = as.numeric(.data$incidenceRateP100py), + dplyr::across(dplyr::where(is.numeric), round, 4), + targetNameShort = paste("C", .data$targetCohortDefinitionId, sep = "-"), + outcomeNameShort = paste("C", .data$outcomeCohortDefinitionId, sep = "-")) %>% + dplyr::relocate("targetNameShort", .after = "targetName") %>% + dplyr::relocate("outcomeNameShort", .after = "outcomeName") } - ) - - - - incidenceColList <- ParallelLogger::loadSettingsFromJson( - system.file("components-columnInformation", - "characterization-incidence-colDefs.json", - package = "OhdsiShinyModules" - ) - ) - - ## CHECK - caused error for me but it is in Nate's latest code - class(incidenceColList$genderName$filterMethod) <- "JS_EVAL" + }) - renderIrTable <- shiny::reactive( - { - filteredData() - } - ) + incidenceColList <- .createCiColDefList() resultTableServer( id = "incidenceRateTable", - df = renderIrTable, - selectedCols = c("cdmSourceAbbreviation", "targetName", "targetIdShort", "outcomeName", "outcomeIdShort", + df = filteredData, + selectedCols = c("cdmSourceAbbreviation", "targetName", "targetNameShort", "outcomeName", "outcomeNameShort", "ageGroupName", "genderName", "startYear", "tar", "outcomes", "incidenceProportionP100p", "incidenceRateP100py"), sortedCols = c("ageGroupName", "genderName", "startYear", "incidenceRateP100py"), elementId = "incidence-select", colDefsInput = incidenceColList, downloadedFileName = "incidenceRateTable-" - ) - + ) + '%!in%' <- function(x,y)!('%in%'(x,y)) - + #ir plots - irPlotCustom <- shiny::reactive( + irPlotCustom <- shiny::reactive( # observeEvent generate instead? { - if (is.null(inputSelectedResults()$targetIds) | - is.null(inputSelectedResults()$outcomeIds) | - is.null(inputSelectedResults()$incidenceRateDbFilter) - ){ + if (is.null(targetIds()) | + is.null(outcomeIds())) { return(data.frame()) } + if(nrow(filteredData()) == 0){ + return(FALSE) + } - ifelse(inputSelectedResults()$incidenceRateTarFilter %in% filteredData()$tar, - plotData <- filteredData() %>% - dplyr::filter(.data$tar %in% inputSelectedResults()$incidenceRateTarFilter), - shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") + ifelse(incidenceRateTarFilter() %in% filteredData()$tar, + plotData <- filteredData() %>% + dplyr::filter(.data$tar %in% incidenceRateTarFilter()) %>% + dplyr::mutate(targetLabel = paste(.data$targetNameShort, " = ", .data$targetName), + outcomeLabel = paste(.data$outcomeNameShort, " = ", .data$outcomeName) + ), + shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") ) - + # Take the specific tar value you want to plot tar_value <- unique(plotData$tar)[1] @@ -813,9 +685,9 @@ characterizationIncidenceServer <- function( plotData$tooltip <- with(plotData, paste( "Incidence Rate:", incidenceRateP100py, "
", "Incidence Proportion:", incidenceProportionP100p, "
", - "Outcome ID:", outcomeIdShort, "
", + "Outcome ID:", outcomeNameShort, "
", "Outcome Name:", outcomeName, "
", - "Target ID:", targetIdShort, "
", + "Target ID:", targetNameShort, "
", "Target Name:", targetName, "
", "Data Source:", cdmSourceAbbreviation, "
", "Calendar Year:", startYear, "
", @@ -827,7 +699,7 @@ characterizationIncidenceServer <- function( "Outcomes:", outcomes )) - + # Check if color, size, shape, and trellis variables are selected, and set aesthetics accordingly color_aesthetic <- NULL size_aesthetic <- NULL @@ -835,19 +707,29 @@ characterizationIncidenceServer <- function( trellis_aesthetic_x <- NULL trellis_aesthetic_y <- NULL + # Get unique target and outcome labels + unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300) + unique_outcome_labels <- strwrap(unique(plotData$outcomeLabel), width = 300) + + # Combine all unique values into a final vector + final_unique_values <- unique(c(unique_target_labels, unique_outcome_labels)) + + # Create the caption text with line breaks + caption_text <- paste(final_unique_values, collapse = "\n") + if (inputSelectedCustomPlot()$plotColor == "Target Cohort" | inputSelectedCustomPlot()$plotColor == "Outcome Cohort") { color_aesthetic <- if (inputSelectedCustomPlot()$plotColor == "Target Cohort") { - dplyr::vars(.data$targetIdShort) + dplyr::vars(.data$targetNameShort) } else if (inputSelectedCustomPlot()$plotColor == "Outcome Cohort") { - dplyr::vars(.data$outcomeIdShort) + dplyr::vars(.data$outcomeNameShort) } } if (inputSelectedCustomPlot()$plotShape == "Target Cohort" | inputSelectedCustomPlot()$plotShape == "Outcome Cohort") { shape_aesthetic <- if (inputSelectedCustomPlot()$plotShape == "Target Cohort") { - dplyr::vars(.data$targetIdShort) + dplyr::vars(.data$targetNameShort) } else if (inputSelectedCustomPlot()$plotShape == "Outcome Cohort") { - dplyr::vars(.data$outcomeIdShort) + dplyr::vars(.data$outcomeNameShort) } } @@ -894,7 +776,7 @@ characterizationIncidenceServer <- function( else if (inputSelectedCustomPlot()$plotXTrellis!="(None)" & inputSelectedCustomPlot()$plotXTrellis=="targetName" & inputSelectedCustomPlot()$plotXTrellis!="outcomeName" & inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis!="targetName" & inputSelectedCustomPlot()$plotYTrellis!="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( - rows = dplyr::vars(.data$targetIdShort), + rows = dplyr::vars(.data$targetNameShort), cols = dplyr::vars(.data[[inputSelectedCustomPlot()$plotYTrellis]]), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + @@ -905,7 +787,7 @@ characterizationIncidenceServer <- function( else if (inputSelectedCustomPlot()$plotXTrellis!="(None)" & inputSelectedCustomPlot()$plotXTrellis!="targetName" & inputSelectedCustomPlot()$plotXTrellis=="outcomeName" & inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis!="targetName" & inputSelectedCustomPlot()$plotYTrellis!="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( - rows = dplyr::vars(.data$outcomeIdShort), + rows = dplyr::vars(.data$outcomeNameShort), cols = dplyr::vars(.data[[inputSelectedCustomPlot()$plotYTrellis]]), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + @@ -917,7 +799,7 @@ characterizationIncidenceServer <- function( inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis=="targetName" & inputSelectedCustomPlot()$plotYTrellis!="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( rows = dplyr::vars(.data[[inputSelectedCustomPlot()$plotXTrellis]]), - cols = dplyr::vars(.data$targetIdShort), + cols = dplyr::vars(.data$targetNameShort), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + ggplot2::theme(strip.background = ggplot2::element_blank(), @@ -928,7 +810,7 @@ characterizationIncidenceServer <- function( inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis!="targetName" & inputSelectedCustomPlot()$plotYTrellis=="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( rows = dplyr::vars(.data[[inputSelectedCustomPlot()$plotXTrellis]]), - cols = dplyr::vars(.data$outcomeIdShort), + cols = dplyr::vars(.data$outcomeNameShort), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + ggplot2::theme(strip.background = ggplot2::element_blank(), @@ -938,8 +820,8 @@ characterizationIncidenceServer <- function( else if (inputSelectedCustomPlot()$plotXTrellis!="(None)" & inputSelectedCustomPlot()$plotXTrellis=="targetName" & inputSelectedCustomPlot()$plotXTrellis!="outcomeName" & inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis=="targetName" & inputSelectedCustomPlot()$plotYTrellis!="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( - rows = dplyr::vars(.data$targetIdShort), - cols = dplyr::vars(.data$targetIdShort), + rows = dplyr::vars(.data$targetNameShort), + cols = dplyr::vars(.data$targetNameShort), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + ggplot2::theme(strip.background = ggplot2::element_blank(), @@ -949,8 +831,8 @@ characterizationIncidenceServer <- function( else if (inputSelectedCustomPlot()$plotXTrellis!="(None)" & inputSelectedCustomPlot()$plotXTrellis=="targetName" & inputSelectedCustomPlot()$plotXTrellis!="outcomeName" & inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis!="targetName" & inputSelectedCustomPlot()$plotYTrellis=="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( - rows = dplyr::vars(.data$targetIdShort), - cols = dplyr::vars(.data$outcomeIdShort), + rows = dplyr::vars(.data$targetNameShort), + cols = dplyr::vars(.data$outcomeNameShort), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + ggplot2::theme(strip.background = ggplot2::element_blank(), @@ -960,8 +842,8 @@ characterizationIncidenceServer <- function( else if (inputSelectedCustomPlot()$plotXTrellis!="(None)" & inputSelectedCustomPlot()$plotXTrellis!="targetName" & inputSelectedCustomPlot()$plotXTrellis=="outcomeName" & inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis=="targetName" & inputSelectedCustomPlot()$plotYTrellis!="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( - rows = dplyr::vars(.data$outcomeIdShort), - cols = dplyr::vars(.data$targetIdShort), + rows = dplyr::vars(.data$outcomeNameShort), + cols = dplyr::vars(.data$targetNameShort), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + ggplot2::theme(strip.background = ggplot2::element_blank(), @@ -971,8 +853,8 @@ characterizationIncidenceServer <- function( else if (inputSelectedCustomPlot()$plotXTrellis!="(None)" & inputSelectedCustomPlot()$plotXTrellis!="targetName" & inputSelectedCustomPlot()$plotXTrellis=="outcomeName" & inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis!="targetName" & inputSelectedCustomPlot()$plotYTrellis=="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( - rows = dplyr::vars(.data$outcomeIdShort), - cols = dplyr::vars(.data$outcomeIdShort), + rows = dplyr::vars(.data$outcomeNameShort), + cols = dplyr::vars(.data$outcomeNameShort), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + ggplot2::theme(strip.background = ggplot2::element_blank(), @@ -983,7 +865,7 @@ characterizationIncidenceServer <- function( inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis!="targetName" & inputSelectedCustomPlot()$plotYTrellis=="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( rows = NULL, - cols = dplyr::vars(.data$outcomeIdShort), + cols = dplyr::vars(.data$outcomeNameShort), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + ggplot2::theme(strip.background = ggplot2::element_blank(), @@ -994,7 +876,7 @@ characterizationIncidenceServer <- function( inputSelectedCustomPlot()$plotYTrellis!="(None)" & inputSelectedCustomPlot()$plotYTrellis=="targetName" & inputSelectedCustomPlot()$plotYTrellis!="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( rows = NULL, - cols = dplyr::vars(.data$targetIdShort), + cols = dplyr::vars(.data$targetNameShort), scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + ggplot2::theme(strip.background = ggplot2::element_blank(), @@ -1026,7 +908,7 @@ characterizationIncidenceServer <- function( else if (inputSelectedCustomPlot()$plotXTrellis!="(None)" & inputSelectedCustomPlot()$plotXTrellis=="targetName" & inputSelectedCustomPlot()$plotXTrellis!="outcomeName" & inputSelectedCustomPlot()$plotYTrellis=="(None)" & inputSelectedCustomPlot()$plotYTrellis!="targetName" & inputSelectedCustomPlot()$plotYTrellis!="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( - rows = dplyr::vars(.data$targetIdShort), + rows = dplyr::vars(.data$targetNameShort), cols = NULL, scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + @@ -1037,7 +919,7 @@ characterizationIncidenceServer <- function( else if (inputSelectedCustomPlot()$plotXTrellis!="(None)" & inputSelectedCustomPlot()$plotXTrellis!="targetName" & inputSelectedCustomPlot()$plotXTrellis=="outcomeName" & inputSelectedCustomPlot()$plotYTrellis=="(None)" & inputSelectedCustomPlot()$plotYTrellis!="targetName" & inputSelectedCustomPlot()$plotYTrellis!="outcomeName") { base_plot <- base_plot + ggplot2::facet_grid( - rows = dplyr::vars(.data$outcomeIdShort), + rows = dplyr::vars(.data$outcomeNameShort), cols = NULL, scales = if (inputSelectedCustomPlot()$irYscaleFixed) "fixed" else "free_y" ) + @@ -1057,15 +939,17 @@ characterizationIncidenceServer <- function( } + + # Rest of your ggplot code remains the same base_plot <- base_plot + ggplot2::labs( title = paste("Incidence Rate for TAR:", tar_value), - x = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% inputSelectedCustomPlot()$plotXAxis]), - y = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% inputSelectedCustomPlot()$plotYAxis]), - color = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% inputSelectedCustomPlot()$plotColor]), - size = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% inputSelectedCustomPlot()$plotSize]), - shape = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% inputSelectedCustomPlot()$plotShape] - ) + x = names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% inputSelectedCustomPlot()$plotXAxis]), + y = names(ciOptions$irPlotNumericChoices[ciOptions$irPlotNumericChoices %in% inputSelectedCustomPlot()$plotYAxis]), + color = names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% inputSelectedCustomPlot()$plotColor]), + size = names(ciOptions$irPlotNumericChoices[ciOptions$irPlotNumericChoices %in% inputSelectedCustomPlot()$plotSize]), + shape = names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% inputSelectedCustomPlot()$plotShape]), + caption = caption_text ) + ggplot2::scale_y_log10(breaks = scales::breaks_log(n=6)) + ggplot2::guides(alpha = "none") + # Remove the alpha legend @@ -1080,45 +964,14 @@ characterizationIncidenceServer <- function( legend.box.spacing = ggplot2::unit(3, "pt"), legend.text = ggplot2::element_text(size=10), legend.title = ggplot2::element_text(size=16, face = "bold"), - #plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12), - #legend.spacing.x = ggplot2::unit(2.0, 'cm'), - # legend.box = "horizontal", - # legend.key.size = ggplot2::unit(3, 'points'), #change legend key size - # legend.title = ggplot2::element_text(size=30), #change legend title font size - # legend.text = ggplot2::element_text(size=20), panel.spacing = ggplot2::unit(2, "lines"), - # strip.background = ggplot2::element_blank(), - strip.text = ggplot2::element_text(face="bold", size = 14) + strip.text = ggplot2::element_text(face="bold", size = 14), + plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12, + margin = ggplot2::margin(t = 20)) ) + ggplot2::guides(shape = ggplot2::guide_legend(override.aes = list(size = 6)), color = ggplot2::guide_legend(override.aes = list(size = 6))) - # - # # Create a custom color scale - # color_scale <- RColorBrewer::colorRampPalette(brewer.pal(9, "YlOrRd"))(100) - # - # # Create a faceted heatmap by outcome and data source - # p <- ggplot2::ggplot(data = plotData, aes(x = targetIdShort, y = ageGroupName, - # text = paste("Outcome ID:", outcomeIdShort, "
Outcome:", outcomeName, - # "
Target ID:", targetIdShort, "
Target:", targetName, - # "
TAR:", tar, "
Age:", ageGroupName, "
Sex:", genderName, - # "
TAR:", - # "
Incidence Rate:", incidenceRateP100py))) + - # ggplot2::geom_tile(aes(fill = incidenceRateP100py), color = "white") + - # ggplot2::scale_fill_gradient(colors = color_scale, name = "Incidence Rate") + - # ggplot2::labs(title = "Incidence Rate by Strata Variables", - # x = "Target Population Cohort", - # y = "Age Category") + - # ggplot2::theme_minimal() + - # ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), - # plot.title = element_text(hjust = 0.5)) + - # ggplot2::facet_grid(outcome ~ data_source, scales = "free_x", space = "free_x") - # - # # Convert the ggplot plot to a Plotly plot - # p <- plotly::ggplotly(p) - # - # - } @@ -1135,54 +988,55 @@ characterizationIncidenceServer <- function( #render the event reactive incidence plot without legend renderIrPlotCustomNoLegend <- shiny::reactive( { - if (is.null(inputSelectedResults()$targetIds) | - is.null(inputSelectedResults()$outcomeIds) | - is.null(inputSelectedResults()$incidenceRateDbFilter) - ){ - shiny::validate("Please select at least one target, one outcome, and one database.") + if (is.null(targetIds()) | + is.null(outcomeIds())) { + shiny::validate("Please select at least one target and one outcome.") + } + if(nrow(filteredData()) == 0){ + shiny::validate("No results.") } else { - plotData <- filteredData() %>% - dplyr::filter(.data$tar %in% inputSelectedResults()$incidenceRateTarFilter) - - # Get the number of facets in both rows and columns - num_rows <- length(unique(plotData[[inputSelectedCustomPlot()$plotXTrellis]])) - num_cols <- length(unique(plotData[[inputSelectedCustomPlot()$plotYTrellis]])) - - max_length <- max(nchar(unique(inputSelectedCustomPlot()$plotXAxis))) - - base_plot <- irPlotCustom() - - p <- base_plot + - ggplot2::guides(shape = FALSE, color = FALSE, size = FALSE) - - # Convert the ggplot to a plotly object - p <- plotly::ggplotly(p, tooltip = "text") - - # Center the main plot title - p <- p %>% plotly::layout(title = list(x = 0.5, xanchor = "center"), - margin = list(t = 75, b = 150, l = 125, r = 25), - #add several xaxis placeholders in case row trellis has several distinct values (this is a workaround) - xaxis = list(tickangle = 45), - xaxis2 = list(tickangle = 45), - xaxis3 = list(tickangle = 45), - xaxis4 = list(tickangle = 45), - xaxis5 = list(tickangle = 45), - xaxis6 = list(tickangle = 45), - xaxis7 = list(tickangle = 45), - xaxis8 = list(tickangle = 45), - xaxis9 = list(tickangle = 45), - xaxis10 = list(tickangle = 45), - xaxis11 = list(tickangle = 45), - xaxis12 = list(tickangle = 45), - xaxis13 = list(tickangle = 45), - xaxis14 = list(tickangle = 45), - xaxis15 = list(tickangle = 45) - ) - - return(p) - + plotData <- filteredData() %>% + dplyr::filter(.data$tar %in% incidenceRateTarFilter()) + + # Get the number of facets in both rows and columns + num_rows <- length(unique(plotData[[inputSelectedCustomPlot()$plotXTrellis]])) + num_cols <- length(unique(plotData[[inputSelectedCustomPlot()$plotYTrellis]])) + + max_length <- max(nchar(unique(inputSelectedCustomPlot()$plotXAxis))) + + base_plot <- irPlotCustom() + + p <- base_plot + + ggplot2::guides(shape = FALSE, color = FALSE, size = FALSE) + + # Convert the ggplot to a plotly object + p <- plotly::ggplotly(p, tooltip = "text") + + # Center the main plot title + p <- p %>% plotly::layout(title = list(x = 0.5, xanchor = "center"), + margin = list(t = 75, b = 150, l = 125, r = 25), + #add several xaxis placeholders in case row trellis has several distinct values (this is a workaround) + xaxis = list(tickangle = 45), + xaxis2 = list(tickangle = 45), + xaxis3 = list(tickangle = 45), + xaxis4 = list(tickangle = 45), + xaxis5 = list(tickangle = 45), + xaxis6 = list(tickangle = 45), + xaxis7 = list(tickangle = 45), + xaxis8 = list(tickangle = 45), + xaxis9 = list(tickangle = 45), + xaxis10 = list(tickangle = 45), + xaxis11 = list(tickangle = 45), + xaxis12 = list(tickangle = 45), + xaxis13 = list(tickangle = 45), + xaxis14 = list(tickangle = 45), + xaxis15 = list(tickangle = 45) + ) + + return(p) + } } @@ -1191,16 +1045,17 @@ characterizationIncidenceServer <- function( #render the event reactive incidence plot without legend renderIrPlotCustom <- shiny::reactive( { - if (is.null(inputSelectedResults()$targetIds) | - is.null(inputSelectedResults()$outcomeIds) | - is.null(inputSelectedResults()$incidenceRateDbFilter) - ){ - shiny::validate("Please select at least one target, one outcome, and one database.") + if (is.null(targetIds()) | + is.null(outcomeIds())) { + shiny::validate("Please select at least one target and one outcome.") + } + if(nrow(filteredData()) == 0){ + shiny::validate("No results.") } else { plotData <- filteredData() %>% - dplyr::filter(.data$tar %in% inputSelectedResults()$incidenceRateTarFilter) + dplyr::filter(.data$tar %in% incidenceRateTarFilter()) # Get the number of facets in both rows and columns num_rows <- length(unique(plotData[[inputSelectedCustomPlot()$plotXTrellis]])) @@ -1254,780 +1109,702 @@ characterizationIncidenceServer <- function( #by age - renderIrPlotStandardAge <- shiny::reactive( - { - - if (is.null(inputSelectedResults()$targetIds) | - is.null(inputSelectedResults()$outcomeIds) | - is.null(inputSelectedResults()$incidenceRateDbFilter) - ) { - return(data.frame()) - } - - ifelse(inputSelectedResults()$incidenceRateTarFilter %in% filteredData()$tar, - plotData <- filteredData() %>% - dplyr::filter(.data$tar %in% inputSelectedResults()$incidenceRateTarFilter), - shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") - ) - - #add check to make sure facetted plots fit nicely in plotting window (600px). this is currently nrow * ncol in facet_wrap() - ifelse(length(inputSelectedResults()$targetId) * length(inputSelectedResults()$outcomeId) <= 10, - plotData <- filteredData(), - shiny::validate("Too many Target-Outcome pairs selected to plot efficiently. Please choose fewer targets and/or outcomes.") - ) - - #add check to make sure "> 1 distinct age is selected for by age plot"any" is in selection for year and sex - ifelse("Any" %in% inputSelectedResults()$incidenceRateCalendarFilter & "Any" %in% inputSelectedResults()$incidenceRateGenderFilter, - plotData <- filteredData(), - shiny::validate("This standard plot is designed to show results aggregated over all (`Any`) year and sex categories. Please make sure you have selected `Any` in the `Select your results` section above for these variables.") - ) - - plotData <- plotData %>% - dplyr::filter(#ageGroupName != "Any" & - genderName == "Any" & - startYear == "Any") %>% - dplyr::mutate(targetLabel = paste(targetIdShort, " = ", targetName), - outcomeLabel = paste(outcomeIdShort, " = ", outcomeName), - ageGroupName = factor(ageGroupName, levels = custom_age_sort(ageGroupName), ordered = TRUE) - ) %>% - dplyr::rename("Target" = targetIdShort, - "Outcome" = outcomeIdShort, - "Age" = ageGroupName) - - # plotHeightStandardAgeSex <- shiny::reactive({ - # paste(sum(length(unique(plotData$targetLabel)), length(unique(plotData$Age)), -3)*100, "px", sep="") - # }) - - # Get unique target and outcome labels - unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300) - unique_outcome_labels <- strwrap(unique(plotData$outcomeLabel), width = 300) - - # Combine all unique values into a final vector - final_unique_values <- unique(c(unique_target_labels, unique_outcome_labels)) - - # Create the caption text with line breaks - caption_text <- paste(final_unique_values, collapse = "\n") - - - # Take the specific tar value you want to plot - tar_value <- unique(plotData$tar)[1] - - - base_plot <- ggplot2::ggplot( - data = plotData, - ggplot2::aes(x = Age, - y = incidenceRateP100py, - color = cdmSourceAbbreviation - ) - ) + - ggplot2::geom_point( - ggplot2::aes(size = 3) - ) + - #geom_jitter() + - #scale_size_continuous(range = c(5,15)) + - ggplot2::scale_colour_brewer(palette = "Paired") + - ggplot2::facet_wrap( - Target~Outcome, - labeller = "label_both", - scales = "free_x", - nrow = 2, - ncol = 5 - #, - #strip.position = "right" - ) + - ggplot2::scale_y_continuous(trans=scales::pseudo_log_trans(base = 10), - n.breaks = 4) - - base_plot <- base_plot + ggplot2::labs( - title = paste("Incidence Rate for Time at Risk:", tar_value), - x = paste(names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "ageGroupName"]), "\n"), - y = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "incidenceRateP100py"]), - color = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "cdmSourceAbbreviation"]), - #size = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "outcomes"]), - #shape = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "genderName"]), - caption = caption_text - ) + - ggplot2::guides(alpha = "none", size = "none") + # Remove the alpha and size legend - ggplot2::theme_bw() + - ggplot2::theme( - plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10), hjust = 0.5, size = 25, face="bold"), - plot.subtitle = ggplot2::element_text(margin = ggplot2::margin(b = 20), hjust = 0.5, size = 16), - axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 25), size = 18), - axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 25), size = 18), - axis.text.x = ggplot2::element_text(size = 14, angle = 45, hjust = 0.5, vjust = 0.25), - axis.text.y = ggplot2::element_text(size = 14), - legend.position = "bottom", - legend.box.spacing = ggplot2::unit(3, "pt"), - legend.text = ggplot2::element_text(size=10), - legend.title = ggplot2::element_text(size=16, face = "bold"), - legend.title.align = 0.5, - plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12, - margin = ggplot2::margin(t = 20)), - #legend.spacing.x = ggplot2::unit(2.0, 'cm'), - # legend.box = "horizontal", - # legend.key.size = ggplot2::unit(3, 'points'), #change legend key size - # legend.title = ggplot2::element_text(size=30), #change legend title font size - # legend.text = ggplot2::element_text(size=20), - panel.spacing = ggplot2::unit(2, "lines"), - # strip.background = ggplot2::element_blank(), - strip.text = ggplot2::element_text(face="bold", size = 14), - strip.background = ggplot2::element_blank(), - strip.clip = "off" - ) + - ggplot2::guides(#shape = ggplot2::guide_legend(override.aes = list(size = 6)), - color = ggplot2::guide_legend(override.aes = list(size = 6)) - ) - - return(base_plot) - + renderIrPlotStandardAge <- shiny::reactive({ + + + if (is.null(targetIds()) | + is.null(outcomeIds())) { + return(data.frame()) } - ) - - output$incidencePlotStandardAge<- - shiny::renderPlot({ - renderIrPlotStandardAge() - }) - - - # Define a function to save the plot as an image - output$downloadPlotStandardAge <- shiny::downloadHandler( - filename = function() { - paste("standard-age-ir-plot-", Sys.Date(), ".png", sep = "") - }, - content = function(file) { - cowplot::save_plot(file, plot = renderIrPlotStandardAge(), base_height = 12) + if(nrow(filteredData()) == 0){ + shiny::validate("No results.") } - ) - - - + + ifelse(incidenceRateTarFilter() %in% filteredData()$tar, + plotData <- filteredData() %>% + dplyr::filter(.data$tar %in% incidenceRateTarFilter()), + shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") + ) + + #add check to make sure facetted plots fit nicely in plotting window (600px). this is currently nrow * ncol in facet_wrap() + ifelse(length(targetIds()) * length(outcomeIds()) <= 10, + plotData <- filteredData(), + shiny::validate("Too many Target-Outcome pairs selected to plot efficiently. Please choose fewer targets and/or outcomes.") + ) + + #add check to make sure "> 1 distinct age is selected for by age plot"any" is in selection for year and sex + ifelse("Any" %in% incidenceRateCalendarFilter() & "Any" %in% incidenceRateGenderFilter(), + plotData <- filteredData(), + shiny::validate("This standard plot is designed to show results aggregated over all (`Any`) year and sex categories. Please make sure you have selected `Any` in the `Select your results` section above for these variables.") + ) + + plotData <- plotData %>% + dplyr::filter(#ageGroupName != "Any" & + .data$genderName == "Any" & + .data$startYear == "Any") %>% + dplyr::mutate(targetLabel = paste(.data$targetNameShort, " = ", .data$targetName), + outcomeLabel = paste(.data$outcomeNameShort, " = ", .data$outcomeName), + ageGroupName = factor(.data$ageGroupName, levels = custom_age_sort(.data$ageGroupName), ordered = TRUE) + ) %>% + dplyr::rename(Target = "targetNameShort", + Outcome = "outcomeNameShort", + Age = "ageGroupName") + + # Get unique target and outcome labels + unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300) + unique_outcome_labels <- strwrap(unique(plotData$outcomeLabel), width = 300) + + # Combine all unique values into a final vector + final_unique_values <- unique(c(unique_target_labels, unique_outcome_labels)) + + # Create the caption text with line breaks + caption_text <- paste(final_unique_values, collapse = "\n") + + + # Take the specific tar value you want to plot + tar_value <- unique(plotData$tar)[1] + + + base_plot <- ggplot2::ggplot( + data = plotData, + ggplot2::aes(x = .data$Age, + y = .data$incidenceRateP100py, + color = .data$cdmSourceAbbreviation + ) + ) + + ggplot2::geom_point( + ggplot2::aes(size = 3) + ) + + #geom_jitter() + + #scale_size_continuous(range = c(5,15)) + + ggplot2::scale_colour_brewer(palette = "Paired") + + ggplot2::facet_wrap( + Target~Outcome, + labeller = "label_both", + scales = "free_x", + nrow = 2, + ncol = 5 + #, + #strip.position = "right" + ) + + ggplot2::scale_y_continuous(trans=scales::pseudo_log_trans(base = 10), + n.breaks = 4) + + base_plot <- base_plot + ggplot2::labs( + title = paste("Incidence Rate for Time at Risk:", tar_value), + x = paste(names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "ageGroupName"]), "\n"), + y = names(ciOptions$irPlotNumericChoices[ciOptions$irPlotNumericChoices %in% "incidenceRateP100py"]), + color = names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "cdmSourceAbbreviation"]), + #size = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "outcomes"]), + #shape = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "genderName"]), + caption = caption_text + ) + + ggplot2::guides(alpha = "none", size = "none") + # Remove the alpha and size legend + ggplot2::theme_bw() + + ggplot2::theme( + plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10), hjust = 0.5, size = 25, face="bold"), + plot.subtitle = ggplot2::element_text(margin = ggplot2::margin(b = 20), hjust = 0.5, size = 16), + axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 25), size = 18), + axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 25), size = 18), + axis.text.x = ggplot2::element_text(size = 14, angle = 45, hjust = 0.5, vjust = 0.25), + axis.text.y = ggplot2::element_text(size = 14), + legend.position = "bottom", + legend.box.spacing = ggplot2::unit(3, "pt"), + legend.text = ggplot2::element_text(size=10), + legend.title = ggplot2::element_text(size=16, face = "bold"), + legend.title.align = 0.5, + plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12, + margin = ggplot2::margin(t = 20)), + panel.spacing = ggplot2::unit(2, "lines"), + strip.text = ggplot2::element_text(face="bold", size = 14), + strip.background = ggplot2::element_blank(), + strip.clip = "off" + ) + + ggplot2::guides(#shape = ggplot2::guide_legend(override.aes = list(size = 6)), + color = ggplot2::guide_legend(override.aes = list(size = 6)) + ) + + return(base_plot) + + }) - #by age and sex - -renderIrPlotStandardAgeSex <- shiny::reactive( - { - - if (is.null(inputSelectedResults()$targetIds) | - is.null(inputSelectedResults()$outcomeIds) | - is.null(inputSelectedResults()$incidenceRateDbFilter) - ) { - return(data.frame()) - } - - ifelse(inputSelectedResults()$incidenceRateTarFilter %in% filteredData()$tar, - plotData <- filteredData() %>% - dplyr::filter(.data$tar %in% inputSelectedResults()$incidenceRateTarFilter), - shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") - ) - - #add check to make sure facetted plots fit nicely in plotting window (600px). this is currently nrow * ncol in facet_wrap() - ifelse(length(inputSelectedResults()$targetId) * length(inputSelectedResults()$outcomeId) <= 10, - plotData <- filteredData(), - shiny::validate("Too many Target-Outcome pairs selected to plot efficiently. Please choose fewer targets and/or outcomes.") - ) - - #add check to make sure "Any" is in the year filter - ifelse("Any" %in% inputSelectedResults()$incidenceRateCalendarFilter, - plotData <- filteredData(), - shiny::validate("This standard plot is designed to show results aggregated over all (`Any`) year categories. Please make sure you have selected `Any` in the `Select your results` section above for this variable.") - ) - - plotData <- plotData %>% - dplyr::filter(ageGroupName != "Any" & - genderName != "Any" & - startYear == "Any") %>% - dplyr::mutate(targetLabel = paste(targetIdShort, " = ", targetName), - outcomeLabel = paste(outcomeIdShort, " = ", outcomeName), - ageGroupName = factor(ageGroupName, levels = custom_age_sort(ageGroupName), ordered = TRUE) - ) %>% - dplyr::rename("Target" = targetIdShort, - "Outcome" = outcomeIdShort, - "Age" = ageGroupName) - - # plotHeightStandardAgeSex <- shiny::reactive({ - # paste(sum(length(unique(plotData$targetLabel)), length(unique(plotData$Age)), -3)*100, "px", sep="") - # }) - - # Get unique target and outcome labels - unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300) - unique_outcome_labels <- strwrap(unique(plotData$outcomeLabel), width = 300) - - # Combine all unique values into a final vector - final_unique_values <- unique(c(unique_target_labels, unique_outcome_labels)) - - # Create the caption text with line breaks - caption_text <- paste(final_unique_values, collapse = "\n") - - - # Take the specific tar value you want to plot - tar_value <- unique(plotData$tar)[1] - - base_plot <- ggplot2::ggplot( - data = plotData, - ggplot2::aes(x = Age, - y = incidenceRateP100py, - shape = genderName, - color = cdmSourceAbbreviation + output$incidencePlotStandardAge<- + shiny::renderPlot({ + renderIrPlotStandardAge() + }) + + + # Define a function to save the plot as an image + output$downloadPlotStandardAge <- shiny::downloadHandler( + filename = function() { + paste("standard-age-ir-plot-", Sys.Date(), ".png", sep = "") + }, + content = function(file) { + cowplot::save_plot(file, plot = renderIrPlotStandardAge(), base_height = 12) + } ) - ) + - ggplot2::geom_point( - ggplot2::aes(size = 3) - ) + - #geom_jitter() + - #scale_size_continuous(range = c(5,15)) + - ggplot2::scale_colour_brewer(palette = "Paired") + - ggplot2::facet_wrap( - Target~Outcome, - labeller = "label_both", - scales = "free_x", - nrow = 2, - ncol = 5 - #, - #strip.position = "right" - ) + - ggplot2::scale_y_continuous(trans=scales::pseudo_log_trans(base = 10), - n.breaks = 4) - - base_plot <- base_plot + ggplot2::labs( - title = paste("Incidence Rate for Time at Risk:", tar_value), - x = paste(names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "ageGroupName"]), "\n"), - y = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "incidenceRateP100py"]), - color = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "cdmSourceAbbreviation"]), - #size = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "outcomes"]), - shape = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "genderName"]), - caption = caption_text - ) + - ggplot2::guides(alpha = "none", size = "none") + # Remove the alpha and size legend - ggplot2::theme_bw() + - ggplot2::theme( - plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10), hjust = 0.5, size = 25, face="bold"), - plot.subtitle = ggplot2::element_text(margin = ggplot2::margin(b = 20), hjust = 0.5, size = 16), - axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 25), size = 18), - axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 25), size = 18), - axis.text.x = ggplot2::element_text(size = 14, angle = 45, hjust = 0.5, vjust = 0.25), - axis.text.y = ggplot2::element_text(size = 14), - legend.position = "bottom", - legend.box.spacing = ggplot2::unit(3, "pt"), - legend.text = ggplot2::element_text(size=10), - legend.title = ggplot2::element_text(size=16, face = "bold"), - legend.title.align = 0.5, - plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12, - margin = ggplot2::margin(t = 20)), - #legend.spacing.x = ggplot2::unit(2.0, 'cm'), - # legend.box = "horizontal", - # legend.key.size = ggplot2::unit(3, 'points'), #change legend key size - # legend.title = ggplot2::element_text(size=30), #change legend title font size - # legend.text = ggplot2::element_text(size=20), - panel.spacing = ggplot2::unit(2, "lines"), - # strip.background = ggplot2::element_blank(), - strip.text = ggplot2::element_text(face="bold", size = 14), - strip.background = ggplot2::element_blank(), - strip.clip = "off" - ) + - ggplot2::guides(shape = ggplot2::guide_legend(override.aes = list(size = 6)), - color = ggplot2::guide_legend(override.aes = list(size = 6)) - ) - - return(base_plot) - } -) + #by age and sex -output$incidencePlotStandardAgeSex<- - shiny::renderPlot({ - renderIrPlotStandardAgeSex() - }) - - -# Define a function to save the plot as an image -output$downloadPlotStandardAgeSex <- shiny::downloadHandler( - filename = function() { - paste("standard-age-sex-ir-plot-", Sys.Date(), ".png", sep = "") - }, - content = function(file) { - cowplot::save_plot(file, plot = renderIrPlotStandardAgeSex(), base_height = 12) - } -) - - - -# by calendar year -renderIrPlotStandardYear <- shiny::reactive( - { - - if (is.null(inputSelectedResults()$targetIds) | - is.null(inputSelectedResults()$outcomeIds) | - is.null(inputSelectedResults()$incidenceRateDbFilter) - ) { - return(data.frame()) - } - - ifelse(inputSelectedResults()$incidenceRateTarFilter %in% filteredData()$tar, - plotData <- filteredData() %>% - dplyr::filter(.data$tar %in% inputSelectedResults()$incidenceRateTarFilter), - shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") - ) - - ifelse(length(inputSelectedResults()$incidenceRateTarFilter %in% filteredData()$tar) == 1, - plotData <- filteredData() %>% - dplyr::filter(.data$tar %in% inputSelectedResults()$incidenceRateTarFilter), - shiny::validate("Please select only one TAR at a time to view yearly plots.") - ) - - ifelse((length(inputSelectedResults()$targetIds) == 1) & - (length(inputSelectedResults()$outcomeIds) == 1), - plotData <- plotData, - shiny::validate("Please select only one Target and Outcome at a time to view yearly plots.") - ) - - - - plotData <- plotData %>% - dplyr::filter(genderName != "Any" & - startYear != "Any") %>% - dplyr::mutate(targetLabel = paste(targetIdShort, " = ", targetName), - outcomeLabel = paste(outcomeIdShort, " = ", outcomeName), - ageGroupName = factor(ageGroupName, levels = custom_age_sort(ageGroupName), ordered = TRUE) - ) %>% - dplyr::rename("Target" = targetIdShort, - "Outcome" = outcomeIdShort, - "Age" = ageGroupName) - - #get unique shorthand cohort name - unique_target <- unique(plotData$Target) - unique_outcome <- unique(plotData$Outcome) - - - # Get unique target and outcome labels - unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300) - unique_outcome_labels <- strwrap(unique(plotData$outcomeLabel), width = 300) - - # Combine all unique values into a final vector - final_unique_values <- unique(c(unique_target_labels, unique_outcome_labels)) - - # Create the caption text with line breaks - caption_text <- paste(final_unique_values, collapse = "\n") - - - # Take the specific tar value you want to plot - tar_value <- unique(plotData$tar)[1] - - base_plot <- ggplot2::ggplot( - data = plotData, - ggplot2::aes(x = startYear, - y = incidenceRateP100py, - shape = genderName, - color = cdmSourceAbbreviation, - group = interaction(cdmSourceAbbreviation, genderName) + renderIrPlotStandardAgeSex <- shiny::reactive({ + + if (is.null(targetIds()) | + is.null(outcomeIds())) { + return(data.frame()) + } + if(nrow(filteredData()) == 0){ + return(data.frame()) + } + + ifelse(incidenceRateTarFilter() %in% filteredData()$tar, + plotData <- filteredData() %>% + dplyr::filter(.data$tar %in% incidenceRateTarFilter()), + shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") + ) + + #add check to make sure facetted plots fit nicely in plotting window (600px). this is currently nrow * ncol in facet_wrap() + ifelse(length(targetIds()) * length(outcomeIds()) <= 10, + plotData <- filteredData(), + shiny::validate("Too many Target-Outcome pairs selected to plot efficiently. Please choose fewer targets and/or outcomes.") + ) + + #add check to make sure "Any" is in the year filter + ifelse("Any" %in% incidenceRateCalendarFilter(), + plotData <- filteredData(), + shiny::validate("This standard plot is designed to show results aggregated over all (`Any`) year categories. Please make sure you have selected `Any` in the `Select your results` section above for this variable.") + ) + + #add check to make sure males and females are included + ifelse(8507 %in% incidenceRateGenderFilter() & 8532 %in% incidenceRateGenderFilter(), + plotData <- filteredData(), + shiny::validate("This standard plot is designed to show results stratified by male and female biological sex. Please make sure you have both `Male` and `Female` selected above and try again.") + ) + + plotData <- plotData %>% + dplyr::filter( #ageGroupName != "Any" & + .data$genderName != "Any" & + .data$startYear == "Any") %>% + dplyr::mutate(targetLabel = paste(.data$targetNameShort, " = ", .data$targetName), + outcomeLabel = paste(.data$outcomeNameShort, " = ", .data$outcomeName), + ageGroupName = factor(.data$ageGroupName, levels = custom_age_sort(.data$ageGroupName), ordered = TRUE) + ) %>% + dplyr::rename(Target = "targetNameShort", + Outcome = "outcomeNameShort", + Age = "ageGroupName") + + # Get unique target and outcome labels + unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300) + unique_outcome_labels <- strwrap(unique(plotData$outcomeLabel), width = 300) + + # Combine all unique values into a final vector + final_unique_values <- unique(c(unique_target_labels, unique_outcome_labels)) + + # Create the caption text with line breaks + caption_text <- paste(final_unique_values, collapse = "\n") + + + # Take the specific tar value you want to plot + tar_value <- unique(plotData$tar)[1] + + base_plot <- ggplot2::ggplot( + data = plotData, + ggplot2::aes(x = .data$Age, + y = .data$incidenceRateP100py, + shape = .data$genderName, + color = .data$cdmSourceAbbreviation + ) + ) + + ggplot2::geom_point( + ggplot2::aes(size = 3) + ) + + #geom_jitter() + + #scale_size_continuous(range = c(5,15)) + + ggplot2::scale_colour_brewer(palette = "Paired") + + ggplot2::facet_wrap( + Target~Outcome, + labeller = "label_both", + scales = "free_x", + nrow = 2, + ncol = 5 + #, + #strip.position = "right" + ) + + ggplot2::scale_y_continuous(trans=scales::pseudo_log_trans(base = 10), + n.breaks = 4) + + base_plot <- base_plot + ggplot2::labs( + title = paste("Incidence Rate for Time at Risk:", tar_value), + x = paste(names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "ageGroupName"]), "\n"), + y = names(ciOptions$irPlotNumericChoices[ciOptions$irPlotNumericChoices %in% "incidenceRateP100py"]), + color = names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "cdmSourceAbbreviation"]), + #size = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "outcomes"]), + shape = names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "genderName"]), + caption = caption_text + ) + + ggplot2::guides(alpha = "none", size = "none") + # Remove the alpha and size legend + ggplot2::theme_bw() + + ggplot2::theme( + plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10), hjust = 0.5, size = 25, face="bold"), + plot.subtitle = ggplot2::element_text(margin = ggplot2::margin(b = 20), hjust = 0.5, size = 16), + axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 25), size = 18), + axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 25), size = 18), + axis.text.x = ggplot2::element_text(size = 14, angle = 45, hjust = 0.5, vjust = 0.25), + axis.text.y = ggplot2::element_text(size = 14), + legend.position = "bottom", + legend.box.spacing = ggplot2::unit(3, "pt"), + legend.text = ggplot2::element_text(size=10), + legend.title = ggplot2::element_text(size=16, face = "bold"), + legend.title.align = 0.5, + plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12, + margin = ggplot2::margin(t = 20)), + panel.spacing = ggplot2::unit(2, "lines"), + strip.text = ggplot2::element_text(face="bold", size = 14), + strip.background = ggplot2::element_blank(), + strip.clip = "off" + ) + + ggplot2::guides(shape = ggplot2::guide_legend(override.aes = list(size = 6)), + color = ggplot2::guide_legend(override.aes = list(size = 6)) + ) + + return(base_plot) + + }) + + output$incidencePlotStandardAgeSex<- + shiny::renderPlot({ + renderIrPlotStandardAgeSex() + }) + + + # Define a function to save the plot as an image + output$downloadPlotStandardAgeSex <- shiny::downloadHandler( + filename = function() { + paste("standard-age-sex-ir-plot-", Sys.Date(), ".png", sep = "") + }, + content = function(file) { + cowplot::save_plot(file, plot = renderIrPlotStandardAgeSex(), base_height = 12) + } ) - ) + - ggplot2::geom_point( - ggplot2::aes(size = 2.5) - ) + - ggplot2::geom_line(ggplot2::aes(linetype = genderName)) + - ggplot2::scale_colour_brewer(palette = "Paired") + - #geom_jitter() + - #scale_size_continuous(range = c(5,15)) + - # ggplot2::scale_colour_brewer(palette = "Paired") + - # ggplot2::facet_grid( - # rows = dplyr::vars(Outcome), - # cols = dplyr::vars(Age), - # labeller = ggplot2::labeller(.rows = outcomeLabeller, - # .cols = ageLabeller), - # scales = "free_y" - # ) + - ggplot2::facet_wrap( - ~Age, - labeller = "label_both", - scales = "free_x", - nrow = 2 - ) + - # scale_y_continuous(#breaks = base_breaks(), - # trans = 'log10') - ggplot2::scale_y_continuous(trans=scales::pseudo_log_trans(base = 10), - n.breaks = 3) - - base_plot <- base_plot + ggplot2::labs( - title = paste("Incidence Rate for Time at Risk:", tar_value), - subtitle = paste("Target = ", unique_target, "; Outcome = ", unique_outcome, sep = ""), - x = paste(names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "startYear"]), "\n"), - y = paste(names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "incidenceRateP100py"]), " (log10 scale)"), - color = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "cdmSourceAbbreviation"]), - #size = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "outcomes"]), - shape = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "genderName"]), - #linetype = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "genderName"]), - caption = caption_text - ) + - ggplot2::guides(alpha = "none", size = "none", linetype = "none") + # Remove the alpha and size legend - ggplot2::theme_bw() + - ggplot2::theme( - plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10), hjust = 0.5, size = 25, face="bold"), - plot.subtitle = ggplot2::element_text(margin = ggplot2::margin(b = 20), hjust = 0.5, size = 16), - axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 25), size = 18), - axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 25), size = 18), - axis.text.x = ggplot2::element_text(size = 14, angle = 45, hjust = 0.5, vjust = 0.25), - axis.text.y = ggplot2::element_text(size = 14), - legend.position = "bottom", - legend.box.spacing = ggplot2::unit(3, "pt"), - legend.text = ggplot2::element_text(size=10), - legend.title = ggplot2::element_text(size=16, face = "bold"), - legend.title.align = 0.5, - plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12, - margin = ggplot2::margin(t = 20)), - #legend.spacing.x = ggplot2::unit(2.0, 'cm'), - # legend.box = "horizontal", - # legend.key.size = ggplot2::unit(3, 'points'), #change legend key size - # legend.title = ggplot2::element_text(size=30), #change legend title font size - # legend.text = ggplot2::element_text(size=20), - panel.spacing = ggplot2::unit(2, "lines"), - # strip.background = ggplot2::element_blank(), - strip.text = ggplot2::element_text(face="bold", size = 14), - strip.background = ggplot2::element_blank(), - strip.clip = "off" - ) + - ggplot2::guides(shape = ggplot2::guide_legend(override.aes = list(size = 6)), - color = ggplot2::guide_legend(override.aes = list(size = 6)) + + + + # by calendar year + renderIrPlotStandardYear <- shiny::reactive({ + + if (is.null(targetIds()) | + is.null(outcomeIds())) { + return(data.frame()) + } + if(nrow(filteredData()) == 0){ + return(data.frame()) + } + + ifelse(incidenceRateTarFilter() %in% filteredData()$tar, + plotData <- filteredData() %>% + dplyr::filter(.data$tar %in% incidenceRateTarFilter()), + shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") + ) + + ifelse(length(incidenceRateTarFilter() %in% filteredData()$tar) == 1, + plotData <- filteredData() %>% + dplyr::filter(.data$tar %in% incidenceRateTarFilter()), + shiny::validate("Please select only one TAR at a time to view yearly plots.") + ) + + ifelse((length(targetIds()) == 1) & + (length(outcomeIds()) == 1), + plotData <- plotData, + shiny::validate("Please select only one Target and Outcome at a time to view yearly plots.") + ) + + ifelse((length(incidenceRateCalendarFilter()) == 1) & + (incidenceRateCalendarFilter() == "Any"), + shiny::validate("Please select at least one start year besides `Any`. This plot depicts calendar trends over time on the x-axis, so at least one distinct year is required."), + plotData <- plotData + ) + + + + plotData <- plotData %>% + dplyr::filter(.data$genderName != "Any" & + .data$startYear != "Any") %>% + dplyr::mutate(targetLabel = paste(.data$targetNameShort, " = ", .data$targetName), + outcomeLabel = paste(.data$outcomeNameShort, " = ", .data$outcomeName), + ageGroupName = factor(.data$ageGroupName, levels = custom_age_sort(.data$ageGroupName), ordered = TRUE) + ) %>% + dplyr::rename(Target = "targetNameShort", + Outcome = "outcomeNameShort", + Age = "ageGroupName") + + #get unique shorthand cohort name + unique_target <- unique(plotData$Target) + unique_outcome <- unique(plotData$Outcome) + + + # Get unique target and outcome labels + unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300) + unique_outcome_labels <- strwrap(unique(plotData$outcomeLabel), width = 300) + + # Combine all unique values into a final vector + final_unique_values <- unique(c(unique_target_labels, unique_outcome_labels)) + + # Create the caption text with line breaks + caption_text <- paste(final_unique_values, collapse = "\n") + + + # Take the specific tar value you want to plot + tar_value <- unique(plotData$tar)[1] + + plotData <- plotData %>% + dplyr::filter("Any" %!in% .data$startYear) %>% + dplyr::mutate(startYear = as.Date(paste0(.data$startYear, "-01-01")) + ) + + base_plot <- ggplot2::ggplot( + data = plotData, + ggplot2::aes(x = .data$startYear, + y = .data$incidenceRateP100py, + shape = .data$genderName, + color = .data$cdmSourceAbbreviation, + group = interaction(.data$cdmSourceAbbreviation, .data$genderName) + ) + ) + + ggplot2::geom_point( + ggplot2::aes(size = 2.5) + ) + + ggplot2::geom_line(ggplot2::aes(linetype = .data$genderName)) + + ggplot2::scale_colour_brewer(palette = "Paired") + + ggplot2::facet_wrap( + ~Age, + labeller = "label_both", + scales = "free_x", + nrow = 2 + ) + + ggplot2::scale_y_continuous(trans=scales::pseudo_log_trans(base = 10), + n.breaks = 3) + + ggplot2::scale_x_date(breaks= seq(min(plotData$startYear), max(plotData$startYear), by = "3 years"), + date_labels = "%Y", + limits = c(min(plotData$startYear), + max(plotData$startYear)) + ) + + base_plot <- base_plot + ggplot2::labs( + title = paste("Incidence Rate for Time at Risk:", tar_value), + subtitle = paste("Target = ", unique_target, "; Outcome = ", unique_outcome, sep = ""), + x = paste(names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "startYear"]), "\n"), + y = paste(names(ciOptions$irPlotNumericChoices[ciOptions$irPlotNumericChoices %in% "incidenceRateP100py"]), " (log10 scale)"), + color = names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "cdmSourceAbbreviation"]), + shape = names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "genderName"]), + caption = caption_text + ) + + ggplot2::guides(alpha = "none", size = "none", linetype = "none") + # Remove the alpha and size legend + ggplot2::theme_bw() + + ggplot2::theme( + plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10), hjust = 0.5, size = 25, face="bold"), + plot.subtitle = ggplot2::element_text(margin = ggplot2::margin(b = 20), hjust = 0.5, size = 16), + axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 25), size = 18), + axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 25), size = 18), + axis.text.x = ggplot2::element_text(size = 14, angle = 45, hjust = 0.5, vjust = 0.25), + axis.text.y = ggplot2::element_text(size = 14), + legend.position = "bottom", + legend.box.spacing = ggplot2::unit(3, "pt"), + legend.text = ggplot2::element_text(size=10), + legend.title = ggplot2::element_text(size=16, face = "bold"), + legend.title.align = 0.5, + plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12, + margin = ggplot2::margin(t = 20)), + panel.spacing = ggplot2::unit(2, "lines"), + strip.text = ggplot2::element_text(face="bold", size = 14), + strip.background = ggplot2::element_blank(), + strip.clip = "off" + ) + + ggplot2::guides(shape = ggplot2::guide_legend(override.aes = list(size = 6)), + color = ggplot2::guide_legend(override.aes = list(size = 6)) + ) + + return(base_plot) + + }) + + output$incidencePlotStandardYear<- + shiny::renderPlot({ + renderIrPlotStandardYear() + }) + + + # Define a function to save the plot as an image + output$downloadPlotStandardYear <- shiny::downloadHandler( + filename = function() { + paste("standard-yearly-ir-plot-", Sys.Date(), ".png", sep = "") + }, + content = function(file) { + cowplot::save_plot(file, plot = renderIrPlotStandardYear(), base_height = 24) + } ) - - return(base_plot) - - } -) - -output$incidencePlotStandardYear<- - shiny::renderPlot({ - renderIrPlotStandardYear() - }) - - -# Define a function to save the plot as an image -output$downloadPlotStandardYear <- shiny::downloadHandler( - filename = function() { - paste("standard-yearly-ir-plot-", Sys.Date(), ".png", sep = "") - }, - content = function(file) { - cowplot::save_plot(file, plot = renderIrPlotStandardYear(), base_height = 24) - } -) - - - - - - - - -#aggregate (unstratified) + -renderIrPlotStandardAggregate <- shiny::reactive( - { - - if (is.null(inputSelectedResults()$targetIds) | - is.null(inputSelectedResults()$outcomeIds) | - is.null(inputSelectedResults()$incidenceRateDbFilter) - ) { - return(data.frame()) - } - - ifelse(inputSelectedResults()$incidenceRateTarFilter %in% filteredData()$tar, - plotData <- filteredDataAggregateForPlot() %>% - dplyr::filter(.data$tar %in% inputSelectedResults()$incidenceRateTarFilter), - shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") - ) - - #add check to make sure facetted plots fit nicely in plotting window (600px). this is currently nrow * ncol in facet_wrap() - ifelse(length(inputSelectedResults()$targetId) * length(inputSelectedResults()$outcomeId) <= 10, - plotData <- filteredData(), - shiny::validate("Too many Target-Outcome pairs selected to plot efficiently. Please choose fewer targets and/or outcomes.") - ) - - plotData <- plotData %>% - dplyr::filter(ageGroupName == "Any" & - genderName == "Any") %>% - dplyr::mutate(targetLabel = paste(targetIdShort, " = ", targetName), - outcomeLabel = paste(outcomeIdShort, " = ", outcomeName) - ) %>% - dplyr::rename("Target" = targetIdShort, - "Outcome" = outcomeIdShort, - "Age" = ageGroupName) - - # Get unique target and outcome labels - unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300) - unique_outcome_labels <- strwrap(unique(plotData$outcomeLabel), width = 300) - - # Combine all unique values into a final vector - final_unique_values <- unique(c(unique_target_labels, unique_outcome_labels)) - - # Create the caption text with line breaks - caption_text <- paste(final_unique_values, collapse = "\n") - - - # Take the specific tar value you want to plot - tar_value <- unique(plotData$tar)[1] - - base_plot <- ggplot2::ggplot( - data = plotData, - ggplot2::aes(x = startYear, - y = incidenceRateP100py, - #shape = genderName, - color = cdmSourceAbbreviation + #aggregate (unstratified) + + renderIrPlotStandardAggregate <- shiny::reactive({ + + if (is.null(targetIds()) | + is.null(outcomeIds())) { + return(data.frame()) + } + if(nrow(filteredData()) == 0){ + return(data.frame()) + } + + ifelse(incidenceRateTarFilter() %in% filteredData()$tar, + plotData <- filteredDataAggregateForPlot() %>% + dplyr::filter(.data$tar %in% incidenceRateTarFilter()), + shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.") + ) + + #add check to make sure facetted plots fit nicely in plotting window (600px). this is currently nrow * ncol in facet_wrap() + ifelse(length(targetIds()) * length(outcomeIds()) <= 10, + plotData <- filteredData(), + shiny::validate("Too many Target-Outcome pairs selected to plot efficiently. Please choose fewer targets and/or outcomes.") + ) + + ifelse("Any" %in% incidenceRateAgeFilter() & + "Any" %in% incidenceRateGenderFilter() & + "Any" %in% incidenceRateCalendarFilter(), + plotData <- filteredData(), + shiny::validate("This plot requires the `Any` category to be selected to aggregate over all ages, sexes, and years. Please ensure `Any` is selected in each of these inputs above and try again.") + ) + + plotData <- plotData %>% + dplyr::filter(.data$ageGroupName == "Any" & + .data$genderName == "Any") %>% + dplyr::mutate(targetLabel = paste(.data$targetNameShort, " = ", .data$targetName), + outcomeLabel = paste(.data$outcomeNameShort, " = ", .data$outcomeName) + ) %>% + dplyr::rename(Target = "targetNameShort", + Outcome = "outcomeNameShort", + Age = "ageGroupName") + + # Get unique target and outcome labels + unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300) + unique_outcome_labels <- strwrap(unique(plotData$outcomeLabel), width = 300) + + # Combine all unique values into a final vector + final_unique_values <- unique(c(unique_target_labels, unique_outcome_labels)) + + # Create the caption text with line breaks + caption_text <- paste(final_unique_values, collapse = "\n") + + + # Take the specific tar value you want to plot + tar_value <- unique(plotData$tar)[1] + + base_plot <- ggplot2::ggplot( + data = plotData, + ggplot2::aes(x = .data$startYear, + y = .data$incidenceRateP100py, + color = .data$cdmSourceAbbreviation + ) + ) + + ggplot2::geom_point( + ggplot2::aes(size = 3) + ) + + #ggplot2::geom_jitter() + + #scale_size_continuous(range = c(5,15)) + + ggplot2::scale_colour_brewer(palette = "Paired") + + ggplot2::facet_wrap( + Target~Outcome, + labeller = "label_both", + scales = "free_x", + nrow = 2, + ncol = 5 + #, + #strip.position = "right" + ) + + ggplot2::scale_y_continuous(trans=scales::pseudo_log_trans(base = 10), + n.breaks = 4) + + base_plot <- base_plot + ggplot2::labs( + title = paste("Incidence Rate for Time at Risk:", tar_value), + x = paste(names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "startYear"]), "\n"), + y = names(ciOptions$irPlotNumericChoices[ciOptions$irPlotNumericChoices %in% "incidenceRateP100py"]), + color = names(ciOptions$irPlotCategoricalChoices[ciOptions$irPlotCategoricalChoices %in% "cdmSourceAbbreviation"]), + caption = caption_text + ) + + ggplot2::guides(alpha = "none", size = "none") + # Remove the alpha and size legend + ggplot2::theme_bw() + + ggplot2::theme( + plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10), hjust = 0.5, size = 25, face="bold"), + plot.subtitle = ggplot2::element_text(margin = ggplot2::margin(b = 20), hjust = 0.5, size = 16), + axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 25), size = 18), + axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 25), size = 18), + axis.text.x = ggplot2::element_text(size = 14, angle = 45, hjust = 0.5, vjust = 0.25), + axis.text.y = ggplot2::element_text(size = 14), + legend.position = "bottom", + legend.box.spacing = ggplot2::unit(3, "pt"), + legend.text = ggplot2::element_text(size=10), + legend.title = ggplot2::element_text(size=16, face = "bold"), + legend.title.align = 0.5, + plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12, + margin = ggplot2::margin(t = 20)), + panel.spacing = ggplot2::unit(2, "lines"), + strip.text = ggplot2::element_text(face="bold", size = 14), + strip.background = ggplot2::element_blank(), + strip.clip = "off" + ) + + ggplot2::guides(shape = ggplot2::guide_legend(override.aes = list(size = 6)), + color = ggplot2::guide_legend(override.aes = list(size = 6))) + + return(base_plot) + + }) + + output$incidencePlotStandardAggregate <- + shiny::renderPlot({ + renderIrPlotStandardAggregate() + }) + + + # Define a function to save the plot as an image + output$downloadPlotStandardAggregate <- shiny::downloadHandler( + filename = function() { + paste("standard-aggregate-ir-plot-", Sys.Date(), ".png", sep = "") + }, + content = function(file) { + cowplot::save_plot(file, plot = renderIrPlotStandardAggregate(), base_height = 12) + } ) - ) + - ggplot2::geom_point( - ggplot2::aes(size = 3) - ) + - #ggplot2::geom_jitter() + - #scale_size_continuous(range = c(5,15)) + - ggplot2::scale_colour_brewer(palette = "Paired") + - ggplot2::facet_wrap( - Target~Outcome, - labeller = "label_both", - scales = "free_x", - nrow = 2, - ncol = 5 - #, - #strip.position = "right" - ) + - ggplot2::scale_y_continuous(trans=scales::pseudo_log_trans(base = 10), - n.breaks = 4) - - base_plot <- base_plot + ggplot2::labs( - title = paste("Incidence Rate for Time at Risk:", tar_value), - x = paste(names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "startYear"]), "\n"), - y = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "incidenceRateP100py"]), - color = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "cdmSourceAbbreviation"]), - #size = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% "outcomes"]), - #shape = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% "genderName"]), - caption = caption_text - ) + - ggplot2::guides(alpha = "none", size = "none") + # Remove the alpha and size legend - ggplot2::theme_bw() + - ggplot2::theme( - plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10), hjust = 0.5, size = 25, face="bold"), - plot.subtitle = ggplot2::element_text(margin = ggplot2::margin(b = 20), hjust = 0.5, size = 16), - axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 25), size = 18), - axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 25), size = 18), - axis.text.x = ggplot2::element_text(size = 14, angle = 45, hjust = 0.5, vjust = 0.25), - axis.text.y = ggplot2::element_text(size = 14), - legend.position = "bottom", - legend.box.spacing = ggplot2::unit(3, "pt"), - legend.text = ggplot2::element_text(size=10), - legend.title = ggplot2::element_text(size=16, face = "bold"), - legend.title.align = 0.5, - plot.caption = ggplot2::element_text(hjust = 0, face = "italic", size = 12, - margin = ggplot2::margin(t = 20)), - #legend.spacing.x = ggplot2::unit(2.0, 'cm'), - # legend.box = "horizontal", - # legend.key.size = ggplot2::unit(3, 'points'), #change legend key size - # legend.title = ggplot2::element_text(size=30), #change legend title font size - # legend.text = ggplot2::element_text(size=20), - panel.spacing = ggplot2::unit(2, "lines"), - # strip.background = ggplot2::element_blank(), - strip.text = ggplot2::element_text(face="bold", size = 14), - strip.background = ggplot2::element_blank(), - strip.clip = "off" - ) + - ggplot2::guides(shape = ggplot2::guide_legend(override.aes = list(size = 6)), - color = ggplot2::guide_legend(override.aes = list(size = 6))) - - return(base_plot) - - } -) - -output$incidencePlotStandardAggregate <- - shiny::renderPlot({ - renderIrPlotStandardAggregate() - }) - - -# Define a function to save the plot as an image -output$downloadPlotStandardAggregate <- shiny::downloadHandler( - filename = function() { - paste("standard-aggregate-ir-plot-", Sys.Date(), ".png", sep = "") - }, - content = function(file) { - cowplot::save_plot(file, plot = renderIrPlotStandardAggregate(), base_height = 12) - } -) - - - + return(invisible(NULL)) ############# end of server }) } - - - - - - - - - - - - +#------------ #------------ Fetching data functions - +#------------ + getIncidenceData <- function( targetIds, outcomeIds, connectionHandler, resultDatabaseSettings ){ - if(!is.null(targetIds) & !is.null(outcomeIds)){ - #shiny::withProgress(message = 'Getting incidence data', value = 0, { + print(targetIds) + print(outcomeIds) - sql <- 'select d.cdm_source_abbreviation, i.* - from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY i - inner join @result_schema.@database_table_name d + shiny::withProgress(message = 'Getting incidence data', value = 0, { + + sql <- 'select d.cdm_source_abbreviation, i.*, ct1.cohort_name as target_name, ct2.cohort_name as outcome_name +from ( + select od.outcome_cohort_definition_id, od.clean_window, agd.age_group_name, + tad.tar_start_with, tad.tar_start_offset, tad.tar_end_with, tad.tar_end_offset, + sd.subgroup_name, i.* + from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY i + join @result_schema.@incidence_table_prefixOUTCOME_DEF od on i.outcome_id = od.outcome_id + and i.ref_id = od.ref_id + join @result_schema.@incidence_table_prefixTAR_DEF tad on i.tar_id = tad.tar_id + and i.ref_id = tad.ref_id + join @result_schema.@incidence_table_prefixSUBGROUP_DEF sd on i.subgroup_id = sd.subgroup_id + and i.ref_id = sd.ref_id + left join @result_schema.@incidence_table_prefixAGE_GROUP_DEF agd on i.age_group_id = agd.age_group_id + and i.ref_id = agd.ref_id +) i +inner join @result_schema.@database_table_name d on d.database_id = i.database_id - where target_cohort_definition_id in (@target_ids) - and outcome_cohort_definition_id in (@outcome_ids) - ;' +inner join @result_schema.@cg_table_prefixcohort_definition ct1 + on ct1.cohort_definition_id = i.target_cohort_definition_id +inner join @result_schema.@cg_table_prefixcohort_definition ct2 + on ct2.cohort_definition_id = i.outcome_cohort_definition_id +where i.target_cohort_definition_id in (@target_ids) + and i.outcome_cohort_definition_id in (@outcome_ids);' - #shiny::incProgress(1/2, detail = paste("Created SQL - Extracting...")) + shiny::incProgress(1/2, detail = paste("Created SQL - Extracting...")) resultTable <- connectionHandler$queryDb( sql = sql, result_schema = resultDatabaseSettings$schema, incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, target_ids = paste(as.double(targetIds), collapse = ','), outcome_ids = paste(as.double(outcomeIds), collapse = ','), database_table_name = resultDatabaseSettings$databaseTable ) - #shiny::incProgress(2/2, detail = paste("Done...")) - - #}) - - # format the tar - resultTable$tar <- paste0('(',resultTable$tarStartWith, " + ", resultTable$tarStartOffset, ') - (', resultTable$tarEndWith, " + ", resultTable$tarEndOffset, ')') - resultTable <- resultTable %>% - dplyr::select(-c("tarStartWith","tarStartOffset","tarEndWith","tarEndOffset", "tarId", "subgroupName")) + shiny::incProgress(2/2, detail = paste("Extracted ", nrow(resultTable)," rows")) - resultTable[is.na(resultTable)] <- 'Any' - resultTable <- unique(resultTable) + }) + if(nrow(resultTable)>0){ + + # format the tar + ##Jenna edit resultTable$tar <- paste0('(',resultTable$tarStartWith, " + ", resultTable$tarStartOffset, ') - (', resultTable$tarEndWith, " + ", resultTable$tarEndOffset, ')') + resultTable$tar <- cohortIncidenceFormatTar(resultTable) + + resultTable <- resultTable %>% + dplyr::select(-c("tarStartWith","tarStartOffset","tarEndWith","tarEndOffset", "tarId", "subgroupName")) + + resultTable[is.na(resultTable)] <- 'Any' + resultTable <- unique(resultTable) + } return(resultTable) } else{ return(NULL) } } +# Jenna added +cohortIncidenceFormatTar <- function(x){ + result <- paste0('(',x$tarStartWith, " + ", x$tarStartOffset, ') - (', x$tarEndWith, " + ", x$tarEndOffset, ')') + return(result) +} -getIncidenceOptions <- function( - connectionHandler, - resultDatabaseSettings -){ - - # shiny::withProgress(message = 'Getting incidence inputs', value = 0, { - - sql <- 'select distinct target_cohort_definition_id, target_name - from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;' - - #shiny::incProgress(1/3, detail = paste("Created SQL - Extracting targets")) - - targets <- connectionHandler$queryDb( - sql = sql, - result_schema = resultDatabaseSettings$schema, - incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix - ) - targetIds <- targets$targetCohortDefinitionId - names(targetIds) <- targets$targetName - - sql <- 'select distinct outcome_cohort_definition_id, outcome_name - from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;' - - #shiny::incProgress(2/3, detail = paste("Created SQL - Extracting outcomes")) - - outcomes <- connectionHandler$queryDb( - sql = sql, - result_schema = resultDatabaseSettings$schema, - incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix - ) - - outcomeIds <- outcomes$outcomeCohortDefinitionId - names(outcomeIds) <- outcomes$outcomeName - - sql <- 'select distinct d.cdm_source_abbreviation - from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY i - inner join @result_schema.@database_table_name d - on d.database_id = i.database_id - ;' - - #shiny::incProgress(2/3, detail = paste("Created SQL - Extracting outcomes")) - - cdmSourceAbbreviations <- connectionHandler$queryDb( - sql = sql, +getIncidenceOptions <- function(connectionHandler, + resultDatabaseSettings){ + + # database options + databaseDf <- connectionHandler$queryDb( + sql = 'select database_id, cdm_source_abbreviation from @result_schema.@database_table_name;', result_schema = resultDatabaseSettings$schema, - incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix, database_table_name = resultDatabaseSettings$databaseTable ) - - cdmSourceAbbreviations <- cdmSourceAbbreviations$cdmSourceAbbreviation - #names(cdmSourceAbbreviations) <- cdmSourceAbbreviations$cdmSourceAbbreviation - - sql <- 'select distinct tar_id, tar_start_with, tar_start_offset, tar_end_with, tar_end_offset - from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;' - - #shiny::incProgress(1/3, detail = paste("Created SQL - Extracting targets")) - - tars <- connectionHandler$queryDb( - sql = sql, - result_schema = resultDatabaseSettings$schema, - incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix - ) - tar <- paste0('(',tars$tarStartWith, " + ", tars$tarStartOffset, ') - (', tars$tarEndWith, " + ", tars$tarEndOffset, ')') - #tar <- tars$tarId - names(tar) <- paste0('(',tars$tarStartWith, " + ", tars$tarStartOffset, ') - (', tars$tarEndWith, " + ", tars$tarEndOffset, ')') - - sql <- 'select distinct age_group_name - from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;' - - result <- connectionHandler$queryDb( - sql = sql, + databases <- databaseDf$cdmSourceAbbreviation + + # Age Gruop Options + ageGroupDf <- connectionHandler$queryDb( + sql = 'select age_group_id, age_group_name from @result_schema.@incidence_table_prefixAGE_GROUP_DEF;', result_schema = resultDatabaseSettings$schema, incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix ) + ageGroupDf <- rbind(data.frame(ageGroupId = 'Any', ageGroupName = 'Any'), ageGroupDf) + ageGroup <- ageGroupDf$ageGroupId + names(ageGroup) <- ageGroupDf$ageGroupName - ageGroupName <- result$ageGroupName - ageGroupName[is.na(ageGroupName)] <- 'Any' - ageGroupName <- sort(ageGroupName) + sex <- c(8507, 8532 , 'Any') + names(sex) <- c('Male', 'Female', 'Any') - sql <- 'select distinct gender_name - from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;' + startYear <- c('Any', format(Sys.Date(), "%Y"):1990) + names(startYear) <- c('Any', format(Sys.Date(), "%Y"):1990) - result <- connectionHandler$queryDb( - sql = sql, - result_schema = resultDatabaseSettings$schema, - incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix - ) + # get tar and then call cohortIncidenceFormatTar() - genderName <- result$genderName - genderName[is.na(genderName)] <- 'Any' - genderName <- sort(genderName) + tarDf <- characterizationGetCiTars(connectionHandler,resultDatabaseSettings) - sql <- 'select distinct start_year - from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;' + tar <- tarDf$tarId + names(tar) <- cohortIncidenceFormatTar(tarDf) - result <- connectionHandler$queryDb( + sql <- ' +select outcome_id, outcome_name +from @result_schema.@incidence_table_prefixOUTCOME_DEF +' + outcomeDf <- connectionHandler$queryDb( sql = sql, result_schema = resultDatabaseSettings$schema, incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix ) - - startYear <- result$startYear - startYear[is.na(startYear)] <- 'Any' - startYear <- sort(startYear) - - # shiny::incProgress(3/3, detail = paste("Done")) - # }) + outcomes <- outcomeDf$outcomeId + names(outcomes) <- outcomeDf$outcomeName irPlotCategoricalChoices <- list( "cdmSourceAbbreviation", @@ -2081,17 +1858,41 @@ getIncidenceOptions <- function( return( list( - targetIds = targetIds, - outcomeIds = outcomeIds, - cdmSourceAbbreviations = cdmSourceAbbreviations, + databases = databases, + ageGroup = ageGroup, + sex = sex, + startYear = startYear, tar = tar, + outcomes = outcomes, irPlotNumericChoices = irPlotNumericChoices, - irPlotCategoricalChoices = irPlotCategoricalChoices, - ageGroupName = ageGroupName, - genderName = genderName, - startYear = startYear + irPlotCategoricalChoices = irPlotCategoricalChoices ) ) } +characterizationGetCiTars <- function(connectionHandler, + resultDatabaseSettings){ + sql <- "SELECT TAR_ID, TAR_START_WITH, TAR_START_OFFSET, + TAR_END_WITH, TAR_END_OFFSET + from @schema.@ci_table_prefixtar_def;" + tars <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + ci_table_prefix = resultDatabaseSettings$incidenceTablePrefix + ) + return(tars) +} + +.createCiColDefList <- function() { + colDefCsv <- readr::read_csv(system.file("components-columnInformation", + "characterization-incidence-colDefs.csv", + package = "OhdsiShinyModules"), + show_col_types = FALSE) + + createCustomColDefList( + rawColNames = colDefCsv$colName, + niceColNames = colDefCsv$niceName, + tooltipText = colDefCsv$toolTip + ) +} \ No newline at end of file diff --git a/R/characterization-main.R b/R/characterization-main.R index 5cfdf43e..ca918d18 100644 --- a/R/characterization-main.R +++ b/R/characterization-main.R @@ -21,7 +21,7 @@ #' #' @details #' Returns the location of the characterization helper file -#' +#' @family {Characterization} #' @return #' string location of the characterization helper file #' @@ -37,7 +37,7 @@ characterizationHelperFile <- function(){ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {Characterization} #' @return #' The user interface to the characterization viewer module #' @@ -46,14 +46,28 @@ characterizationViewer <- function(id=1) { ns <- shiny::NS(id) shinydashboard::box( - status = 'info', width = 12, + status = 'info', width = '100%', title = shiny::span( shiny::icon("table"), "Characterization Viewer"), solidHeader = TRUE, - - shiny::tabsetPanel( - type = 'pills', - id = ns('mainPanel') - ) + + # pick a targetId of interest + shinydashboard::box( + title = 'Target Of Interest', + width = '100%', + status = "primary", + collapsible = T, + shiny::uiOutput(ns("targetSelection")) + ), + + shiny::conditionalPanel( + condition = 'input.targetSelect', + ns = ns, + inputSelectionDfViewer(id = ns('targetSelected'), title = 'Selected Target'), + shiny::tabsetPanel( + type = 'pills', + id = ns('mainPanel') + ) + ) ) } @@ -66,7 +80,7 @@ characterizationViewer <- function(id=1) { #' @param id the unique reference id for the module #' @param connectionHandler a connection to the database with the results #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix -#' +#' @family {Characterization} #' @return #' The server for the characterization module #' @@ -79,7 +93,8 @@ 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 @@ -87,109 +102,428 @@ characterizationServer <- function( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings ) + + #================================================ + # GETTING OPTIONS FOR INPTUS + #================================================ + #TODO add time-to-event and dechal-rechal options + options <- characterizationGetOptions( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + includeAggregate = "Risk Factor" %in% charTypes$subPanel, + includeIncidence = "Incidence Results" %in% charTypes$subPanel + ) + + #================================================ + # PARENT TARGET SELECTION UI + #================================================ + parents <- characterizationGetParents(options) + parentIndex <- shiny::reactiveVal(1) + subTargets <- shiny::reactiveVal() + + # add an input for all char that lets you select cohort of interest + output$targetSelection <- shiny::renderUI({ + shiny::div( + shinyWidgets::pickerInput( + inputId = session$ns('targetId'), + label = 'Target Group: ', + choices = parents, + selected = parents[1], + multiple = FALSE, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + dropupAuto = F, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 500 + ) + ), + shiny::selectInput( + inputId = session$ns('subTargetId'), + label = 'Target: ', + choices = characterizationGetChildren(options,1), + selected = 1, + multiple = FALSE, + selectize = TRUE, + width = NULL, + size = NULL + ), + shiny::actionButton( + inputId = session$ns('targetSelect'), + label = 'Select', + icon = shiny::icon('redo') + ) + ) + }) + + #================================================ + # UPDATE TARGET BASED ON TARGET GROUP + #================================================ + shiny::observeEvent(input$targetId,{ + parentIndex(which(parents == input$targetId)) + subTargets(characterizationGetChildren(options,which(parents == input$targetId))) + shiny::updateSelectInput( + inputId = 'subTargetId', + label = 'Target: ', + choices = subTargets(), + selected = subTargets()[1] + ) + }) + + #================================================ + # PARENT TARGET SELECTION ACTION + #================================================ + # reactives updated when parent target is selected + outcomes <- shiny::reactiveVal() + targetSelected <- shiny::reactiveVal() + subTargetId <- shiny::reactiveVal() + # output the selected target + shiny::observeEvent(input$targetSelect, { + + # First create input dataframe and add to the inputServer to display + targetSelected( + data.frame( + `Target group` = names(parents)[parents == input$targetId], + `Target` = names(subTargets())[subTargets() == input$subTargetId] + ) + ) + inputSelectionDfServer( + id = 'targetSelected', + dataFrameRow = targetSelected, + ncol = 1 + ) + + subTargetId(input$subTargetId) + + # update the outcomes for the selected parent target id + outcomes(characterizationGetOutcomes(options, parentIndex())) - # 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') + # create the outcome selector for the case exposure tabs + output$outcomeSelection <- shiny::renderUI({ + shinydashboard::box( + collapsible = TRUE, + title = "Options", + width = "100%", + + shinyWidgets::pickerInput( + inputId = session$ns('outcomeId'), + label = 'Outcome: ', + choices = outcomes(), + selected = 1, + multiple = FALSE, + options = shinyWidgets::pickerOptions( + actionsBox = F, + dropupAuto = F, + size = 10, + liveSearch = TRUE, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search" + ) + ), + shiny::actionButton( + inputId = session$ns('outcomeSelect'), + label = 'Select', + icon = shiny::icon('redo') + ) + ) + }) + + }) + + #================================================ + # OUTCOME SELECTION ACTION + #================================================ + # used by the case exposure tabs + # show the selected outcome + outcomeSelected <- shiny::reactiveVal() + outcomeId <- shiny::reactiveVal() + #subTargetId <- shiny::reactiveVal() + + shiny::observeEvent(input$outcomeSelect, { + outcomeSelected( + data.frame( + #Target = names(subTargets())[subTargets() == input$subTargetId], + Outcome = names(outcomes())[outcomes() == input$outcomeId] + ) + ) + + # store the outcome and subTargetIds for the case exposure tabs + outcomeId(input$outcomeId) + #subTargetId(input$subTargetId) + + inputSelectionDfServer( + id = 'outcomeSelected', + dataFrameRow = outcomeSelected, + ncol = 1 + ) + }) + + + #================================================ + # CREATE TABS BASED ON RESULTS TABLES + #================================================ + + # MAIN PANELS + #first populate the mainPanel + typesMainPanel <- list( + list( + title = 'Cohort Summary', + shiny::tabsetPanel( + type = 'pills', + id = session$ns('cohortSummaryPanel') + ) + ), + list( + title = 'Exposed Cases Summary', + shiny::uiOutput(session$ns("outcomeSelection")), + shiny::conditionalPanel( + condition = 'input.outcomeSelect', + ns = session$ns, + inputSelectionDfViewer(id = session$ns('outcomeSelected'), title = 'Selected'), + shiny::tabsetPanel( + type = 'pills', + id = session$ns('exposedCasesPanel') + ) + ) + ), + list( + title = 'Cohort Incidence', + shiny::tabsetPanel( + type = 'pills', + id = session$ns('cohortIncidencePanel') + ) ) + ) + selectVal <- T - for( type in types){ - if(type[1] %in% charTypes){ + for( type in typesMainPanel){ + if(type$title %in% charTypes$mainPanel){ shiny::insertTab( - inputId = "mainPanel", - tab = shiny::tabPanel( - type[1], - do.call(what = type[2], args = list(id = session$ns(type[3]))) - ), + inputId = 'mainPanel', + tab = do.call( + what = shiny::tabPanel, + args = type + ), select = selectVal ) selectVal = F } - } + + # SUB PANELS + # now populate the subpanel + # add the tabs based on results + types <- rbind( + c("Database Comparison","characterizationDatabaseComparisonViewer", "databaseComparisonTab", "cohortSummaryPanel"), + c("Cohort Comparison", "characterizationCohortComparisonViewer", "cohortComparisonTab", "cohortSummaryPanel"), - previouslyLoaded <- shiny::reactiveVal(c()) + c("Risk Factor", "characterizationRiskFactorViewer", "riskFactorTab", "exposedCasesPanel"), + c("Case Series", "characterizationCaseSeriesViewer", "caseSeriesTab", "exposedCasesPanel"), + c("Time-to-event", "characterizationTimeToEventViewer", "timeToEventTab", "exposedCasesPanel"), + c("Dechallenge Rechallenge", 'characterizationDechallengeRechallengeViewer', 'dechallengeRechallengeTab', "exposedCasesPanel"), + + c("Incidence Results", "characterizationIncidenceViewer", "cohortIncidenceTab", "cohortIncidencePanel") + ) + colnames(types) <- c('c1', 'c2', 'c3', 'c4') + types <- as.data.frame(types) - # only render the tab when selected + for(subPanel in c("cohortSummaryPanel", "exposedCasesPanel", "cohortIncidencePanel")){ + typesOfInterest <- types %>% dplyr::filter(.data$c4 == subPanel) + if(nrow(typesOfInterest)>0){ + selectVal <- T + for( i in 1:nrow(typesOfInterest)){ + if(typesOfInterest[i,1] %in% charTypes$subPanel){ + shiny::insertTab( + inputId = typesOfInterest[i,4], + tab = shiny::tabPanel( + typesOfInterest[i,1], + do.call(what = typesOfInterest[i,2], args = list(id = session$ns(typesOfInterest[i,3]))) + ), + select = selectVal + ) + selectVal = F + } + } + } + } + + + # ============================= + # TRACK CURRENT TAB + # ============================= + # set the current tab + mainPanel <- shiny::reactiveVal('None') shiny::observeEvent(input$mainPanel,{ + mainPanel(input$mainPanel) + }) + cohortSummaryPanel <- shiny::reactiveVal('None') + shiny::observeEvent(input$cohortSummaryPanel,{ + cohortSummaryPanel(input$cohortSummaryPanel) + }) + exposedCasesPanel <- shiny::reactiveVal('None') + shiny::observeEvent(input$exposedCasesPanel,{ + exposedCasesPanel(input$exposedCasesPanel) + }) + + currentTab <- shiny::reactive({ + if(mainPanel() == "Cohort Summary" & cohortSummaryPanel() == 'Cohort Comparison'){ + return('Cohort Comparison') + } + if(mainPanel() == "Cohort Summary" & cohortSummaryPanel() == 'Database Comparison'){ + return('Database Comparison') + } + if(mainPanel() == "Exposed Cases Summary" & exposedCasesPanel() == 'Risk Factor'){ + return('Risk Factor') + } + if(mainPanel() == "Exposed Cases Summary" & exposedCasesPanel() == 'Case Series'){ + return('Case Series') + } + if(mainPanel() == "Exposed Cases Summary" & exposedCasesPanel() == 'Time-to-event'){ + return('Time-to-event') + } + if(mainPanel() == "Exposed Cases Summary" & exposedCasesPanel() == 'Dechallenge Rechallenge'){ + return('Dechallenge Rechallenge') + } + if(mainPanel() == "Cohort Incidence"){ + return("Cohort Incidence") + } + + return('None') + }) # ============================= - # Table of cohorts + # MODULE SERVERS + # ============================= + # store what servers have been loaded and only load them the first time + # when the corresponding tab is loaded + previouslyLoaded <- shiny::reactiveVal(c()) + + # only render the tab when selected + shiny::observeEvent(currentTab(), { + # ============================= + # Cohort Comparison # ============================= - if(input$mainPanel == "Target Viewer"){ - if(!"Target Viewer" %in% previouslyLoaded()){ - characterizationTableServer( - id = 'descriptiveTableTab', + if(currentTab() == 'Cohort Comparison'){ + if(!"Cohort Comparison" %in% previouslyLoaded()){ + characterizationCohortComparisonServer( + id = 'cohortComparisonTab', connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + options = options, + parents = parents, + parentIndex = parentIndex, + subTargetId = subTargetId ) - previouslyLoaded(c(previouslyLoaded(), "Target Viewer")) + previouslyLoaded(c(previouslyLoaded(), "Cohort Comparison")) } } - - - # ============================= - # Aggregrate Features - # ============================= - if(input$mainPanel == "Outcome Stratified"){ - if(!"Outcome Stratified" %in% previouslyLoaded()){ - characterizationAggregateFeaturesServer( - id = 'aggregateFeaturesTab', + + # ============================= + # Database Comparison + # ============================= + if(currentTab() == "Database Comparison"){ + if(!"Database Comparison" %in% previouslyLoaded()){ + characterizationDatabaseComparisonServer( + id = 'databaseComparisonTab', connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + options = options, + parents = parents, + parentIndex = parentIndex, + subTargetId = subTargetId ) - previouslyLoaded(c(previouslyLoaded(), "Outcome Stratified")) + previouslyLoaded(c(previouslyLoaded(), "Database Comparison")) } } - + # ============================= - # Incidence + # Risk Factor # ============================= - if(input$mainPanel == "Incidence Rate"){ - if(!"Incidence Rate" %in% previouslyLoaded()){ - characterizationIncidenceServer( - id = 'incidenceTab', + if(currentTab() == "Risk Factor"){ + if(!"Risk Factor" %in% previouslyLoaded()){ + characterizationRiskFactorServer( + id = 'riskFactorTab', connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + targetId = subTargetId, + outcomeId = outcomeId ) - previouslyLoaded(c(previouslyLoaded(), "Incidence Rate")) + previouslyLoaded(c(previouslyLoaded(), "Risk Factor")) } } - - - # ============================= - # Time To Event - # ============================= - if(input$mainPanel == "Time To Event"){ - if(!"Time To Event" %in% previouslyLoaded()){ + + # ============================= + # Case Series + # ============================= + if(currentTab() == 'Case Series'){ + if(!"Case Series" %in% previouslyLoaded()){ + characterizationCaseSeriesServer( + id = 'caseSeriesTab', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = subTargetId, + outcomeId = outcomeId + ) + previouslyLoaded(c(previouslyLoaded(), "Case Series")) + } + } + + # ============================= + # Time-to-event + # ============================= + if(currentTab() == 'Time-to-event'){ + if(!"Time-to-event" %in% previouslyLoaded()){ characterizationTimeToEventServer( - id = 'timeToEventTab', + id = 'timeToEventTab', connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + targetId = subTargetId, + outcomeId = outcomeId ) - previouslyLoaded(c(previouslyLoaded(), "Time To Event")) + previouslyLoaded(c(previouslyLoaded(), "Time-to-event")) } } - - # ============================= - # Dechallenge Rechallenge - # ============================= - if(input$mainPanel == "Dechallenge Rechallenge"){ + + # ============================= + # Dechallenge Rechallenge + # ============================= + if(currentTab() == 'Dechallenge Rechallenge'){ if(!"Dechallenge Rechallenge" %in% previouslyLoaded()){ characterizationDechallengeRechallengeServer( - id = 'dechallengeRechallengeTab', + id = 'dechallengeRechallengeTab', connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + targetId = subTargetId, + outcomeId = outcomeId ) previouslyLoaded(c(previouslyLoaded(), "Dechallenge Rechallenge")) } } - }) # end observed input tab + + # ============================= + # Incidence + # ============================= + if(currentTab() == "Cohort Incidence"){ + if(!"Incidence Results" %in% previouslyLoaded()){ + characterizationIncidenceServer( + id = 'cohortIncidenceTab', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + #options = options, + parents = parents, + parentIndex = parentIndex, # reactive + outcomes = outcomes, # reactive + targetIds = subTargetId# reactive + ) + previouslyLoaded(c(previouslyLoaded(), "Incidence Results")) + } + } + }) + + } ) @@ -210,13 +544,21 @@ getCharacterizationTypes <- function( connection = conn, databaseSchema = resultDatabaseSettings$schema ) - + + #"Database Comparison" - TODO check multiple databases? + # check Targets if(sum(paste0( resultDatabaseSettings$cTablePrefix, c('covariates', 'covariate_ref', 'cohort_details', 'settings') ) %in% tbls) == 4){ - results <- c(results, "Target Viewer", "Outcome Stratified" ) + results <- rbind( + results, + c("Database Comparison",'Cohort Summary', 'cohortSummaryPanel'), + c("Cohort Comparison",'Cohort Summary', 'cohortSummaryPanel'), + c("Risk Factor",'Exposed Cases Summary', 'exposedCasesPanel'), + c("Case Series",'Exposed Cases Summary', 'exposedCasesPanel') + ) } # check dechallenge_rechallenge @@ -224,7 +566,10 @@ getCharacterizationTypes <- function( resultDatabaseSettings$cTablePrefix, 'dechallenge_rechallenge' ) %in% tbls){ - results <- c(results, "Dechallenge Rechallenge") + results <- rbind( + results, + c("Dechallenge Rechallenge",'Exposed Cases Summary', 'exposedCasesPanel') + ) } # check time_to_event @@ -232,7 +577,10 @@ getCharacterizationTypes <- function( resultDatabaseSettings$cTablePrefix, 'time_to_event' ) %in% tbls){ - results <- c(results, "Time To Event") + results <- rbind( + results, + c("Time-to-event",'Exposed Cases Summary', 'exposedCasesPanel') + ) } # check incidence @@ -240,8 +588,136 @@ getCharacterizationTypes <- function( resultDatabaseSettings$incidenceTablePrefix, 'incidence_summary' ) %in% tbls){ - results <- c(results, "Incidence Rate") + results <- rbind( + results, + c("Incidence Results",'Cohort Incidence', 'cohortIncidencePanel') + ) + } + + + + return(list( + mainPanel = unique(results[,2]), + subPanel = unique(results[,1]) + )) +} + +# TODO add tte and dechal as include options +characterizationGetOptions <- function( + connectionHandler, + resultDatabaseSettings, + includeAggregate, + includeIncidence + ){ + + # get cohorts + cg <- connectionHandler$queryDb( + sql = 'select * from @schema.@cg_table_prefixcohort_definition + ORDER BY cohort_name;', + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix + ) + +# TODO: CohortIncidence does not caputre specific T-O pairs, will need to implement +# if this function requires it. + TnOsSql = " +select distinct temp.*, c.cohort_name +from ( +{@include_aggregate} ? { +select distinct +target_cohort_id, +outcome_cohort_id +from @schema.@c_table_prefixcohort_details +where cohort_type = 'Cases' + +{@include_incidence} ? { +union +} +} + +{@include_incidence} ? { +select target_cohort_definition_id as target_cohort_id, outcome_cohort_definition_id as outcome_cohort_id + from @schema.@ci_table_prefixtarget_def, @ci_table_prefixoutcome_def +} + +) temp +inner join @schema.@cg_table_prefixcohort_definition c on temp.outcome_cohort_id = c.cohort_definition_id +;" + TnOs <- connectionHandler$queryDb( + sql = TnOsSql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + ci_table_prefix = resultDatabaseSettings$incidenceTablePrefix, + include_incidence = includeIncidence, + include_aggregate = includeAggregate + ) + # fix backwards compatability + if(!'isSubset' %in% colnames(cg)){ + cg$isSubset <- NA + } + if(!'subsetParent' %in% colnames(cg)){ + cg$subsetParent <- cg$cohortDefinitionId } + if(!'subsetDefinitionId' %in% colnames(cg)){ + cg$subsetDefinitionId <- cg$cohortDefinitionId + } + cg$subsetParent[is.na(cg$isSubset)] <- cg$cohortDefinitionId + cg$subsetDefinitionId[is.na(cg$isSubset)] <- cg$cohortDefinitionId + cg$isSubset[is.na(cg$isSubset)] <- 0 + + parents <- unique(cg$cohortDefinitionId[cg$isSubset == 0]) + results <- lapply(parents, function(id){ + list( + cohortName = cg$cohortName[cg$cohortDefinitionId == id], + cohortId = id, + children = lapply(cg$cohortDefinitionId[cg$subsetParent == id], function(sid){ + list( + subsetName = cg$cohortName[cg$cohortDefinitionId == sid], + subsetId = sid, + outcomeIds = unique(TnOs$outcomeCohortId[TnOs$targetCohortId == sid]), + outcomeNames = unique(TnOs$cohortName[TnOs$targetCohortId == sid]) + # add outcomes from case exposures + ) + } + ) + ) + }) return(results) + +} + +characterizationGetParents <- function(options){ + parentTs <- unlist(lapply(options, function(x) x$cohortId)) + names(parentTs) <- unlist(lapply(options, function(x) x$cohortName)) + + return(parentTs) +} + +characterizationGetChildren <- function(options, index){ + children <- unlist(lapply(options[[index]]$children, function(x) x$subsetId)) + names(children) <- unlist(lapply(options[[index]]$children, function(x) x$subsetName)) + + return(children) } + +characterizationGetOutcomes <- function(options, index){ + result <- unique( + do.call( + 'rbind', + lapply( + X = options[[index]]$children, + FUN = function(x) data.frame(ids = x$outcomeIds, names = x$outcomeNames) + ) + ) + ) + + outcomes <- result$ids + names(outcomes) <- result$names + + # sort the outcomes alphabetically + outcomes <- outcomes[order(names(outcomes))] + return(outcomes) +} + diff --git a/R/characterization-riskFactors.R b/R/characterization-riskFactors.R new file mode 100644 index 00000000..9a5db4f4 --- /dev/null +++ b/R/characterization-riskFactors.R @@ -0,0 +1,1004 @@ +# @file characterization-aggregateFeatures.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. + + + +characterizationRiskFactorViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::div( + + # module that does input selection for a single row DF + shiny::uiOutput(ns("inputs")), + + shiny::conditionalPanel( + condition = 'input.generate != 0', + ns = ns, + + inputSelectionDfViewer(id = ns('inputSelected'), title = 'Selected'), + + shinydashboard::box( + title = 'Counts', + width = "100%", + collapsible = T, + resultTableViewer(ns('countTable')) + ), + + shinydashboard::tabBox( + width = "100%", + # Title can include an icon + title = shiny::tagList(shiny::icon("gear"), "Risk Factors"), + + shiny::tabPanel("Binary Feature Table", + resultTableViewer(ns('binaryTable')) + ), + shiny::tabPanel("Continuous Feature Table", + resultTableViewer(ns('continuousTable')) + ) + ) + ) + ) + +} + + + +characterizationRiskFactorServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + targetId, #reactive + outcomeId #reactive +) { + shiny::moduleServer( + id, + function(input, output, session) { + + # get databases + options <- shiny::reactive({ + characterizationGetCaseSeriesOptions( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = targetId(), + outcomeId = outcomeId() + ) + }) + + output$inputs <- shiny::renderUI({ # need to make reactive? + + shiny::div( + shiny::selectInput( + inputId = session$ns('databaseId'), + label = 'Database: ', + choices = options()$databaseIds, + selected = options()$databaseIds[1], + multiple = F + ), + + shiny::selectInput( + inputId = session$ns('tarInd'), + label = 'Time-at-risk: ', + choices = options()$tarInds, + selected = options()$tarInds[1], + multiple = F + ), + + shiny::actionButton( + inputId = session$ns('generate'), + label = 'Generate' + ) + ) + + }) + + # save the selections + selected <- shiny::reactiveVal(value = NULL) + + shiny::observeEvent(input$generate, { + + selected( + data.frame( + database = names(options()$databaseIds)[which(input$databaseId == options()$databaseIds)], + time_at_risk = names(options()$tarInds)[which(input$tarInd == options()$tarInds)] + ) + ) + + inputSelectionDfServer( + id = 'inputSelected', + dataFrameRow = selected, + ncol = 1 + ) + + counts <- characterizationGetRiskFactorCounts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = targetId(), + outcomeId = outcomeId(), + databaseId = input$databaseId, + tar = options()$tarList[[which(options()$tarInds == input$tarInd)]] + ) + + countTableOutput <- resultTableServer( + id = "countTable", + df = counts, + details = data.frame( + target = options()$targetName, + outcome = options()$outcomeName, + Database = names(options()$databaseIds)[which(input$databaseId == options()$databaseIds)], + TimeAtRisk = options()$tarList[[which(options()$tarInds == input$tarInd)]], + Analysis = 'Counts - Risk Factor' + ), + downloadedFileName = 'risk_factor_counts', + colDefsInput = characteriationCountsColDefs( + elementId = session$ns('count-table-filter') + ), + addActions = NULL, + elementId = session$ns('count-table-filter') + ) + + allData <- characterizationGetRiskFactorData( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = targetId(), + outcomeId = outcomeId(), + databaseId = input$databaseId, + tar = options()$tarList[[which(options()$tarInds == input$tarInd)]] + ) + + binTableOutputs <- resultTableServer( + id = "binaryTable", + df = allData$binary, + details = data.frame( + target = options()$targetName, + outcome = options()$outcomeName, + Database = names(options()$databaseIds)[which(input$databaseId == options()$databaseIds)], + TimeAtRisk = options()$tarList[[which(options()$tarInds == input$tarInd)]], + Analysis = 'Exposed Cases Summary - Risk Factor' + ), + downloadedFileName = 'risk_factor_binary', + colDefsInput = characteriationRiskFactorColDefs( + elementId = session$ns('binary-table-filter') + ), # function below + addActions = NULL, + elementId = session$ns('binary-table-filter') + ) + + conTableOutputs <- resultTableServer( + id = "continuousTable", + df = allData$continuous, + colDefsInput = characteriationRiskFactorContColDefs( + elementId = session$ns('continuous-table-filter') + ), # function below + addActions = NULL, + elementId = session$ns('continuous-table-filter') + ) + + }) + + return(invisible(NULL)) + } + ) +} + + +characterizationGetRiskFactorCounts <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + outcomeId, + databaseId, + tar +){ + + sql <- "SELECT + cohort_type, + min_prior_observation, + outcome_washout_days, + row_count, + person_count + + from + @schema.@c_table_prefixcohort_counts + where database_id = '@database_id' + and target_cohort_id = @target_id + and outcome_cohort_id in (@outcome_id, 0) + and (risk_window_start = @risk_window_start OR risk_window_start is NULL) + and (risk_window_end = @risk_window_end OR risk_window_end is NULL) + and (start_anchor = '@start_anchor' OR start_anchor is NULL) + and (end_anchor = '@end_anchor' OR end_anchor is NULL) + and cohort_type in ('Cases','Exclude','Target') + ;" + + counts <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + database_id = databaseId, + target_id = targetId, + outcome_id = outcomeId, + risk_window_start = tar$riskWindowStart, + start_anchor = tar$startAnchor, + risk_window_end = tar$riskWindowEnd, + end_anchor = tar$endAnchor + ) + + return(counts) + +} + +characterizationGetRiskFactorData <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + outcomeId, + databaseId, + tar +){ + + shiny::withProgress(message = 'Getting risk factor data', value = 0, { + shiny::incProgress(1/4, detail = paste("Extracting ids")) + + sql <- "SELECT distinct setting_id + from + @schema.@c_table_prefixsettings + where database_id = '@database_id' + and risk_window_start = @risk_window_start + and risk_window_end = @risk_window_end + and start_anchor = '@start_anchor' + and end_anchor = '@end_anchor' + + union + + SELECT distinct setting_id + from + @schema.@c_table_prefixsettings + where database_id = '@database_id' + and risk_window_start is NULL + ;" + + ids <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + database_id = databaseId, + risk_window_start = tar$riskWindowStart, + start_anchor = tar$startAnchor, + risk_window_end = tar$riskWindowEnd, + end_anchor = tar$endAnchor + ) + + shiny::incProgress(2/4, detail = paste("Extracting binary")) + + sql <- "SELECT distinct cov.cohort_type, cr.covariate_name, + s.min_prior_observation, s.outcome_washout_days, + cov.covariate_id, cov.sum_value, cov.average_value + from + @schema.@c_table_prefixcovariates cov + inner join @schema.@c_table_prefixcovariate_ref cr + on cov.setting_id = cr.setting_id and + cov.database_id = cr.database_id and + cov.covariate_id = cr.covariate_id + + inner join @schema.@c_table_prefixsettings s + on cov.setting_id = s.setting_id + and cov.database_id = s.database_id + + where + cov.target_cohort_id = @target_id + and cov.outcome_cohort_id in (0,@outcome_id) + and cov.cohort_type in ('Target','Cases', 'Exclude') + and cov.database_id = '@database_id' + and cov.setting_id in (@setting_ids) + and cr.analysis_id not in (109, 110, 217, 218, 305, 417, 418, 505, 605, 713, 805, 926, 927) + ;" + + binary <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + target_id = targetId, + outcome_id = outcomeId, + database_id = databaseId, + setting_ids = paste0(ids$settingId, collapse=',') + ) + message(paste0('Extracted ',nrow(binary),' binary RF rows')) + + # now process into table + binary <- riskFactorTable( + data = binary + ) + + shiny::incProgress(3/4, detail = paste("Extracting continuous")) + + sql <- "SELECT distinct cov.cohort_type, cr.covariate_name, + s.min_prior_observation, s.outcome_washout_days,cov.covariate_id, + cov.count_value, cov.min_value, cov.max_value, cov.average_value, + cov.standard_deviation, cov.median_value, cov.p_10_value, + cov.p_25_value, cov.p_75_value, cov.p_90_value + from + @schema.@c_table_prefixcovariates_continuous cov + inner join @schema.@c_table_prefixcovariate_ref cr + on cov.setting_id = cr.setting_id and + cov.database_id = cr.database_id and + cov.covariate_id = cr.covariate_id + + inner join @schema.@c_table_prefixsettings s + on cov.setting_id = s.setting_id + and cov.database_id = s.database_id + + where cov.target_cohort_id = @target_id + and cov.outcome_cohort_id in (0,@outcome_id) + and cov.cohort_type in ('Target','Cases', 'Exclude') + and cov.database_id = '@database_id' + and cov.setting_id in (@setting_ids) + and cr.analysis_id not in (109, 110, 217, 218, 305, 417, 418, 505, 605, 713, 805, 926, 927) + ;" + + # TODO - how to remove prior outcomes?? + continuous <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + target_id = targetId, + outcome_id = outcomeId, + database_id = databaseId, + setting_ids = paste0(ids$settingId, collapse=',') + ) + + message(paste0('Extracted ',nrow(binary),' continuous RF rows')) + + continuous <- riskFactorContinuousTable( + data = continuous + ) + + shiny::incProgress(4/4, detail = paste("Done")) + + }) + + return( + list( + binary = binary, + continuous = continuous + ) + ) +} + + +# now process into table +riskFactorTable <- function( + data +){ + + if(is.null(data)){ + return(data) + } + + data <- unique(data) + if(nrow(data) == 0){ + return(data) + } + + outcomeWashoutDays <- unique(data$outcomeWashoutDays) + outcomeWashoutDays <- outcomeWashoutDays[!is.na(outcomeWashoutDays)] + if(length(outcomeWashoutDays) == 0){ + shiny::showNotification('No cases') + data <- data %>% + dplyr::filter(.data$cohortType == 'Target') %>% + dplyr::select(-"cohortType", -"outcomeWashoutDays") %>% + dplyr::mutate( + nonCaseSumValue = .data$sumValue, + nonCaseAverageValue = .data$averageValue + ) %>% + dplyr::select( + "covariateId","covariateName", + 'minPriorObservation', + "nonCaseSumValue","nonCaseAverageValue" + ) + return(data) + } + + targetData <- data %>% + dplyr::filter(.data$cohortType == 'Target') %>% + dplyr::mutate( + sumValue_Target = .data$sumValue, + averageValue_Target = .data$averageValue + ) %>% + dplyr::select( + -"cohortType", + -"outcomeWashoutDays", + -"sumValue", + -"averageValue" + ) + + targetN <- targetData %>% + dplyr::mutate(N_Target = .data$sumValue_Target/.data$averageValue_Target) %>% + dplyr::select('minPriorObservation', 'N_Target') %>% + dplyr::group_by(.data$minPriorObservation) %>% + dplyr::summarise(N_Target = round(max(.data$N_Target, na.rm = T))) + + completeData <- c() + for(outcomeWashoutDay in outcomeWashoutDays){ + + # add dummy Cases and Exclude to data so columns always exist + data <- rbind(data, data.frame( + cohortType = c('Cases','Exclude'), + covariateName = rep('NA', 2), + minPriorObservation = rep(unique(data$minPriorObservation)[1], 2), + outcomeWashoutDays = rep(outcomeWashoutDay, 2), + covariateId = rep(-1, 2), + sumValue = rep(0,2), + averageValue = rep(0,2) + )[colnames(data)]) + + #filter data to outcomeWashoutDays + otherData <- data %>% + dplyr::filter( + .data$cohortType != 'Target' & + .data$outcomeWashoutDays == !!outcomeWashoutDay + ) %>% + tidyr::pivot_wider( + id_cols = c( + "minPriorObservation", + "covariateId", + "covariateName" + ), + names_from = "cohortType", + values_from = c("sumValue","averageValue") + ) + + otherN <- otherData %>% + dplyr::mutate( + N_Cases = .data$sumValue_Cases/.data$averageValue_Cases, + N_Exclude = .data$sumValue_Exclude/.data$averageValue_Exclude + ) %>% + dplyr::group_by(.data$minPriorObservation) %>% + dplyr::summarise( + N_Cases = max(.data$N_Cases, na.rm = T), + N_Exclude = max(.data$N_Exclude, na.rm = T) + ) + + if(length(is.infinite(otherN$N_Cases))>0){ + otherN$N_Cases[is.infinite(otherN$N_Cases)] <- 0 + } + if(length(is.infinite(otherN$N_Exclude))>0){ + otherN$N_Exclude[is.infinite(otherN$N_Exclude)] <- 0 + } + + # get all counts + counts <- targetN %>% + dplyr::left_join(otherN, by = c('minPriorObservation')) + + # get final data for minPriorObs + finalData <- targetData %>% + dplyr::left_join( + otherData, + by = c( + "minPriorObservation", + "covariateId", + "covariateName" + ) + ) %>% + dplyr::inner_join( + counts , + by = c( + "minPriorObservation" + ) + ) + if(length(is.na(finalData$sumValue_Cases))>0){ + finalData$sumValue_Cases[is.na(finalData$sumValue_Cases)] <- 0 + } + if(length(is.na(finalData$sumValue_Target))>0){ + finalData$sumValue_Target[is.na(finalData$sumValue_Target)] <- 0 + } + if(length(is.na(finalData$sumValue_Exclude))>0){ + finalData$sumValue_Exclude[is.na(finalData$sumValue_Exclude)] <- 0 + } + if(length(is.na(finalData$N_Target))>0){ + finalData$N_Target[is.na(finalData$N_Target)] <- 0 + } + if(length(is.na(finalData$N_Cases))>0){ + finalData$N_Cases[is.na(finalData$N_Cases)] <- 0 + } + if(length(is.na(finalData$N_Exclude))>0){ + finalData$N_Exclude[is.na(finalData$N_Exclude)] <- 0 + } + if(length(is.na(finalData$averageValue_Cases))>0){ + finalData$averageValue_Cases[is.na(finalData$averageValue_Cases)] <- 0 + } + + # removing censored counts as dont want to add due to negative + if(length(finalData$N_Exclude < 0) > 0 ){ + finalData$N_Exclude[finalData$N_Exclude < 0] <- 0 + } + finalData$N_Cases_exclude <- finalData$N_Cases + if(length(finalData$N_Cases_exclude < 0) > 0 ){ + finalData$N_Cases_exclude[finalData$N_Cases_exclude < 0] <- 0 + } + if(length(finalData$sumValue_Exclude < 0) > 0 ){ + finalData$sumValue_Exclude[finalData$sumValue_Exclude < 0] <- 0 + } + finalData$sumValue_Cases_exclude <- finalData$sumValue_Cases + if(length(finalData$sumValue_Cases_exclude < 0) > 0 ){ + finalData$sumValue_Cases_exclude[finalData$sumValue_Cases_exclude < 0] <- 0 + } + + finalData <- finalData %>% + dplyr::mutate( + nonCaseN = round(.data$N_Target-.data$N_Exclude-.data$N_Cases_exclude), + caseN = .data$N_Cases, + N = .data$N_Target, + nonCaseSumValue = .data$sumValue_Target-.data$sumValue_Exclude-.data$sumValue_Cases_exclude, + caseSumValue = .data$sumValue_Cases, + nonCaseAverageValue = (.data$sumValue_Target-.data$sumValue_Exclude-.data$sumValue_Cases_exclude)/(.data$N_Target-.data$N_Exclude-.data$N_Cases_exclude), + caseAverageValue = .data$averageValue_Cases + ) %>% + dplyr::select( + "covariateId", "covariateName", "minPriorObservation", + "caseSumValue","caseAverageValue", + "nonCaseSumValue","nonCaseAverageValue", + "nonCaseN", "caseN", "N" + ) %>% + dplyr::mutate( + meanDiff = .data$caseAverageValue - .data$nonCaseAverageValue, + std1 = ifelse(.data$caseN == 0, 0 ,sqrt(((1-.data$caseAverageValue)^2*.data$caseSumValue + (-.data$caseAverageValue)^2*(.data$caseN - .data$caseSumValue))/.data$caseN)), + std2 = ifelse(.data$nonCaseN == 0, 0, sqrt(((1-.data$nonCaseAverageValue)^2*.data$nonCaseSumValue + (-.data$nonCaseAverageValue)^2*(.data$nonCaseN - .data$nonCaseSumValue))/.data$nonCaseN)) + ) %>% + dplyr::mutate( + SMD = .data$meanDiff/sqrt((.data$std1^2 + .data$std2^2)/2), + absSMD = abs(.data$meanDiff/sqrt((.data$std1^2 + .data$std2^2)/2)) + ) %>% + dplyr::select(-"meanDiff",-"std1", -"std2", -"N",-"caseN", -"nonCaseN") + + + # add outcomewashout back here + finalData <- finalData %>% + dplyr::mutate( + outcomeWashoutDays = !!outcomeWashoutDay + ) %>% + dplyr::relocate("outcomeWashoutDays", + .after = "minPriorObservation") + + completeData <- rbind(finalData, completeData) + + } # end outcomeWashoutDays loop + + if(nrow(completeData) == 0){ + completeData <- data %>% + dplyr::filter(.data$cohortType == 'Target') %>% + dplyr::select(-"cohortType", -"outcomeWashoutDays") %>% + dplyr::mutate( + nonCaseSumValue = .data$sumValue, + nonCaseAverageValue = .data$averageValue + ) %>% + dplyr::select( + "covariateId","covariateName", + 'minPriorObservation', + "nonCaseSumValue","nonCaseAverageValue" + ) + } + + return(unique(completeData)) +} + + +riskFactorContinuousTable <- function( + data +){ + + + data <- unique(data) + + caseData <- data %>% + dplyr::filter(.data$cohortType == 'Cases') %>% + dplyr::select(-"cohortType") + + allData <- data %>% + dplyr::filter(.data$cohortType == 'Target') %>% + dplyr::select(-"cohortType", -"outcomeWashoutDays") + + if(nrow(caseData) > 0){ + + caseData <- caseData %>% + dplyr::mutate( + caseCountValue = .data$countValue, + caseAverageValue = .data$averageValue, + caseStandardDeviation = .data$standardDeviation, + caseMedianValue = .data$medianValue, + caseMinValue = .data$minValue, + caseMaxValue = .data$maxValue, + caseP10Value = .data$p10Value, + caseP25Value = .data$p25Value, + caseP75Value = .data$p75Value, + caseP90Value = .data$p90Value + ) %>% + dplyr::select("covariateId","covariateName", + 'minPriorObservation', 'outcomeWashoutDays', + "caseCountValue","caseAverageValue", + "caseStandardDeviation", "caseMedianValue", "caseP10Value", "caseP25Value", + "caseP75Value", "caseP90Value", "caseMaxValue", "caseMinValue") + + # join with cases + allData <- allData %>% + dplyr::full_join(caseData, by = c('covariateId', 'covariateName', 'minPriorObservation')) %>% + dplyr::mutate( + targetCountValue = .data$countValue, + targetAverageValue = .data$averageValue, + targetStandardDeviation = .data$standardDeviation, + targetMedianValue = .data$medianValue, + targetMinValue = .data$minValue, + targetMaxValue = .data$maxValue, + targetP10Value = .data$p10Value, + targetP25Value = .data$p25Value, + targetP75Value = .data$p75Value, + targetP90Value = .data$p90Value + ) %>% + dplyr::select("covariateId","covariateName", + 'minPriorObservation', 'outcomeWashoutDays', + "caseCountValue","caseAverageValue", + "caseStandardDeviation", "caseMedianValue", "caseP10Value", "caseP25Value", + "caseP75Value", "caseP90Value", "caseMaxValue", "caseMinValue", + + "targetCountValue","targetAverageValue", + "targetStandardDeviation", "targetMedianValue", "targetP10Value", "targetP25Value", + "targetP75Value", "targetP90Value","targetMaxValue", "targetMinValue",) + + # add abs smd + allData <- allData %>% + dplyr::mutate( + SMD = (.data$caseAverageValue - .data$targetAverageValue)/sqrt((.data$caseStandardDeviation^2 + .data$targetStandardDeviation^2)/2), + absSMD = abs((.data$caseAverageValue - .data$targetAverageValue)/sqrt((.data$caseStandardDeviation^2 + .data$targetStandardDeviation^2)/2)), + targetBoxPlot = 0, + caseBoxPlot = 0 + ) + + + } + + + return(unique(allData)) + +} + +characteriationCountsColDefs <- function( + elementId +){ + result <- list( + cohortType = reactable::colDef( + header = withTooltip("Cohort Type", + "The target popualtion, exclusions from target or cases"), + filterable = T + ), + + rowCount = reactable::colDef( + header = withTooltip("# rows", + "Number of exposures in the cohort (people can be in more than once)"), + cell = function(value) { + if(is.null(value)){return('< min threshold')} + if(is.na(value)){return('< min threshold')} + if (value >= 0) value else paste0('< ', abs(value)) + } + ), + personCount = reactable::colDef( + header = withTooltip("# persons", + "Number of distinct people in the cohort"), + cell = function(value) { + if(is.null(value)){return('< min threshold')} + if(is.na(value)){return('< min threshold')} + if (value >= 0) value else paste0('< ', abs(value)) + } + ) + ) + return(result) +} + +characteriationRiskFactorColDefs <- function( + elementId + ){ + result <- list( + covariateId = reactable::colDef( + show = F + ), + covariateName = reactable::colDef( + header = withTooltip("Covariate Name", + "Name of the covariate"), + filterable = T, + minWidth = 300 + ), + minPriorObservation = reactable::colDef( + header = withTooltip("Min Prior Observation", + "Minimum prior observation time (days)"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + outcomeWashoutDays = reactable::colDef( + header = withTooltip("Outcome Washout Days", + "Number of days for the outcome washout"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + nonCaseSumValue = reactable::colDef( + header = withTooltip("# Non-cases with Feature Before Exposure", + "Number of non-cases for the outcome with the feature before exposure"), + filterable = T, + format = reactable::colFormat( + percent = F, + separators = TRUE + ), + cell = function(value) { + if(is.null(value)){return('< min threshold')} + if(is.na(value)){return('< min threshold')} + if (value >= 0) value else paste0('< ', abs(value)) + } + ), + caseSumValue = reactable::colDef( + header = withTooltip("# Cases with Feature Before Exposure", + "Number of cases for the outcome with the feature before exposure"), + filterable = T, + format = reactable::colFormat( + separators = TRUE, + percent = F + ), + cell = function(value) { + if(is.null(value)){return('< min threshold')} + if(is.na(value)){return('< min threshold')} + if (value >= 0) value else paste0('< ', abs(value)) + } + ), + nonCaseAverageValue = reactable::colDef( + header = withTooltip("% Non-cases with Feature Before Exposure", + "Percent of non-cases for the outcome with the feature before exposure"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = T) + ), + caseAverageValue = reactable::colDef( + header = withTooltip("% Cases with Feature Before Exposure", + "Percent of Cases for the outcome with the feature before exposure"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = T) + ), + + SMD = reactable::colDef( + header = withTooltip("SMD", + "Standardized mean difference"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + + absSMD = reactable::colDef( + header = withTooltip("absSMD", + "Absolute value of standardized mean difference"), + format = reactable::colFormat(digits = 2, percent = F), + filterable = TRUE, + filterMethod = reactable::JS("function(rows, columnId, filterValue) { + return rows.filter(function(row) { + return row.values[columnId] >= filterValue + }) + }"), + filterInput = function(values, name) { + oninput <- sprintf("Reactable.setFilter('%s', '%s', this.value)", elementId, name) + shiny::tags$input( + type = "range", + min = floor(min(values, na.rm = T)), + max = ceiling(max(values, na.rm = T)), + value = floor(min(values, na.rm = T)), + oninput = oninput, + onchange = oninput, # For IE11 support + "aria-label" = sprintf("Filter by minimum %s", name) + ) + } + ) + ) + return(result) +} + + + +characteriationRiskFactorContColDefs <- function( + elementId + ){ + result <- list( + covariateName = reactable::colDef( + header = withTooltip("Covariate Name", + "Name of the covariate"), + filterable = T, + minWidth = 300 + ), + covariateId = reactable::colDef( + show = F + ), + minPriorObservation = reactable::colDef( + header = withTooltip("Min Prior Observation", + "Minimum prior observation time (days)"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + outcomeWashoutDays = reactable::colDef( + header = withTooltip("Outcome Washout Days", + "Number of days for the outcome washout"), + filterable = T, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + countValue = reactable::colDef( + header = withTooltip("# with Feature", + "Number with feature"), + filterable = T + , + format = reactable::colFormat( + percent = F, + separators = TRUE + ), + cell = function(value) { + if(is.null(value)){return('< min threshold')} + if(is.na(value)){return('< min threshold')} + if (value >=0) value else paste0('< ', abs(value)) + } + ), + averageValue = reactable::colDef( + header = withTooltip("Mean Feature Value", + "Mean value of the feature in the population"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + standardDeviation = reactable::colDef( + header = withTooltip("SD Feature Value", + "Standard deviation of the feature value in the population"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + medianValue = reactable::colDef( + header = withTooltip("Median Feature Value", + "Median of the feature value"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + p10Value = reactable::colDef( + header = withTooltip("10th %ile Feature Value", + "10th percentile of the feature value"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + p25Value = reactable::colDef( + header = withTooltip("25th %tile Feature Value", + "25th percentile of the feature value"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + p75Value = reactable::colDef( + header = withTooltip("75th %tile Feature Value", + "75th percentile of the feature value"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + p90Value = reactable::colDef( + header = withTooltip("90th %tile Feature Value", + "90th percentile of the feature value"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + maxValue = reactable::colDef( + header = withTooltip("Max Feature Value", + "Maximum of the feature value"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + minValue = reactable::colDef( + header = withTooltip("Min Feature Value", + "Minimum of the feature value"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + boxPlot = reactable::colDef( + show = F + ), + #targetBoxPlot = reactable::colDef(cell = function(value, index) { + # ggplot2::ggplot() + + # ggplot2::geom_boxplot( + # ggplot2::aes( + # x = 1, + # ymin = data$targetMinValue[index], + # lower = data$targetP10Value[index], + # middle = data$targetMedianValue[index], + # upper = data$targetP90Value[index], + # ymax = data$targetMaxValue[index] + # ), + # stat = "identity" + # ) + #}), + #caseBoxPlot = reactable::colDef(cell = function(value, index) { + # sparkline(vcs_boxp_data$em_red_per_th[[index]], type = "box") + # }), + #caseBoxPlot = reactable::colDef(cell = function(value, index) { + # sparkline::sparkline(vcs_boxp_data$em_red_per_th[[index]], type = "box") + # }), + + # low_outlier, low_whisker, q1, median, q3, high_whisker, high_outlier + #sparkline::spk_chr(c(data$targetMinValue[index], data$targetP10Value[index], data$targetP25Value[index], data$targetMedianValue[index], 3, 6, 6), type="box", raw = TRUE, width = 200) + + SMD = reactable::colDef( + header = withTooltip("SMD", + "Standardized mean difference"), + filterable = T, + format = reactable::colFormat(digits = 2, percent = F) + ), + absSMD = reactable::colDef( + header = withTooltip("absSMD", + "Absolute value of the standardized mean difference"), + format = reactable::colFormat(digits = 2, percent = F), + filterable = TRUE, + filterMethod = reactable::JS("function(rows, columnId, filterValue) { + return rows.filter(function(row) { + return row.values[columnId] >= filterValue + }) + }"), + filterInput = function(values, name) { + oninput <- sprintf("Reactable.setFilter('%s', '%s', this.value)", elementId, name) + shiny::tags$input( + type = "range", + min = floor(min(values, na.rm = T)), + max = ceiling(max(values, na.rm = T)), + value = floor(min(values, na.rm = T)), + oninput = oninput, + onchange = oninput, # For IE11 support + "aria-label" = sprintf("Filter by minimum %s", name) + ) + } + ) + ) + return(result) +} + diff --git a/R/characterization-timeToEvent.R b/R/characterization-timeToEvent.R index 1c6c7fb8..abfb322b 100644 --- a/R/characterization-timeToEvent.R +++ b/R/characterization-timeToEvent.R @@ -17,161 +17,207 @@ # limitations under the License. -#' The module viewer for exploring time to event results -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the characterization time to event module -#' -#' @export characterizationTimeToEventViewer <- function(id) { ns <- shiny::NS(id) shiny::div( - - # input component module - inputSelectionViewer(id = ns('input-selection')), - - shiny::conditionalPanel( - condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection")), + shiny::tabsetPanel( + type = 'pills', + id = ns('tteMainPanel'), + shiny::tabPanel( + title = "Time-to-event Plots", + shinydashboard::box( width = "100%", - title = shiny::tagList(shiny::icon("gear"), "Results"), + title = "", - shiny::fluidRow( - shiny::column( - width = 2, - shiny::uiOutput(ns('timeToEventPlotInputs')) - ), - shiny::column( - width = 10, - shinycssloaders::withSpinner( - shiny::plotOutput(ns('timeToEvent')) - ) + shiny::uiOutput(ns('timeToEventPlotInputs')), + shinycssloaders::withSpinner( + shiny::plotOutput(ns('timeToEvent')) ) ) + ), + + shiny::tabPanel( + title = "Time-to-event Table", + + shinydashboard::box( + status = 'info', + width = '100%', + solidHeader = TRUE, + resultTableViewer(ns('tableResults')) + ) ) ) - - ) } -#' The module server for exploring time to event results -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the prediction result database -#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix -#' -#' @return -#' The server to the prediction time to event module -#' -#' @export characterizationTimeToEventServer <- function( id, connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + targetId, + outcomeId ) { shiny::moduleServer( id, function(input, output, session) { - # get the possible target ids - bothIds <- timeToEventGetIds( - connectionHandler, - resultDatabaseSettings - ) - - - # input selection component - inputSelected <- inputSelectionServer( - id = "input-selection", - inputSettingList = list( - createInputSetting( - rowNumber = 1, - columnWidth = 6, - varName = 'targetId', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Target: ', - choices = bothIds$targetIds, - #choicesOpt = list(style = rep_len("color: black;", 999)), - selected = bothIds$targetIds[1], - 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 = 'outcomeId', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Outcome: ', - choices = bothIds$outcomeIds, - #choicesOpt = list(style = rep_len("color: black;", 999)), - selected = bothIds$outcomeIds[1], - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) + options <- shiny::reactive({ + characterizationGetCaseSeriesOptions( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = targetId(), + outcomeId = outcomeId() ) - ) + }) allData <- shiny::reactive({ getTimeToEventData( - targetId = inputSelected()$targetId, - outcomeId = inputSelected()$outcomeId, + targetId = targetId(), + outcomeId = outcomeId(), connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings - ) + ) %>% + dplyr::mutate(targetName = options()$targetName, + outcomeName = options()$outcomeName) %>% + dplyr::relocate("databaseName", .before = "databaseId") %>% + dplyr::relocate("targetName", .after = "databaseName") %>% + dplyr::relocate("outcomeName", .after = "targetName") }) + + + characterizationTimeToEventColDefs <- function(){ + result <- list( + databaseName = reactable::colDef( + header = withTooltip("Database", + "Name of the database"), + filterable = T + ), + databaseId = reactable::colDef( + header = withTooltip("Database ID", + "Unique ID of the database"), + filterable = T, + show = F + ), + targetCohortDefinitionId = reactable::colDef( + header = withTooltip("Target ID", + "Unique ID of the target cohort"), + filterable = T, + show = F + ), + targetName = reactable::colDef( + header = withTooltip("Target Name", + "Name of the target cohort"), + filterable = T + ), + outcomeCohortDefinitionId = reactable::colDef( + header = withTooltip("Outcome ID", + "Unique ID of the outcome cohort"), + filterable = T, + show = F + ), + outcomeName = reactable::colDef( + header = withTooltip("Outcome Name", + "Name of the outcome cohort"), + filterable = T + ), + outcomeType = reactable::colDef( + header = withTooltip("Outcome Type", + "Type of the outcome, either first or subsequent occurrence"), + filterable = T + ), + targetOutcomeType = reactable::colDef( + header = withTooltip("Target-Outcome Type", + "The timing of the event relative to the target era"), + filterable = T + ), + timeToEvent = reactable::colDef( + header = withTooltip("Time (in days) To Event", + "The time in days relative to target index until the event occurred"), + filterable = T + ), + numEvents = reactable::colDef( + header = withTooltip("# of Events", + "The number of events that occurred"), + filterable = T, + cell = function(value) { + # Add < if cencored + if (value < 0 ) paste("<", abs(value)) else value + } + ), + timeScale = reactable::colDef( + header = withTooltip("Time Scale", + "The time scale in which the events occurred"), + filterable = T + ) + ) + return(result) + } + + tableOutputs <- resultTableServer( + id = "tableResults", + df = allData, + details = data.frame( + target = options()$targetName, + outcome = options()$outcomeName, + Analysis = 'Exposed Cases Summary - Time-to-event' + ), + downloadedFileName = 'time_to_event', + colDefsInput = characterizationTimeToEventColDefs() + ) output$timeToEventPlotInputs <- shiny::renderUI({ shiny::fluidPage( shiny::fluidRow( - shiny::checkboxGroupInput( - inputId = session$ns("databases"), + shiny::selectInput( + inputId = session$ns("databases"), label = "Databases:", - choiceNames = unique(allData()$databaseName), - choiceValues = unique(allData()$databaseName), + multiple = T, + choices = unique(allData()$databaseName), selected = unique(allData()$databaseName) - ), - shiny::checkboxGroupInput( - inputId = session$ns("times"), - label = "Timespan:", - choiceNames = unique(allData()$timeScale), - choiceValues = unique(allData()$timeScale), - selected = unique(allData()$timeScale) + ), + + shiny::fluidRow( + shiny::column( + width = 3, + shiny::selectInput( + inputId = session$ns("times"), + label = "Timespan:", + multiple = T, + choices = unique(allData()$timeScale), + selected = unique(allData()$timeScale) + ) + ), + + shiny::column( + width = 3, + shiny::selectInput( + inputId = session$ns("outcomeTypes"), + label = "Outcome occurrence type:", + multiple = T, + choices = unique(allData()$outcomeType), + selected = unique(allData()$outcomeType) + ) + ), + + shiny::column( + width = 6, + shiny::selectInput( + inputId = session$ns("targetOutcomeTypes"), + label = "Timing of outcome:", + multiple = T, + choices = unique(allData()$targetOutcomeType), + selected = unique(allData()$targetOutcomeType) + ) + ) ) + ) ) } @@ -181,7 +227,9 @@ characterizationTimeToEventServer <- function( plotTimeToEvent( timeToEventData = allData, # reactive databases = input$databases, - times = input$times + times = input$times, + outcomeTypes = input$outcomeTypes, + targetOutcomeTypes = input$targetOutcomeTypes ) ) @@ -192,61 +240,6 @@ characterizationTimeToEventServer <- function( ) } -timeToEventGetIds <- function( - connectionHandler, - resultDatabaseSettings -){ - - shiny::withProgress(message = 'Getting time to event T and O ids', value = 0, { - - sql <- "SELECT DISTINCT - t.COHORT_NAME as target, TARGET_COHORT_DEFINITION_ID, - o.COHORT_NAME as outcome, OUTCOME_COHORT_DEFINITION_ID - FROM @schema.@c_table_prefixTIME_TO_EVENT tte - inner join @schema.@cg_table_prefixCOHORT_DEFINITION t - on tte.TARGET_COHORT_DEFINITION_ID = t.COHORT_DEFINITION_ID - inner join @schema.@cg_table_prefixCOHORT_DEFINITION o - on tte.OUTCOME_COHORT_DEFINITION_ID = o.COHORT_DEFINITION_ID - ;" - - - shiny::incProgress(1/4, detail = paste("Fetching ids")) - - bothIds <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix - ) - - shiny::incProgress(3/4, detail = paste("Processing ids")) - - targetUnique <- bothIds %>% - dplyr::select(c("targetCohortDefinitionId", "target")) %>% - dplyr::distinct() - - targetIds <- targetUnique$targetCohortDefinitionId - names(targetIds) <- targetUnique$target - - outcomeUnique <- bothIds %>% - dplyr::select(c("outcomeCohortDefinitionId", "outcome")) %>% - dplyr::distinct() - - outcomeIds <- outcomeUnique$outcomeCohortDefinitionId - names(outcomeIds) <- outcomeUnique$outcome - - shiny::incProgress(4/4, detail = paste("Finished")) - - }) - - return( - list( - targetIds = targetIds, - outcomeIds = outcomeIds - ) - ) -} - # pulls all data for a target and outcome getTimeToEventData <- function( targetId, @@ -282,13 +275,17 @@ getTimeToEventData <- function( }) + #write.csv(data,'/Users/jreps/Documents/tte_data.csv') + return(data) } plotTimeToEvent <- function( timeToEventData, databases, - times + times, + outcomeTypes, + targetOutcomeTypes ){ if(is.null(timeToEventData())){ @@ -298,14 +295,31 @@ plotTimeToEvent <- function( timeToEventData <- timeToEventData() %>% dplyr::filter(.data$databaseName %in% databases) - if(is.null(timeToEventData)){ + if(nrow(timeToEventData) == 0){ + shiny::showNotification('No results for selected databases') return(NULL) } timeToEventData <- timeToEventData %>% dplyr::filter(.data$timeScale %in% times) - if(is.null(timeToEventData)){ + if(nrow(timeToEventData) == 0){ + shiny::showNotification('No results for selected databases and times') + return(NULL) + } + + # remove censored data + timeToEventData <- timeToEventData %>% + dplyr::filter( + .data$outcomeType %in% outcomeTypes & + .data$targetOutcomeType %in% targetOutcomeTypes & + .data$numEvents > 0 + ) + + # TODO plot censored as black? + + if(nrow(timeToEventData) == 0){ + shiny::showNotification('No results for selection') return(NULL) } @@ -316,7 +330,10 @@ plotTimeToEvent <- function( shiny::incProgress(1/2, detail = paste("Generating plot")) plot <- ggplot2::ggplot( - data = timeToEventData %>% dplyr::mutate(fillGroup = paste0(.data$outcomeType, '-', .data$targetOutcomeType)), + data = timeToEventData %>% + dplyr::mutate( + fillGroup = paste0(.data$outcomeType, '-', .data$targetOutcomeType) + ), ggplot2::aes( x = .data$timeToEvent, y = .data$numEvents, @@ -325,21 +342,14 @@ plotTimeToEvent <- function( ) ) + ggplot2::geom_bar( - #position="stacked", stat = "identity" ) + - #ggplot2::geom_text( - # ggplot2::aes( - # label = .data$numEvents - # ), - # vjust = 1.6, - # color = "white", - # size = 3.5 - # ) + ggplot2::facet_wrap(ncol = nDatabases , .data$timeScale ~ .data$databaseName , scales = 'free' ) + - ggplot2::theme_minimal() + ggplot2::theme_minimal() + + ggplot2::guides(fill=ggplot2::guide_legend(title="Outcome Type")) + + ggplot2::labs(y= "# of Events", x = "Time (days) to Event") shiny::incProgress(2/2, detail = paste("Finished")) diff --git a/R/cohort-diagnostics-characterization.R b/R/cohort-diagnostics-characterization.R index 02a88887..880eec4d 100644 --- a/R/cohort-diagnostics-characterization.R +++ b/R/cohort-diagnostics-characterization.R @@ -19,6 +19,7 @@ #' Use for customizing UI #' #' @param id Namespace Id - use namespaced id ns("characterization") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export cohortDiagCharacterizationView <- function(id) { ns <- shiny::NS(id) @@ -419,7 +420,7 @@ prepareTable1 <- function(covariates, "characteristic", "valueCount" ) %>% - dplyr::rename("count" = "valueCount") %>% + dplyr::rename(count = "valueCount") %>% dplyr::inner_join(cohort %>% dplyr::select( "cohortId", @@ -739,7 +740,7 @@ cohortDiagCharacterizationModule <- function( "covariateName", "mean" ) %>% - dplyr::rename("sumValue" = "mean") + dplyr::rename(sumValue = "mean") table <- data %>% diff --git a/R/cohort-diagnostics-cohort-overlap.R b/R/cohort-diagnostics-cohort-overlap.R index 016c5556..0d376642 100644 --- a/R/cohort-diagnostics-cohort-overlap.R +++ b/R/cohort-diagnostics-cohort-overlap.R @@ -172,6 +172,7 @@ plotCohortOverlap <- function(data, #' Use for customizing UI #' #' @param id Namespace Id - use namespaced id ns("cohortOverlap") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export cohortOverlapView <- function(id) { ns <- shiny::NS(id) @@ -358,7 +359,7 @@ getResultsCohortOverlap <- function(dataSource, dplyr::inner_join( cohortCounts %>% dplyr::select(-"cohortEntries") %>% - dplyr::rename("targetCohortSubjects" = "cohortSubjects"), + dplyr::rename(targetCohortSubjects = "cohortSubjects"), by = c("databaseId", "cohortId") ) %>% dplyr::mutate(tOnlySubjects = .data$targetCohortSubjects - .data$subjects) %>% @@ -366,8 +367,8 @@ getResultsCohortOverlap <- function(dataSource, cohortCounts %>% dplyr::select(-"cohortEntries") %>% dplyr::rename( - "comparatorCohortSubjects" = "cohortSubjects", - "comparatorCohortId" = "cohortId" + comparatorCohortSubjects = "cohortSubjects", + comparatorCohortId = "cohortId" ), by = c("databaseId", "comparatorCohortId") ) %>% diff --git a/R/cohort-diagnostics-compareCharacterization.R b/R/cohort-diagnostics-compareCharacterization.R index 58d5e177..6bcd45d3 100644 --- a/R/cohort-diagnostics-compareCharacterization.R +++ b/R/cohort-diagnostics-compareCharacterization.R @@ -246,6 +246,7 @@ plotTemporalCompareStandardizedDifference <- function(balance, #' #' @param id Namespace Id - use namespaced id ns("compareCohortCharacterization") inside diagnosticsExplorer module #' @param title Optional string title field +#' @family {CohortDiagnostics} #' @export compareCohortCharacterizationView <- function(id, title = "Compare cohort characterization") { ns <- shiny::NS(id) diff --git a/R/cohort-diagnostics-conceptsInDataSource.R b/R/cohort-diagnostics-conceptsInDataSource.R index 825e58aa..33819cbe 100644 --- a/R/cohort-diagnostics-conceptsInDataSource.R +++ b/R/cohort-diagnostics-conceptsInDataSource.R @@ -19,6 +19,7 @@ #' Use for customizing UI #' #' @param id Namespace Id - use namespaced id ns("conceptsInDataSource") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export conceptsInDataSourceView <- function(id) { ns <- shiny::NS(id) diff --git a/R/cohort-diagnostics-counts.R b/R/cohort-diagnostics-counts.R index 262c41ea..e104d113 100644 --- a/R/cohort-diagnostics-counts.R +++ b/R/cohort-diagnostics-counts.R @@ -18,6 +18,7 @@ #' @description #' Shiny view for cohort counts module #' @param id Namespace id +#' @family {CohortDiagnostics} #' @export cohortCountsView <- function(id) { ns <- shiny::NS(id) @@ -191,6 +192,7 @@ getInclusionRulesTable <- function( #' @param selectedCohorts shiny::reactive - should return cohorts selected or NULL #' @param selectedDatabaseIds shiny::reactive - should return cohorts selected or NULL #' @param cohortIds shiny::reactive - should return cohorts selected integers or NULL +#' @family {CohortDiagnostics} cohortCountsModule <- function(id, dataSource, cohortTable = dataSource$cohortTable, diff --git a/R/cohort-diagnostics-databaseInformation.R b/R/cohort-diagnostics-databaseInformation.R index 74f4c671..6e1ac0d3 100644 --- a/R/cohort-diagnostics-databaseInformation.R +++ b/R/cohort-diagnostics-databaseInformation.R @@ -20,6 +20,7 @@ #' Use for customizing UI #' #' @param id Namespace Id - use namespaced id ns("databaseInformation") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export databaseInformationView <- function(id) { ns <- shiny::NS(id) diff --git a/R/cohort-diagnostics-definition.R b/R/cohort-diagnostics-definition.R index 27733ec4..ec887394 100644 --- a/R/cohort-diagnostics-definition.R +++ b/R/cohort-diagnostics-definition.R @@ -26,7 +26,7 @@ #' @param cohortName Name for the cohort definition #' #' @param includeConceptSets Do you want to inclued concept set in the documentation -#' +#' @family {CohortDiagnostics} #' @return list object #' getCirceRenderedExpression <- function(cohortDefinition, @@ -302,6 +302,7 @@ exportCohortDefinitionsZip <- function(cohortDefinitions, #' @description #' Outputs cohort definitions #' @param id Namespace id for module +#' @family {CohortDiagnostics} #' @export cohortDefinitionsView <- function(id) { ns <- shiny::NS(id) @@ -522,6 +523,7 @@ getCountForConceptIdInCohort <- #' @param databaseTable data.frame of databasese, databaseId, name #' @param cohortTable data.frame of cohorts, cohortId, cohortName #' @param cohortCountTable data.frame of cohortCounts, cohortId, subjects records +#' @family {CohortDiagnostics} cohortDefinitionsModule <- function( id, dataSource, diff --git a/R/cohort-diagnostics-incidenceRates.R b/R/cohort-diagnostics-incidenceRates.R index 1e331c95..d588ab20 100644 --- a/R/cohort-diagnostics-incidenceRates.R +++ b/R/cohort-diagnostics-incidenceRates.R @@ -500,6 +500,7 @@ plotIncidenceRate <- function(data, #' Use for customizing UI #' #' @param id Namespace Id - use namespaced id ns("incidenceRates") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export incidenceRatesView <- function(id) { ns <- shiny::NS(id) diff --git a/R/cohort-diagnostics-inclusionRules.R b/R/cohort-diagnostics-inclusionRules.R index 8122a1fa..2b71c6fc 100644 --- a/R/cohort-diagnostics-inclusionRules.R +++ b/R/cohort-diagnostics-inclusionRules.R @@ -19,6 +19,7 @@ #' Use for customizing UI #' #' @param id Namespace Id - use namespaced id ns("inclusionRules") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export inclusionRulesView <- function(id) { ns <- shiny::NS(id) diff --git a/R/cohort-diagnostics-indexEventBreakdown.R b/R/cohort-diagnostics-indexEventBreakdown.R index 07476663..25a3ea2f 100644 --- a/R/cohort-diagnostics-indexEventBreakdown.R +++ b/R/cohort-diagnostics-indexEventBreakdown.R @@ -19,6 +19,7 @@ #' Use for customizing UI #' #' @param id Namespace Id - use namespaced id ns("indexEvents") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export indexEventBreakdownView <- function(id) { ns <- shiny::NS(id) diff --git a/R/cohort-diagnostics-main-ui.R b/R/cohort-diagnostics-main-ui.R index 8552922f..b248e3f8 100644 --- a/R/cohort-diagnostics-main-ui.R +++ b/R/cohort-diagnostics-main-ui.R @@ -146,6 +146,7 @@ cdUiControls <- function(ns) { #' @return #' string location of the description helper file #' @family {CohortDiagnostics} +#' #' @export cohortDiagnosticsHelperFile <- function() { fileLoc <- system.file('cohort-diagnostics-www', "cohort-diagnostics.html", package = utils::packageName()) @@ -161,6 +162,7 @@ cohortDiagnosticsHelperFile <- function() { #' #' @return #' The user interface to the cohort diagnostics viewer module +#' @family {CohortDiagnostics} #' #' @export cohortDiagnosticsView <- function(id = "DiagnosticsExplorer") { diff --git a/R/cohort-diagnostics-main.R b/R/cohort-diagnostics-main.R index fa121ef6..ef59f164 100644 --- a/R/cohort-diagnostics-main.R +++ b/R/cohort-diagnostics-main.R @@ -23,7 +23,7 @@ } else if (connectionHandler$dbms() != "sqlite") { tables <- DatabaseConnector::getTableNames(connectionHandler$getConnection(), - databaseSchema = schema) |> + databaseSchema = schema) |> tolower() } else { tables <- DatabaseConnector::getTableNames(connectionHandler$getConnection()) |> @@ -39,18 +39,18 @@ loadResultsTable <- function(dataSource, tableName, required = FALSE, cdTablePre selectTableName <- paste0(cdTablePrefix, tableName) resultsTablesOnServer <- tolower(.availableTables(dataSource$connectionHandler, dataSource$schema)) - + if (required || selectTableName %in% resultsTablesOnServer) { if (tableIsEmpty(dataSource, selectTableName)) { return(data.frame()) } - + tryCatch( - { - table <- dataSource$connectionHandler$queryDb("SELECT * FROM @schema.@table", - schema = dataSource$schema, - table = selectTableName) - }, + { + table <- dataSource$connectionHandler$queryDb("SELECT * FROM @schema.@table", + schema = dataSource$schema, + table = selectTableName) + }, error = function(err) { stop( "Error reading from ", @@ -60,10 +60,10 @@ loadResultsTable <- function(dataSource, tableName, required = FALSE, cdTablePre ) } ) - + return(table) } - + return(data.frame()) } @@ -77,16 +77,16 @@ tableIsEmpty <- function(dataSource, tableName) { schema = dataSource$schema, table = tableName ) - + }, error = function(...) { message("Table not found: ", tableName) }) - + return(nrow(row) == 0) } postgresEnabledReports <- function(connectionHandler, schema, tbls) { - + sql <- " select c.relname as table_name from pg_class c @@ -96,15 +96,16 @@ postgresEnabledReports <- function(connectionHandler, schema, tbls) { and c.reltuples != 0 and n.nspname = '@schema' " - + return(connectionHandler$queryDb(sql, schema = schema) %>% dplyr::pull("tableName")) } #' Get enable cd reports from available data #' @param dataSource Cohort diagnostics data source +#' @family {CohortDiagnostics} #' @export getEnabledCdReports <- function(dataSource) { - + if (dataSource$connectionHandler$dbms() == "postgresql") { tbls <- dataSource$dataModelSpecifications$tableName %>% unique() possible <- paste0(dataSource$cdTablePrefix, tbls) @@ -114,10 +115,10 @@ getEnabledCdReports <- function(dataSource) { SqlRender::snakeCaseToCamelCase() return(enabledReports) } - + enabledReports <- c() resultsTables <- .availableTables(dataSource$connectionHandler, schema = dataSource$schema) - + for (table in dataSource$dataModelSpecifications$tableName %>% unique()) { if (dataSource$prefixTable(table) %in% resultsTables) { if (!tableIsEmpty(dataSource, dataSource$prefixTable(table))) { @@ -126,7 +127,7 @@ getEnabledCdReports <- function(dataSource) { } } enabledReports <- c(enabledReports, "cohort", "database") - + return(enabledReports) } @@ -142,7 +143,7 @@ getEnabledCdReports <- function(dataSource) { #' @param displayProgress display a progress messaage (can only be used inside a shiny reactive context) #' @param dataMigrationsRef The path to a file listing all migrations for the data model that should have been applied #' @return An object of class `CdDataSource`. -#' +#' @family {CohortDiagnostics} #' @export createCdDatabaseDataSource <- function( connectionHandler, @@ -155,7 +156,7 @@ createCdDatabaseDataSource <- function( package = utils::packageName()), displayProgress = FALSE ) { - + checkmate::assertR6(connectionHandler, "ConnectionHandler") checkmate::assertString(resultDatabaseSettings$schema) checkmate::assertString(resultDatabaseSettings$vocabularyDatabaseSchema, null.ok = TRUE) @@ -165,7 +166,7 @@ createCdDatabaseDataSource <- function( checkmate::assertString(resultDatabaseSettings$databaseTablePrefix, null.ok = TRUE) checkmate::assertFileExists(dataModelSpecificationsPath) checkmate::assertFileExists(dataMigrationsRef) - + if (is.null(resultDatabaseSettings$vocabularyDatabaseSchema)) { resultDatabaseSettings$vocabularyDatabaseSchema <- resultDatabaseSettings$schema } @@ -184,7 +185,7 @@ createCdDatabaseDataSource <- function( if (is.null(resultDatabaseSettings$databaseTablePrefix)) { resultDatabaseSettings$databaseTablePrefix <- resultDatabaseSettings$cdTablePrefix } - + if (displayProgress) { shiny::setProgress(value = 0.05, message = "Getting settings") } @@ -196,13 +197,13 @@ createCdDatabaseDataSource <- function( schema = resultDatabaseSettings$schema, cd_table_prefix = resultDatabaseSettings$cdTablePrefix) }, error = function(...) { - warning("CohortDiagnotics schema does not contain migrations table. Schema was likely created incorrectly") + warning("CohortDiagnostics schema does not contain migrations table. Schema was likely created incorrectly") if (displayProgress) { shiny::showNotification(paste("CohortDiagnostics data model does not have migrations table. Schema was likely created incorrectly"), type = "error") } }) - + dataMigrationsExpected <- utils::read.csv(dataMigrationsRef) for (m in dataMigrationsExpected$migrationFile) { if (!m %in% migrations$migrationFile) { @@ -212,10 +213,10 @@ createCdDatabaseDataSource <- function( } } } - + modelSpec <- utils::read.csv(dataModelSpecificationsPath) colnames(modelSpec) <- SqlRender::snakeCaseToCamelCase(colnames(modelSpec)) - + dataSource <- list( connectionHandler = connectionHandler, schema = resultDatabaseSettings$schema, @@ -228,7 +229,7 @@ createCdDatabaseDataSource <- function( # don't prexfix table if we us a dedicated vocabulary schema if (resultDatabaseSettings$vocabularyDatabaseSchema == resultDatabaseSettings$schema) return(paste0(resultDatabaseSettings$cdTablePrefix, tableName)) - + return(tableName) }, cgTable = resultDatabaseSettings$cgTable, @@ -238,53 +239,53 @@ createCdDatabaseDataSource <- function( databaseTablePrefix = "cd_", dataModelSpecifications = modelSpec ) - + if (displayProgress) shiny::setProgress(value = 0.05, message = "Getting enabled reports") - + dataSource$enabledReports <- getEnabledCdReports(dataSource) - + if (displayProgress) shiny::setProgress(value = 0.1, message = "Getting database information") dataSource$dbTable <- getDatabaseTable(dataSource) - + if (displayProgress) shiny::setProgress(value = 0.2, message = "Getting cohorts") - - + + dataSource$cohortTableName <- paste0(dataSource$cdTablePrefix, "cohort") - + dataSource$cohortTable <- getCohortTable(dataSource) - + if (displayProgress) shiny::setProgress(value = 0.6, message = "Getting concept sets") - + dataSource$conceptSets <- loadResultsTable(dataSource, "concept_sets", cdTablePrefix = dataSource$cdTablePrefix) - + if (displayProgress) shiny::setProgress(value = 0.7, message = "Getting counts") - + dataSource$cohortCountTable <- loadResultsTable(dataSource, "cohort_count", required = TRUE, cdTablePrefix = dataSource$cdTablePrefix) - + dataSource$enabledReports <- dataSource$enabledReports - + if (displayProgress) shiny::setProgress(value = 0.7, message = "Getting Temporal References") - + dataSource$temporalAnalysisRef <- loadResultsTable(dataSource, "temporal_analysis_ref", cdTablePrefix = dataSource$cdTablePrefix) - + dataSource$temporalChoices <- getResultsTemporalTimeRef(dataSource = dataSource) - + 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( dataSource$temporalAnalysisRef, @@ -296,20 +297,20 @@ createCdDatabaseDataSource <- function( missingMeansZero = "Y" ) ) - + dataSource$domainIdOptions <- dataSource$temporalAnalysisRef %>% dplyr::select("domainId") %>% dplyr::pull("domainId") %>% unique() %>% sort() - + dataSource$analysisNameOptions <- dataSource$temporalAnalysisRef %>% dplyr::select("analysisName") %>% dplyr::pull("analysisName") %>% unique() %>% sort() } - + class(dataSource) <- "CdDataSource" return(dataSource) } @@ -317,13 +318,13 @@ createCdDatabaseDataSource <- function( getDatabaseTable <- function(dataSource) { databaseTable <- loadResultsTable(dataSource, dataSource$prefixTable(dataSource$databaseTable), required = TRUE) if (nrow(databaseTable) > 0 & - "vocabularyVersion" %in% colnames(databaseTable)) { + "vocabularyVersion" %in% colnames(databaseTable)) { databaseTable <- databaseTable %>% dplyr::mutate( databaseIdWithVocabularyVersion = paste0(.data$databaseId, " (", .data$vocabularyVersion, ")") ) } - + databaseTable } @@ -334,12 +335,12 @@ getCohortTable <- function(dataSource) { schema = dataSource$schema, cd_table_prefix = dataSource$cdTablePrefix ) - + cohortTable <- cohortTable %>% dplyr::arrange(.data$cohortId) %>% dplyr::mutate(shortName = paste0("C", .data$cohortId)) %>% dplyr::mutate(compoundName = paste0(.data$shortName, ": ", .data$cohortName)) - + cohortTable } @@ -352,11 +353,11 @@ getResultsTemporalTimeRef <- function(dataSource) { schema = dataSource$schema, table_name = dataSource$prefixTable("temporal_time_ref") ) - + if (nrow(temporalTimeRef) == 0) { return(NULL) } - + temporalChoices <- temporalTimeRef %>% dplyr::mutate(temporalChoices = paste0("T (", .data$startDay, "d to ", .data$endDay, "d)")) %>% dplyr::arrange(.data$startDay, .data$endDay) %>% @@ -390,7 +391,7 @@ getResultsTemporalTimeRef <- function(dataSource) { false = 1 )) %>% dplyr::arrange(.data$startDay, .data$timeId, .data$endDay) - + temporalChoices <- dplyr::bind_rows( temporalChoices %>% dplyr::slice(0), dplyr::tibble( @@ -402,7 +403,7 @@ getResultsTemporalTimeRef <- function(dataSource) { temporalChoices ) %>% dplyr::mutate(sequence = dplyr::row_number()) - + return(temporalChoices) } @@ -420,7 +421,7 @@ cohortDiagnosticsServer <- function(id, resultDatabaseSettings, dataSource = NULL) { ns <- shiny::NS(id) - + checkmate::assertClass(dataSource, "CdDataSource", null.ok = TRUE) if (is.null(dataSource)) { checkmate::assertR6(connectionHandler, "ConnectionHandler", null.ok = FALSE) @@ -431,7 +432,7 @@ cohortDiagnosticsServer <- function(id, displayProgress = TRUE ) } - + shiny::moduleServer(id, function(input, output, session) { databaseTable <- dataSource$dbTable cohortTable <- dataSource$cohortTable @@ -440,46 +441,46 @@ cohortDiagnosticsServer <- function(id, enabledReports <- dataSource$enabledReports temporalChoices <- dataSource$temporalChoices temporalCharacterizationTimeIdChoices <- dataSource$temporalCharacterizationTimeIdChoices - + shiny::observe({ - + selection <- c( "Cohort Definitions" = "cohortDefinitions", "Database Information" = "databaseInformation" ) if ("cohortCount" %in% dataSource$enabledReports) selection["Cohort Counts"] <- "cohortCounts" - + if ("indexEvents" %in% dataSource$enabledReports) selection["Index Events"] <- "indexEvents" - + if ("temporalCovariateValue" %in% dataSource$enabledReports) { selection["Cohort Characterization"] <- "characterization" selection["Compare Cohort Characterization"] <- "compareCohortCharacterization" selection["Time Distributions"] <- "timeDistribution" } - + if ("relationship" %in% dataSource$enabledReports) selection["Cohort Overlap"] <- "cohortOverlap" - + if ("cohortInclusion" %in% dataSource$enabledReports) selection["Inclusion Rule Statistics"] <- "inclusionRules" - + if ("incidenceRate" %in% dataSource$enabledReports) selection["Incidence"] <- "incidenceRates" - + if ("visitContext" %in% dataSource$enabledReports) selection["Visit Context"] <- "visitContext" - + if ("includedSourceConcept" %in% dataSource$enabledReports) selection["Concepts In Data Source"] <- "conceptsInDataSource" - - if ("orphanConcept" %in% dataSource$enabledReports) + + if ("orphanConcepts" %in% dataSource$enabledReports) selection["Orphan Concepts"] <- "orphanConcepts" - + if ("indexEventBreakdown" %in% dataSource$enabledReports) selection["Index Event Breakdown"] <- "indexEvents" - + shiny::updateSelectInput( inputId = "tabs", label = "Select Report", @@ -487,7 +488,7 @@ cohortDiagnosticsServer <- function(id, selected = c("cohortDefinitions") ) }) - + # Reacive: targetCohortId targetCohortId <- shiny::reactive({ return(cohortTable$cohortId[cohortTable$compoundName == input$targetCohort]) @@ -499,11 +500,11 @@ cohortDiagnosticsServer <- function(id, dplyr::select("cohortId") %>% dplyr::pull() }) - + selectedConceptSets <- shiny::reactive({ input$conceptSetsSelected }) - + # conceptSetIds ---- conceptSetIds <- shiny::reactive(x = { conceptSetsFiltered <- conceptSets %>% @@ -514,10 +515,10 @@ cohortDiagnosticsServer <- function(id, unique() return(conceptSetsFiltered) }) - + databaseChoices <- databaseTable$databaseId names(databaseChoices) <- databaseTable$databaseName - + ## ReactiveValue: selectedDatabaseIds ---- selectedDatabaseIds <- shiny::reactive({ if (!is.null(input$tabs)) { @@ -533,8 +534,8 @@ cohortDiagnosticsServer <- function(id, } } }) - - + + shiny::observe({ shinyWidgets::updatePickerInput(session = session, inputId = "database", @@ -547,7 +548,7 @@ cohortDiagnosticsServer <- function(id, selected = databaseChoices[[1]], ) }) - + ## ReactiveValue: selectedTemporalTimeIds ---- selectedTemporalTimeIds <- shiny::reactiveVal(NULL) shiny::observeEvent(eventExpr = { @@ -558,7 +559,7 @@ cohortDiagnosticsServer <- function(id, ) }, handlerExpr = { if (isFALSE(input$timeIdChoices_open) || - !is.null(input$tabs) & !is.null(temporalCharacterizationTimeIdChoices)) { + !is.null(input$tabs) & !is.null(temporalCharacterizationTimeIdChoices)) { selectedTemporalTimeIds( temporalCharacterizationTimeIdChoices %>% dplyr::filter(.data$temporalChoices %in% input$timeIdChoices) %>% @@ -568,12 +569,12 @@ cohortDiagnosticsServer <- function(id, ) } }) - + cohortSubset <- shiny::reactive({ return(cohortTable %>% dplyr::arrange(.data$cohortId)) }) - + shiny::observe({ subset <- cohortSubset()$compoundName shinyWidgets::updatePickerInput( @@ -583,7 +584,7 @@ cohortDiagnosticsServer <- function(id, choices = subset ) }) - + shiny::observe({ subset <- cohortSubset()$compoundName shinyWidgets::updatePickerInput( @@ -594,7 +595,7 @@ cohortDiagnosticsServer <- function(id, selected = c(subset[1], subset[2]) ) }) - + # Characterization (Shared across) ------------------------------------------------- ## Reactive objects ---- ### getConceptSetNameForFilter ---- @@ -606,9 +607,9 @@ cohortDiagnosticsServer <- function(id, dplyr::filter(.data$cohortId == targetCohortId()) %>% dplyr::mutate(name = .data$conceptSetName) %>% dplyr::select("name") - + }) - + shiny::observe({ subset <- getConceptSetNameForFilter()$name %>% sort() %>% @@ -620,7 +621,7 @@ cohortDiagnosticsServer <- function(id, choices = subset ) }) - + selectedCohorts <- shiny::reactive({ cohorts <- cohortSubset() %>% dplyr::filter(.data$cohortId %in% cohortIds()) %>% @@ -630,17 +631,17 @@ cohortDiagnosticsServer <- function(id, shiny::tags$tr(lapply(x, shiny::tags$td)) })) }) - + selectedCohort <- shiny::reactive({ return(input$targetCohort) }) - + if ("cohort" %in% enabledReports) { cohortDefinitionsModule(id = "cohortDefinitions", dataSource = dataSource, cohortDefinitions = cohortSubset) } - + if ("includedSourceConcept" %in% enabledReports) { conceptsInDataSourceModule(id = "conceptsInDataSource", dataSource = dataSource, @@ -650,7 +651,7 @@ cohortDiagnosticsServer <- function(id, selectedConceptSets = selectedConceptSets, databaseTable = databaseTable) } - + if ("orphanConcept" %in% enabledReports) { orphanConceptsModule("orphanConcepts", dataSource = dataSource, @@ -661,7 +662,7 @@ cohortDiagnosticsServer <- function(id, selectedConceptSets = selectedConceptSets, conceptSetIds = conceptSetIds) } - + if ("cohortCount" %in% enabledReports) { cohortCountsModule(id = "cohortCounts", dataSource = dataSource, @@ -671,7 +672,7 @@ cohortDiagnosticsServer <- function(id, selectedDatabaseIds = selectedDatabaseIds, cohortIds = cohortIds) } - + if ("indexEventBreakdown" %in% enabledReports) { indexEventBreakdownModule(id = "indexEvents", dataSource = dataSource, @@ -680,7 +681,7 @@ cohortDiagnosticsServer <- function(id, cohortCountTable = cohortCountTable, selectedDatabaseIds = selectedDatabaseIds) } - + if ("visitContext" %in% enabledReports) { visitContextModule(id = "visitContext", dataSource = dataSource, @@ -690,7 +691,7 @@ cohortDiagnosticsServer <- function(id, cohortCountTable = cohortCountTable, databaseTable = databaseTable) } - + if ("relationship" %in% enabledReports) { cohortOverlapModule(id = "cohortOverlap", dataSource = dataSource, @@ -700,21 +701,21 @@ cohortDiagnosticsServer <- function(id, cohortIds = cohortIds, cohortTable = cohortTable) } - + if ("temporalCovariateValue" %in% enabledReports) { timeDistributionsModule(id = "timeDistributions", dataSource = dataSource, selectedCohorts = selectedCohorts, cohortIds = cohortIds, selectedDatabaseIds = selectedDatabaseIds) - + cohortDiagCharacterizationModule(id = "characterization", dataSource = dataSource) - + compareCohortCharacterizationModule(id = "compareCohortCharacterization", dataSource = dataSource) } - + if ("incidenceRate" %in% enabledReports) { incidenceRatesModule(id = "incidenceRates", dataSource = dataSource, @@ -724,7 +725,7 @@ cohortDiagnosticsServer <- function(id, databaseTable = databaseTable, cohortTable = cohortTable) } - + if ("cohortInclusion" %in% enabledReports) { inclusionRulesModule(id = "inclusionRules", dataSource = dataSource, @@ -732,15 +733,15 @@ cohortDiagnosticsServer <- function(id, selectedCohort = selectedCohort, targetCohortId = targetCohortId, selectedDatabaseIds = selectedDatabaseIds) - + } databaseInformationModule(id = "databaseInformation", dataSource = dataSource, selectedDatabaseIds = selectedDatabaseIds, databaseTable = databaseTable) - + } - + ) - -} + +} \ No newline at end of file diff --git a/R/cohort-diagnostics-orphanConcepts.R b/R/cohort-diagnostics-orphanConcepts.R index 1dba27f4..51d6564d 100644 --- a/R/cohort-diagnostics-orphanConcepts.R +++ b/R/cohort-diagnostics-orphanConcepts.R @@ -19,6 +19,7 @@ #' Use for customizing UI #' @family {CohortDiagnostics} #' @param id Namespace Id - use namespaced id ns("orphanConcepts") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export orpahanConceptsView <- function(id) { ns <- shiny::NS(id) diff --git a/R/cohort-diagnostics-timeDistributions.R b/R/cohort-diagnostics-timeDistributions.R index 436c7b80..764809f9 100644 --- a/R/cohort-diagnostics-timeDistributions.R +++ b/R/cohort-diagnostics-timeDistributions.R @@ -219,6 +219,7 @@ plotTimeDistribution <- function(data, shortNameRef = NULL, showMax = FALSE) { #' Use for customizing UI #' #' @param id Namespace Id - use namespaced id ns("imeDistributions") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export timeDistributionsView <- function(id) { ns <- shiny::NS(id) diff --git a/R/cohort-diagnostics-visitContext.R b/R/cohort-diagnostics-visitContext.R index 3b4b1771..dcc5c704 100644 --- a/R/cohort-diagnostics-visitContext.R +++ b/R/cohort-diagnostics-visitContext.R @@ -19,6 +19,7 @@ #' Use for customizing UI #' #' @param id Namespace Id - use namespaced id ns("vistConext") inside diagnosticsExplorer module +#' @family {CohortDiagnostics} #' @export visitContextView <- function(id) { ns <- shiny::NS(id) diff --git a/R/cohort-generator-main.R b/R/cohort-generator-main.R index 4a1b6cb0..2e2f7b88 100644 --- a/R/cohort-generator-main.R +++ b/R/cohort-generator-main.R @@ -21,7 +21,7 @@ #' #' @details #' Returns the location of the cohort-generator helper file -#' +#' @family {CohortGenerator} #' @return #' string location of the cohort-generator helper file #' @@ -34,7 +34,7 @@ cohortGeneratorHelperFile <- function(){ #' The viewer of the main cohort generator module #' #' @param id the unique reference id for the module -#' +#' @family {CohortGenerator} #' @return #' The user interface to the cohort generator results viewer #' @@ -119,6 +119,9 @@ cohortGeneratorViewer <- function(id) { title = shiny::span( shiny::icon("table"), 'Generation Table'), #solidHeader = TRUE, + shiny::uiOutput(ns("selectColsCohortGeneration") + ), + reactable::reactableOutput( outputId = ns("cohortGeneration") ) @@ -167,7 +170,10 @@ cohortGeneratorViewer <- function(id) { title = shiny::span( shiny::icon("table"), 'Attrition Table'), #solidHeader = TRUE, - reactable::reactableOutput(ns('attritionTable')) + # shiny::uiOutput(ns("selectColsCohortAttrition") + # ), + + resultTableViewer(ns('attritionTable')) ), shinydashboard::box( @@ -193,7 +199,7 @@ cohortGeneratorViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler a connection to the database with the results #' @param resultDatabaseSettings a named list containing the cohort generator results database details (schema, table prefix) -#' +#' @family {CohortGenerator} #' @return #' the cohort generator results viewer main module server #' @@ -359,19 +365,65 @@ cohortGeneratorServer <- function( } ) - output$cohortGeneration <- reactable::renderReactable({ - data <- getCohortGeneratorCohortMeta( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) %>% - dplyr::select("cdmSourceName", - "cohortId", - "cohortName", - "generationStatus", - "startTime", - "endTime", - "generationDuration") - reactable::reactable(data, + inputColsCohortGeneration <- colnames(getCohortGeneratorCohortMeta( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::select("cdmSourceName", + "cohortId", + "cohortName", + "generationStatus", + "startTime", + "endTime", + "generationDuration") + ) + + names(inputColsCohortGeneration) <- c("Database Name", + "Cohort ID", + "Cohort Name", + "Is the Cohort Generated?", + "Generation Start Time", + "Generation End Time", + "Generation Duration (mins)") + + output$selectColsCohortGeneration <- shiny::renderUI({ + + shinyWidgets::pickerInput( + inputId = session$ns('cohortGenerationCols'), + label = 'Select Columns to Display: ', + choices = inputColsCohortGeneration, + selected = inputColsCohortGeneration, + choicesOpt = list(style = rep_len("color: black;", 999)), + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ), + width = "50%" + ) + + }) + + dataGen <- getCohortGeneratorCohortMeta( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::select("cdmSourceName", + "cohortId", + "cohortName", + "generationStatus", + "startTime", + "endTime", + "generationDuration") + + cgTable <- shiny::reactive({ + + reactable::reactable(dataGen %>% + dplyr::select(input$cohortGenerationCols), columns = list( # Render a "show details" button in the last column of the table. # This button won't do anything by itself, but will trigger the custom @@ -430,6 +482,24 @@ cohortGeneratorServer <- function( ) }) + output$cohortGeneration <- reactable::renderReactable({ + + tryCatch({ + cgTable() + }, + + error = function(e){ + shiny::showNotification( + paste0( + "Loading..." + ) + ); + return(NULL) + } + + ) + }) + # download button - generation output$downloadCohortGeneration <- shiny::downloadHandler( filename = function() { @@ -579,97 +649,98 @@ cohortGeneratorServer <- function( data <- inputValsClean %>% - dplyr::filter(.data$cdmSourceName %in% input$selectedDatabaseId & - .data$cohortName %in% input$selectedCohortName & - .data$modeId %in% input$selectedModeId - ) + dplyr::filter(.data$cdmSourceName %in% input$selectedDatabaseId & + .data$cohortName %in% input$selectedCohortName & + .data$modeId %in% input$selectedModeId + ) reactiveData <- shiny::reactive(data) if(!is.null(data)){ - - output$attritionTable <- reactable::renderReactable( - reactable::reactable( - data = reactiveData() %>% - dplyr::select(c("cdmSourceName", "cohortName", "ruleName", - "personCount", "dropCount", - "dropPerc", "retainPerc") + + resultTableServer( + id = 'attritionTable', + df = reactiveData() %>% + dplyr::select(c("cdmSourceName", "cohortName", "ruleName", + "personCount", "dropCount", + "dropPerc", "retainPerc") + ) + + , + # rownames = FALSE, + # defaultPageSize = 5, + # showPageSizeOptions = T, + # striped = T, + colDefsInput = list( + cdmSourceName = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Database Name", + "The name of the database" + )), + cohortName = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Cohort Name", + "The name of the cohort" + )), + ruleName = reactable::colDef( + header = withTooltip( + "Inclusion Rule Name", + "The name of the inclusion rule" + )), + personCount = reactable::colDef( + format = reactable::colFormat(separators = TRUE), + header = withTooltip( + "Subject/Record Count", + "The number of subjects or records (depending on your selection) remaining after the inclusion rule was applied" + )), + dropCount = reactable::colDef( + format = reactable::colFormat(separators = TRUE), + header = withTooltip( + "Number Lost", + "The number of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied" + )), + dropPerc = reactable::colDef( + format = reactable::colFormat(separators = TRUE), + header = withTooltip( + "Percentage Lost", + "The percentage of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied compared to the previous rule count" + )), + retainPerc = reactable::colDef( + format = reactable::colFormat(separators = TRUE), + header = withTooltip( + "Percentage Retained", + "The percentage of subjects or records (depending on your selection) retained after the inclusion rule was applied compared to the previous rule count" + )) ) - - , - rownames = FALSE, - defaultPageSize = 5, - showPageSizeOptions = T, - striped = T, - columns = list( - cdmSourceName = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Database Name", - "The name of the database" - )), - cohortName = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cohort Name", - "The name of the cohort" - )), - ruleName = reactable::colDef( - header = withTooltip( - "Inclusion Rule Name", - "The name of the inclusion rule" - )), - personCount = reactable::colDef( - format = reactable::colFormat(separators = TRUE), - header = withTooltip( - "Subject/Record Count", - "The number of subjects or records (depending on your selection) remaining after the inclusion rule was applied" - )), - dropCount = reactable::colDef( - format = reactable::colFormat(separators = TRUE), - header = withTooltip( - "Number Lost", - "The number of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied" - )), - dropPerc = reactable::colDef( - format = reactable::colFormat(separators = TRUE), - header = withTooltip( - "Percentage Lost", - "The percentage of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied compared to the previous rule count" - )), - retainPerc = reactable::colDef( - format = reactable::colFormat(separators = TRUE), - header = withTooltip( - "Number Retained", - "The number of subjects or records (depending on your selection) retained after the inclusion rule was applied compared to the previous rule count" - )) - ), - - filterable = TRUE, - sortable = TRUE, - defaultColDef = reactable::colDef( - align = "left" + #, + + # filterable = TRUE, + # sortable = TRUE, + # defaultColDef = reactable::colDef( + # align = "left" + # ) + ) + #) + + #attrition plot + output$attritionPlot <- plotly::renderPlotly( + getCohortAttritionPlot( + data ) ) - ) - - #attrition plot - output$attritionPlot <- plotly::renderPlotly( - getCohortAttritionPlot( - data + + # download button + output$downloadAttritionTable <- shiny::downloadHandler( + filename = function() { + paste('cohort-attrition-data-', Sys.Date(), '.csv', sep='') + }, + content = function(con) { + utils::write.csv(data() + , con) + } ) - ) - - # download button - output$downloadAttritionTable <- shiny::downloadHandler( - filename = function() { - paste('cohort-attrition-data-', Sys.Date(), '.csv', sep='') - }, - content = function(con) { - utils::write.csv(data() - , con) - } - ) } else{ @@ -677,20 +748,20 @@ cohortGeneratorServer <- function( } } - ) - - }, + ) - error = function(e){ - shiny::showNotification( - paste0( - "No cohort inclusion result data present." - ) - ); - return(NULL) - } - - ) + }, + + error = function(e){ + shiny::showNotification( + paste0( + "No cohort inclusion result data present." + ) + ); + return(NULL) + } + + ) # end of server diff --git a/R/cohort-method-diagnosticsSummary.R b/R/cohort-method-diagnosticsSummary.R deleted file mode 100644 index 72f0a66b..00000000 --- a/R/cohort-method-diagnosticsSummary.R +++ /dev/null @@ -1,389 +0,0 @@ -# @file cohort-method-diagnosticsSummary -# -# 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 module viewer for rendering the PLE diagnostics results -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the cohort method diagnostics viewer -#' -#' @export -cohortMethodDiagnosticsSummaryViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - - shiny::tabsetPanel( - type = 'pills', - id = ns('diagnosticsTablePanel'), - shiny::tabPanel( - title = 'Summary', - resultTableViewer(ns("diagnosticsSummaryTable")) - ), - shiny::tabPanel( - title = 'Full', - resultTableViewer(ns("diagnosticsTable")) - ) - ) - #) - ) -} - - -#' The module server for rendering the PLE diagnostics summary -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the PLE results database -#' @param resultDatabaseSettings a list containing the result schema and prefixes -#' @param inputSelected The target id, comparator id, outcome id and analysis id selected by the user -#' -#' @return -#' the PLE diagnostics summary results -#' -#' @export -cohortMethodDiagnosticsSummaryServer <- function( - id, - connectionHandler, - resultDatabaseSettings, - inputSelected -) { - - shiny::moduleServer( - id, - function(input, output, session) { - - data <- shiny::reactive({ - getCmDiagnosticsData( - connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - inputSelected = inputSelected - ) - }) - - data2 <- shiny::reactive({ - diagnosticSummaryFormat(data) - }) - - customColDefs <- list( - databaseName = reactable::colDef( - header = withTooltip( - "Database", - "The database name" - ) - ), - target = reactable::colDef( - header = withTooltip( - "Target", - "The target cohort of interest" - ), - minWidth = 300 - ), - comparator = reactable::colDef( - header = withTooltip( - "Comparator", - "The comparator cohort of interest" - ), - minWidth = 300 - ), - outcome = reactable::colDef( - header = withTooltip( - "Outcome", - "The outcome of interest" - ) - ), - analysis = reactable::colDef( - header = withTooltip( - "Analysis", - "The analysis name" - ) - ), - - mdrr = reactable::colDef( - header = withTooltip( - "MDRR", - "The minimum detectible relative risk" - ), - format = reactable::colFormat(digits = 4) - ), - ease = reactable::colDef( - header = withTooltip( - "EASE", - "The 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" - ) - ), - - summaryValue = reactable::colDef(show = F) - - ) - - resultTableServer( - id = "diagnosticsTable", - df = data, - colDefsInput = customColDefs - ) - - resultTableServer( - id = "diagnosticsSummaryTable", - df = data2, - colDefsInput = getColDefsCmDiag( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - ) - - } - ) -} - -getColDefsCmDiag <- function( - connectionHandler, - resultDatabaseSettings -){ - - fixedColumns = list( - databaseName = reactable::colDef( - header = withTooltip( - "Database", - "The database name" - ), - sticky = "left" - ), - target = reactable::colDef( - header = withTooltip( - "Target", - "The target cohort of interest" - ), - sticky = "left" - ), - comparator = reactable::colDef( - header = withTooltip( - "Comparator", - "The comparator cohort of interest" - ), - sticky = "left" - ) - ) - - outcomes <- getCmCohorts( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - type = 'outcome' - ) - analyses <- getCmAnalyses( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - colnameFormat <- merge(unique(names(outcomes)), unique(names(analyses))) - colnameFormat <- apply(colnameFormat, 1, function(x){paste(x, collapse = '_', sep = '_')}) - - styleList <- lapply( - colnameFormat, - FUN = function(x){ - reactable::colDef( - header = withTooltip( - paste0(substring(x,1,35), "...", sep=""), - x - ), - style = function(value) { - color <- 'orange' - if(is.na(value)){ - color <- 'black' - }else if(value == 'Pass'){ - color <- '#AFE1AF' - }else if(value == 'Fail'){ - color <- '#E97451' - } - list(background = color) - } - ) - } - ) - names(styleList) <- colnameFormat - result <- append(fixedColumns, styleList) - - return(result) -} - -diagnosticSummaryFormat <- function( - data, - idCols = c('databaseName','target', 'comparator'), - namesFrom = c('outcome','analysis') - ){ - - if(is.null(data())){ - return(NULL) - } - - data2 <- tidyr::pivot_wider( - data = data(), - id_cols = idCols, - names_from = namesFrom, - values_from = c('summaryValue') - ) - - return(data2) -} - - - -getCmDiagnosticsData <- function( - connectionHandler, - resultDatabaseSettings, - inputSelected -) { - - targetIds = inputSelected()$targetIds - outcomeIds = inputSelected()$outcomeIds - comparatorIds = inputSelected()$comparatorIds - analysisIds = inputSelected()$analysisIds - - if(is.null(targetIds) || is.null(outcomeIds)){ - return(NULL) - } - - sql <- " - SELECT DISTINCT - dmd.cdm_source_abbreviation database_name, - cma.description analysis, - cgcd1.cohort_name target, - cgcd2.cohort_name comparator, - cgcd3.cohort_name outcome, - cmds.max_sdm, - cmds.shared_max_sdm, - cmds.equipoise, - cmds.mdrr, - cmds.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(outcomeIds, collapse = ','), - analyses = paste0(analysisIds, collapse = ','), - - use_comparators = !is.null(comparatorIds), - use_analyses = !is.null(analysisIds) - ) - - # adding percent fail for summary - result$summaryValue <- apply( - X = result[, grep('Diagnostic', colnames(result))], - MARGIN = 1, - FUN = function(x){ - - if(sum(x %in% c('FAIL'))>0){ - return('Fail') - } else if(sum(x %in% c('WARNING')) >0){ - return(sum(x %in% c('WARNING'))) - } else{ - return('Pass') - } - } - ) - - return( - result - ) -} diff --git a/R/cohort-method-main.R b/R/cohort-method-main.R deleted file mode 100644 index 7d81487d..00000000 --- a/R/cohort-method-main.R +++ /dev/null @@ -1,290 +0,0 @@ -# @file cohort-method-main.R -# -# Copyright 2024 Observational Health Data Sciences and Informatics -# -# This file is part of PatientLevelPrediction -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. - - -#' The location of the cohort method module helper file -#' -#' @details -#' Returns the location of the cohort method helper file -#' -#' @return -#' string location of the cohort method helper file -#' -#' @export -cohortMethodHelperFile <- function(){ - fileLoc <- system.file('cohort-method-www', "cohort-method.html", package = "OhdsiShinyModules") - return(fileLoc) -} - -#' The viewer of the main cohort method module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the cohort method results viewer -#' -#' @export -cohortMethodViewer <- function(id) { - ns <- shiny::NS(id) - - shinydashboard::box( - status = 'info', - width = 12, - title = shiny::span( shiny::icon("chart-column"), 'Cohort Method'), - solidHeader = TRUE, - - - - # Input selection of T, C and Os - inputSelectionViewer(ns("input-selection")), - - shiny::conditionalPanel( - condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection")), - - shiny::tabsetPanel( - type = 'pills', - id = ns('mainPanel'), - - shiny::tabPanel( - title = "Diagnostics", - cohortMethodDiagnosticsSummaryViewer(ns("cmDiganostics")) - ), - - shiny::tabPanel( - title = "Results", - cohortMethodResultSummaryViewer(ns("cmResults")) - ) - ) - ) - - ) -} - - -#' The module server for the main cohort method module -#' -#' @param id the unique reference id for the module -#' @param connectionHandler a connection to the database with the results -#' @param resultDatabaseSettings a named list containing the PLE results database connection details -#' -#' @return -#' the PLE results viewer main module server -#' -#' @export -cohortMethodServer <- function( - id, - connectionHandler, - resultDatabaseSettings - ) { - - shiny::moduleServer( - id, - function(input, output, session) { - - dataFolder <- NULL - - targetIds <- getCmCohorts( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - type = 'target' - ) - outcomeIds <- getCmCohorts( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - type = 'outcome' - ) - comparatorIds <- getCmCohorts( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - type = 'comparator' - ) - analysisIds <- getCmAnalyses( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - inputSelected <- inputSelectionServer( - id = "input-selection", - inputSettingList = list( - createInputSetting( - rowNumber = 1, - columnWidth = 6, - varName = 'targetIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Target: ', - choices = targetIds, - selected = targetIds[1], - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - createInputSetting( - rowNumber = 1, - columnWidth = 6, - varName = 'outcomeIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Outcome: ', - choices = outcomeIds, - selected = outcomeIds[1], - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - createInputSetting( - rowNumber = 2, - columnWidth = 6, - varName = 'comparatorIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Comparator: ', - choices = comparatorIds, - selected = comparatorIds[1], - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - - createInputSetting( - rowNumber = 2, - columnWidth = 6, - varName = 'analysisIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Analysis: ', - choices = analysisIds, - selected = analysisIds[1], - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) - ) - ) - - cohortMethodDiagnosticsSummaryServer( - id = "cmDiganostics", - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - inputSelected = inputSelected - ) - - cohortMethodResultSummaryServer( - id = "cmResults", - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - inputSelected = inputSelected - ) - - } - ) -} - -getCmCohorts <- function( - connectionHandler, - resultDatabaseSettings, - type = 'target' -){ - - sql <- " - SELECT DISTINCT - cgcd1.cohort_name as names, - cgcd1.cohort_definition_id - FROM - @schema.@cm_table_prefixresult cmds - INNER JOIN - @schema.@cg_table_prefixcohort_definition cgcd1 - ON cmds.@type_id = cgcd1.cohort_definition_id; - " - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - type = type - ) - - res <- result$cohortDefinitionId - names(res) <- result$names - - return( - res - ) -} - -getCmAnalyses <- function( - connectionHandler, - resultDatabaseSettings -){ - - sql <- " - SELECT DISTINCT - cma.analysis_id, - cma.description as names - FROM - @schema.@cm_table_prefixresult cmds - INNER JOIN - @schema.@cm_table_prefixanalysis cma - ON cmds.analysis_id = cma.analysis_id - ; - " - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix - ) - - res <- result$analysisId - names(res) <- result$names - - return( - res - ) - -} diff --git a/R/components-data-viewer.R b/R/components-data-viewer.R index 8ad40662..6f544539 100644 --- a/R/components-data-viewer.R +++ b/R/components-data-viewer.R @@ -9,18 +9,20 @@ #' #' @param id string #' @param downloadedFileName string, desired name of downloaded data file. can use the name from the module that is being used -#' +#' @param boxTitle the title added to the box +#' @family {Utils} #' @return shiny module UI #' @family {Utils} resultTableViewer <- function( id = "result-table", - downloadedFileName = NULL + downloadedFileName = NULL, + boxTitle = 'Table' ) { ns <- shiny::NS(id) shiny::div(# UI shinydashboard::box( width = "100%", - title = shiny::span(shiny::icon("table"), "Table"), + title = shiny::span(shiny::icon("table"), boxTitle), shiny::fluidPage( shiny::fluidRow( shiny::column( @@ -148,6 +150,7 @@ ohdsiReactableTheme <- reactable::reactableTheme( #' @param id string, table id must match resultsTableViewer function #' @param df reactive that returns a data frame #' @param colDefsInput named list of reactable::colDefs +#' @param details The details of the results such as cohort names and database names #' @param selectedCols string vector of columns the reactable should display to start by default. Defaults to ALL if not specified. #' @param sortedCols string vector of columns the reactable should sort by by default. Defaults to no sort if not specified. #' @param elementId optional string vector of element Id name for custom dropdown filtering if present in the customColDef list. Defaults to NULL. @@ -156,13 +159,14 @@ ohdsiReactableTheme <- reactable::reactableTheme( #' actions must be a column in df #' @param downloadedFileName string, desired name of downloaded data file. can use the name from the module that is being used #' @param groupBy The columns to group by -#' +#' @family {Utils} #' @return shiny module server #' @family {Utils} resultTableServer <- function( id, #string df, #data.frame colDefsInput, + details = data.frame(), # details about the data.frame such as target and database name selectedCols = NULL, sortedCols = NULL, elementId = NULL, @@ -174,6 +178,13 @@ resultTableServer <- function( id, function(input, output, session) { + + # find the columns that are set to show=F + colNames <- names(colDefsInput) + hideCol <- unlist(lapply(colDefsInput, function(x) ifelse(is.null(x$show), F, !x$show))) + hideColNames <- colNames[hideCol] + + # convert a data.frame to a reactive if(!inherits(df, 'reactive')){ df <- shiny::reactiveVal(df) @@ -199,8 +210,8 @@ resultTableServer <- function( if(!is.null(selectedCols)){ intersect(colnames(newdf()), selectedCols) } - else{ - colnames(newdf()) + else{ # edited to restrict to colDef - show = T columns + setdiff(colnames(newdf()), hideColNames) } }) @@ -245,12 +256,13 @@ resultTableServer <- function( onClick <- NULL } + output$columnSelector <- shiny::renderUI({ shinyWidgets::pickerInput( inputId = session$ns('dataCols'), label = 'Select Columns to Display: ', - choices = colnames(newdf()), + choices = setdiff(colnames(newdf()), hideColNames), # edited to only show columns show = T selected = selectedColumns(), choicesOpt = list(style = rep_len("color: black;", 999)), multiple = T, @@ -266,6 +278,7 @@ resultTableServer <- function( ) }) + #need to try adding browser() to all reactives to see why selected cols isnt working @@ -323,7 +336,19 @@ function filterMinValue(rows, columnId, filterValue) { }); } " - +#use fuzzy text matching for global table search +fuzzySearch<- reactable::JS('function(rows, columnIds, filterValue) { + + // Create a case-insensitive RegEx pattern that performs a fuzzy search. + const pattern = new RegExp(filterValue, "i"); + + return rows.filter(function(row) { + return columnIds.some(function(columnId) { + return pattern.test(row.values[columnId]); + }); + }); +}') + output$resultData <- reactable::renderReactable({ if (is.null(input$dataCols)) { data = newdf() @@ -339,45 +364,50 @@ function filterMinValue(rows, columnId, filterValue) { } else{ height <- NULL } - - reactable::reactable( - data, - columns = colDefs(), - onClick = onClick, - groupBy = groupBy, - #these can be turned on/off and will overwrite colDef args - sortable = TRUE, - resizable = TRUE, - filterable = TRUE, - searchable = TRUE, - showPageSizeOptions = TRUE, - outlined = TRUE, - showSortIcon = TRUE, - striped = TRUE, - highlight = TRUE, - defaultColDef = reactable::colDef(align = "left"), - defaultSorted = sortedColumns(), - rowStyle = list( - height = height - ), - elementId = elementIdName() - #, experimental - #theme = ohdsiReactableTheme - ) + # htmltools::browsable( + # tagList( + # matchSorterDep, + reactable::reactable( + data, + columns = colDefs(), + onClick = onClick, + groupBy = groupBy, + #these can be turned on/off and will overwrite colDef args + sortable = TRUE, + resizable = TRUE, + filterable = TRUE, + searchable = TRUE, + searchMethod = fuzzySearch, + showPageSizeOptions = TRUE, + outlined = TRUE, + showSortIcon = TRUE, + striped = TRUE, + highlight = TRUE, + #defaultColDef = reactable::colDef(align = "left"), + defaultSorted = sortedColumns(), + rowStyle = list( + height = height + ), + elementId = elementIdName() + #, experimental + #theme = ohdsiReactableTheme + ) + # ) + # ) }) # download full data button output$downloadDataFull <- shiny::downloadHandler( filename = function() { - paste('result-data-full-', downloadedFileName, Sys.Date(), '.csv', sep = '') + paste('result-data-full-', downloadedFileName, Sys.Date(), '.xlsx', sep = '') }, content = function(con) { - utils::write.csv( - x = df(), - file = con, - row.names = F - ) + wb <- openxlsx::buildWorkbook(x = list( + details = details, + results = df() + )) + openxlsx::saveWorkbook(wb = wb, file = con) } ) 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/components-largeTableViewer.R b/R/components-largeTableViewer.R index 0e1c8220..67f42a95 100644 --- a/R/components-largeTableViewer.R +++ b/R/components-largeTableViewer.R @@ -103,7 +103,7 @@ LargeDataTable <- R6::R6Class( #' @param baseQuery base sql query #' @param countQuery count query string (should match query). Can be auto generated with sub query #' (default) but this will likely result in slow results -#' @family {LargeTables} +#' @family {LargeTables} createLargeSqlQueryDt <- function(connectionHandler = NULL, connectionDetails = NULL, baseQuery, diff --git a/R/data-diagnostic-drill.R b/R/data-diagnostic-drill.R index 2da1c2a5..39b62774 100644 --- a/R/data-diagnostic-drill.R +++ b/R/data-diagnostic-drill.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {DataDiagnostics} #' @return #' The user interface to the summary module #' @@ -53,7 +53,7 @@ dataDiagnosticDrillViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {DataDiagnostics} #' @return #' The server to the summary module #' diff --git a/R/data-diagnostic-main.R b/R/data-diagnostic-main.R index 8a460c12..30fd6a0f 100644 --- a/R/data-diagnostic-main.R +++ b/R/data-diagnostic-main.R @@ -21,7 +21,7 @@ #' #' @details #' Returns the location of the data-diagnostic helper file -#' +#' @family {DataDiagnostics} #' @return #' string location of the data-diagnostic helper file #' @@ -37,7 +37,7 @@ dataDiagnosticHelperFile <- function(){ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {DataDiagnostics} #' @return #' The user interface to the data-diagnostic viewer module #' @@ -72,7 +72,7 @@ dataDiagnosticViewer <- function(id = 'dataDiag') { #' @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 data-diagnostic result schema -#' +#' @family {DataDiagnostics} #' @return #' The server for the data-diagnostic module #' diff --git a/R/data-diagnostic-summary.R b/R/data-diagnostic-summary.R index b9b72614..9486a591 100644 --- a/R/data-diagnostic-summary.R +++ b/R/data-diagnostic-summary.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {DataDiagnostics} #' @return #' The user interface to the summary module #' @@ -47,7 +47,7 @@ dataDiagnosticSummaryViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {DataDiagnostics} #' @return #' The server to the summary module #' diff --git a/R/datasources-main.R b/R/datasources-main.R index 207fe812..23ab5d7e 100644 --- a/R/datasources-main.R +++ b/R/datasources-main.R @@ -22,6 +22,7 @@ #' Define the helper file for the module #' #' @return The helper html file for the datasources module +#' @family {Utils} #' @export #' @family {Utils} datasourcesHelperFile <- function() { @@ -37,6 +38,7 @@ datasourcesHelperFile <- function() { #' @param id The unique id for the datasources viewer namespace #' #' @return The UI for the datasources module +#' @family {Utils} #' @export #' @family {Utils} datasourcesViewer <- function(id) { @@ -71,6 +73,7 @@ datasourcesViewer <- function(id) { #' @param resultDatabaseSettings A named list containing the cohort generator results database details (schema, table prefix) #' #' @return The server for the datasources module +#' @family {Utils} #' @export #' @family {Utils} datasourcesServer <- function( @@ -167,6 +170,9 @@ datasourcesServer <- function( resultTableServer(id = "datasourcesTable", df = datasourcesData, colDefsInput = datasourcesColList, + selectedCols = c("cdmSourceName", "cdmSourceAbbreviation", "cdmHolder", + "sourceReleaseDate", "cdmReleaseDate", "cdmVersion", + "vocabularyVersion", "maxObsPeriodEndDate"), downloadedFileName = "datasourcesTable-") return(invisible(NULL)) diff --git a/R/cohort-method-attrition.R b/R/estimation-cohort-method-attrition.R similarity index 99% rename from R/cohort-method-attrition.R rename to R/estimation-cohort-method-attrition.R index 31ed7da5..649b5b06 100644 --- a/R/cohort-method-attrition.R +++ b/R/estimation-cohort-method-attrition.R @@ -19,7 +19,7 @@ #' The module viewer for rendering the PLE attrition results #' #' @param id the unique reference id for the module -#' +#' @family {Estimation} #' @return #' The user interface to the cohort method attrition #' @@ -44,7 +44,7 @@ cohortMethodAttritionViewer <- function(id) { #' @param selectedRow the selected row from the main results table #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {Estimation} #' @return #' the PLE attrition results content server #' diff --git a/R/cohort-method-covariateBalance.R b/R/estimation-cohort-method-covariateBalance.R similarity index 91% rename from R/cohort-method-covariateBalance.R rename to R/estimation-cohort-method-covariateBalance.R index b3927b79..70410569 100644 --- a/R/cohort-method-covariateBalance.R +++ b/R/estimation-cohort-method-covariateBalance.R @@ -20,7 +20,7 @@ #' The module viewer for rendering the PLE covariate balance analysis #' #' @param id the unique reference id for the module -#' +#' @family {Estimation} #' @return #' The user interface to the cohort method covariate balance results #' @@ -75,7 +75,7 @@ cohortMethodCovariateBalanceViewer <- function(id) { #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes #' @param metaAnalysisDbIds metaAnalysisDbIds -#' +#' @family {Estimation} #' @return #' the PLE covariate balance content server #' @@ -85,7 +85,8 @@ cohortMethodCovariateBalanceServer <- function( selectedRow, connectionHandler, resultDatabaseSettings, - metaAnalysisDbIds = NULL) { + metaAnalysisDbIds = NULL + ) { shiny::moduleServer( id, @@ -96,35 +97,6 @@ cohortMethodCovariateBalanceServer <- function( resultDatabaseSettings ) - # input selection component -- could be added later if desired - # inputSelectedResults <- inputSelectionServer( - # id = "input-selection-results", - # inputSettingList = list( - # createInputSetting( - # rowNumber = 1, - # columnWidth = 12, - # varName = 'covariateAnalysisId', - # uiFunction = 'shinyWidgets::pickerInput', - # updateFunction = 'shinyWidgets::updatePickerInput', - # uiInputs = list( - # label = 'Covariate Analysis Name: ', - # choices = options$covariateAnalysisId, - # selected = options$covariateAnalysisId, # - # multiple = T, - # options = shinyWidgets::pickerOptions( - # actionsBox = TRUE, - # liveSearch = TRUE, - # size = 10, - # liveSearchStyle = "contains", - # liveSearchPlaceholder = "Type here to search", - # virtualScroll = 50 - # ) - # ) - # ) - # ) - # ) - - balance <- shiny::reactive({ row <- selectedRow() if(is.null(row$targetId)){ @@ -137,9 +109,6 @@ cohortMethodCovariateBalanceServer <- function( targetId = row$targetId, comparatorId = row$comparatorId, databaseId = row$databaseId, - # covariateAnalysisId = ifelse(is.null(inputSelectedResults()$covariateAnalysisId), - # -1, - # inputSelectedResults()$covariateAnalysisId), analysisId = row$analysisId)}, error = function(e){return(data.frame())} ) @@ -299,8 +268,8 @@ cohortMethodCovariateBalanceServer <- function( dbNames <- getDatabaseName(connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings) comb <- dplyr::inner_join(balance, dbNames) %>% - dplyr::relocate(cdmSourceAbbreviation, .after = databaseId) %>% - dplyr::select(-c(databaseId)) + dplyr::relocate("cdmSourceAbbreviation", .after = "databaseId") %>% + dplyr::select(-c("databaseId")) } ) @@ -322,11 +291,6 @@ cohortMethodCovariateBalanceServer <- function( resultTableServer( id = "balanceTable", df = renderBalanceTable, - # selectedCols = c("cdmSourceAbbreviation", "targetName", "targetIdShort", "outcomeName", "outcomeIdShort", - # "ageGroupName", "genderName", "startYear", "tar", "outcomes", - # "incidenceProportionP100p", "incidenceRateP100py"), - # sortedCols = c("ageGroupName", "genderName", "startYear", "incidenceRateP100py"), - # elementId = "incidence-select", colDefsInput = cmBalanceColList, downloadedFileName = "covariateBalanceTable-" ) @@ -490,7 +454,7 @@ plotCohortMethodCovariateBalanceScatterPlotNew <- function( x1 = limits[2], xref = "paper", y0 = 0, - y1 = limits[2], + y1 = limits[2], line = list(color = color, dash = 'dash') ) } @@ -504,7 +468,17 @@ plotCohortMethodCovariateBalanceScatterPlotNew <- function( colors = colors ) %>% plotly::layout( - shapes = list(xyline(limits)), + #shapes = list(xyline(limits)), + shapes = list(list( + type = "line", + x0 = 0, + x1 = ~max(absBeforeMatchingStdDiff, absAfterMatchingStdDiff), + xref = "x", + y0 = 0, + y1 = ~max(absBeforeMatchingStdDiff, absAfterMatchingStdDiff), + yref = "y", + line = list(color = "grey", dash = "dash") + )), plot_bgcolor = "#e5ecf6", xaxis = list(title = beforeLabel, range = limits), yaxis = list(title = afterLabel, range = limits) @@ -533,8 +507,8 @@ plotCohortMethodCovariateBalanceSummary <- function(balanceSummary, upper = .data$upper, ymax = .data$ymax, group = .data$databaseId)) + - ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymin, ymax = .data$ymin), size = 1) + - ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymax, ymax = .data$ymax), size = 1) + + ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymin, ymax = .data$ymin), linewidth = 1) + + ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymax, ymax = .data$ymax), linewidth = 1) + ggplot2::geom_boxplot(stat = "identity", fill = grDevices::rgb(0, 0, 0.8, alpha = 0.25), size = 1) + ggplot2::geom_hline(yintercept = 0) + ggplot2::scale_x_continuous(limits = c(0.5, max(vizData$x) + 1.75)) + diff --git a/R/estimation-cohort-method-diagnostics.R b/R/estimation-cohort-method-diagnostics.R new file mode 100644 index 00000000..56430cf2 --- /dev/null +++ b/R/estimation-cohort-method-diagnostics.R @@ -0,0 +1,264 @@ +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)} + ; + " + print(comparatorIds) + + 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 = ifelse(is.null(comparatorIds), F, 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("summaryValue", .after = "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/cohort-method-full-result.R b/R/estimation-cohort-method-full-result.R similarity index 93% rename from R/cohort-method-full-result.R rename to R/estimation-cohort-method-full-result.R index 2c05c501..7f4631cd 100644 --- a/R/cohort-method-full-result.R +++ b/R/estimation-cohort-method-full-result.R @@ -1,4 +1,4 @@ -cohortMethodFullResultViewer <- function(id) { +estimationCmFullResultViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -49,7 +49,7 @@ cohortMethodFullResultViewer <- function(id) { } -cohortMethodFullResultServer <- function( +estimationCmFullResultServer <- function( id, connectionHandler, resultDatabaseSettings, @@ -76,11 +76,11 @@ cohortMethodFullResultServer <- function( "cdmSourceAbbreviation" ) %>% dplyr::rename( - 'Target' = .data$target, - 'Comparator' = .data$comparator, - 'Outcome' = .data$outcome, - 'Analysis' = .data$description, - 'Database' = .data$cdmSourceAbbreviation + Target = "target", + Comparator = "comparator", + Outcome = "outcome", + Analysis = "description", + Database = "cdmSourceAbbreviation" ) }) diff --git a/R/cohort-method-kaplainMeier.R b/R/estimation-cohort-method-kaplainMeier.R similarity index 99% rename from R/cohort-method-kaplainMeier.R rename to R/estimation-cohort-method-kaplainMeier.R index 87906c13..9f8bbf0d 100644 --- a/R/cohort-method-kaplainMeier.R +++ b/R/estimation-cohort-method-kaplainMeier.R @@ -20,7 +20,7 @@ #' The module viewer for rendering the PLE Kaplan Meier curve #' #' @param id the unique reference id for the module -#' +#' @family {Estimation} #' @return #' The module viewer for Kaplan Meier objects #' @@ -45,7 +45,7 @@ cohortMethodKaplanMeierViewer <- function(id) { #' @param selectedRow the selected row from the main results table #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {Estimation} #' @return #' the PLE Kaplain Meier content server #' diff --git a/R/estimation-cohort-method-plots.R b/R/estimation-cohort-method-plots.R new file mode 100644 index 00000000..314a9c93 --- /dev/null +++ b/R/estimation-cohort-method-plots.R @@ -0,0 +1,156 @@ +estimationCmPlotsViewer <- function(id=1) { + ns <- shiny::NS(id) + shinyWidgets::addSpinner( + shiny::plotOutput(ns('esCohortMethodPlot')), + spin = 'rotating-plane' + ) +} + + +estimationCmPlotsServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1), + cmData +) { + shiny::moduleServer( + id, + function(input, output, session) { + + height <- shiny::reactive({ + if(is.null(cmData()$target)){ + return(100) + } + length(unique(cmData()$target))*250 + 250 + }) + + output$esCohortMethodPlot <- shiny::renderPlot( + estimationCreateCmPlot( + data = cmData + ), + height = height + ) + + } + ) +} + +estimationCreateCmPlot <- function(data) { + data <- data() + if(nrow(data) == 0){ + shiny::showNotification('No results to plot') + return(NULL) + } + data <- data[!is.na(data$calibratedRr),] + if(nrow(data) == 0){ + shiny::showNotification('No results to plot') + return(NULL) + } + data$database <- data$cdmSourceAbbreviation + + if(is.null(data$comparator)){ + shiny::showNotification('No results to plot') + return(NULL) + } + + + renameDf <- data.frame( + shortName = paste0( + 1:length(unique(data$comparator)), + ') ', + substring(sort(unique(data$comparator)), 1,50), + '...' + ), + comparator = sort(unique(data$comparator)) + ) + + + data <- merge( + data, + renameDf, + 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) + + ### Add table above the graph + renameDf$comparator <- sapply( + strwrap(renameDf$comparator, width = 150, 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 + ) + plotList <- list(tbl) # adding table first + + for(target in unique(data$target)){ # per targets + + title <- sprintf("%s", target) + plotList[[length(plotList) + 1]] <- ggplot2::ggplot( + data = data %>% dplyr::filter(.data$target == !!target), + ggplot2::aes(x = .data$calibratedRr, y = .data$shortName)) + + 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 %>% dplyr::filter(.data$target == !!target), + 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" + ) + } + + plot <- do.call( + gridExtra::grid.arrange, + list(grobs = plotList, ncol =1) + ) + + return(plot) +} diff --git a/R/cohort-method-populationCharacteristics.R b/R/estimation-cohort-method-populationCharacteristics.R similarity index 98% rename from R/cohort-method-populationCharacteristics.R rename to R/estimation-cohort-method-populationCharacteristics.R index c37cde83..c87a934f 100644 --- a/R/cohort-method-populationCharacteristics.R +++ b/R/estimation-cohort-method-populationCharacteristics.R @@ -20,7 +20,7 @@ #' The module viewer for rendering the PLE population characteristics #' #' @param id the unique reference id for the module -#' +#' @family {Estimation} #' @return #' The user interface to the cohort method population characteristics objects #' @@ -41,7 +41,7 @@ cohortMethodPopulationCharacteristicsViewer <- function(id) { #' @param selectedRow the selected row from the main results table #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {Estimation} #' @return #' the PLE population characteristics content server #' @@ -149,7 +149,8 @@ cohortMethodPopulationCharacteristicsServer <- function( digits = 2 ), sortable = F - ) + ), + label = reactable::colDef(show = T) ) ) @@ -251,7 +252,7 @@ getCohortMethodPopChar <- function( .data$covariateName ) - # remove text before covariateNames + # remove text before covariateNames - TODO generalize this? txtRms <- c( 'age group: ', 'condition_era group during day -365 through 0 days relative to index: ', @@ -260,7 +261,7 @@ getCohortMethodPopChar <- function( for(txtRm in txtRms){ result$covariateName <- gsub(txtRm,'', result$covariateName) } - + return( result ) diff --git a/R/cohort-method-power.R b/R/estimation-cohort-method-power.R similarity index 98% rename from R/cohort-method-power.R rename to R/estimation-cohort-method-power.R index aa57bf91..2acec47c 100644 --- a/R/cohort-method-power.R +++ b/R/estimation-cohort-method-power.R @@ -20,7 +20,7 @@ #' The module viewer for rendering the PLE power analysis #' #' @param id the unique reference id for the module -#' +#' @family {Estimation} #' @return #' The user interface to the cohort method power calculation results #' @@ -44,7 +44,7 @@ cohortMethodPowerViewer <- function(id) { #' @param selectedRow the selected row from the main results table #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {Estimation} #' @return #' the PLE systematic error power server #' @@ -177,11 +177,7 @@ prepareCohortMethodPowerTable <- function( connectionHandler , resultDatabaseSettings ) { - #analyses <- getCohortMethodAnalyses( - # connectionHandler = connectionHandler, - # resultDatabaseSettings = resultDatabaseSettings - #) - #table <- merge(mainResults, analyses) + table <- mainResults alpha <- 0.05 power <- 0.8 diff --git a/R/cohort-method-propensityModel.R b/R/estimation-cohort-method-propensityModel.R similarity index 98% rename from R/cohort-method-propensityModel.R rename to R/estimation-cohort-method-propensityModel.R index 53877b20..9cc201bc 100644 --- a/R/cohort-method-propensityModel.R +++ b/R/estimation-cohort-method-propensityModel.R @@ -20,7 +20,7 @@ #' The module viewer for rendering the PLE propensity score model covariates/coefficients #' #' @param id the unique reference id for the module -#' +#' @family {Estimation} #' @return #' The user interface to the cohort method propensity score model covariates/coefficients #' @@ -42,7 +42,7 @@ cohortMethodPropensityModelViewer <- function(id) { #' @param selectedRow the selected row from the main results table #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {Estimation} #' @return #' the PLE propensity score model #' diff --git a/R/cohort-method-propensityScoreDistribution.R b/R/estimation-cohort-method-propensityScoreDistribution.R similarity index 99% rename from R/cohort-method-propensityScoreDistribution.R rename to R/estimation-cohort-method-propensityScoreDistribution.R index 08ae4384..7a5eb204 100644 --- a/R/cohort-method-propensityScoreDistribution.R +++ b/R/estimation-cohort-method-propensityScoreDistribution.R @@ -20,7 +20,7 @@ #' The module viewer for rendering the propensity score distribution #' #' @param id the unique reference id for the module -#' +#' @family {Estimation} #' @return #' The user interface to the cohort method propensity score distribution #' @@ -49,7 +49,7 @@ cohortMethodPropensityScoreDistViewer <- function(id) { #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes #' @param metaAnalysisDbIds metaAnalysisDbIds -#' +#' @family {Estimation} #' @return #' the PLE propensity score distribution content server #' diff --git a/R/cohort-method-resultSummary.R b/R/estimation-cohort-method-results.R similarity index 62% rename from R/cohort-method-resultSummary.R rename to R/estimation-cohort-method-results.R index 4e8ea8df..499a9a73 100644 --- a/R/cohort-method-resultSummary.R +++ b/R/estimation-cohort-method-results.R @@ -17,15 +17,7 @@ # limitations under the License. -#' The module viewer for rendering the cohort method results -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the cohort method diagnostics viewer -#' -#' @export -cohortMethodResultSummaryViewer <- function(id) { +estimationCmResultsViewer <- function(id) { ns <- shiny::NS(id) shiny::tabsetPanel( @@ -34,13 +26,7 @@ cohortMethodResultSummaryViewer <- function(id) { shiny::tabPanel( title = "Table", - #shinydashboard::box( - # status = 'info', - # width = '100%', - # title = shiny::span('Result Summary'), - # solidHeader = TRUE, - resultTableViewer(ns("resultSummaryTable")) - # ) + resultTableViewer(ns("resultSummaryTable")) ), shiny::tabPanel( @@ -51,7 +37,7 @@ cohortMethodResultSummaryViewer <- function(id) { shiny::icon("arrow-left"), style="color: #fff; background-color: #337ab7; border-color: #2e6da4" ), - cohortMethodFullResultViewer(ns("cmFullResults")) + estimationCmFullResultViewer(ns("cmFullResults")) ) ) @@ -60,22 +46,13 @@ cohortMethodResultSummaryViewer <- function(id) { } -#' The module server for rendering the PLE diagnostics summary -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the PLE results database -#' @param resultDatabaseSettings a list containing the result schema and prefixes -#' @param inputSelected The target id, comparator id, outcome id and analysis id selected by the user -#' -#' @return -#' the PLE diagnostics summary results -#' -#' @export -cohortMethodResultSummaryServer <- function( +estimationCmResultsServer <- function( id, connectionHandler, resultDatabaseSettings, - inputSelected + targetIds, + comparatorIds, + outcomeId ) { shiny::moduleServer( @@ -88,43 +65,67 @@ cohortMethodResultSummaryServer <- function( shiny::updateTabsetPanel(session, "resultPanel", selected = "Table") }) - data <- shiny::reactive({ - getCmResultData( - connectionHandler, + # extract results from CM tables + cmData <- shiny::reactive({ + estimationGetCmResultData( + connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - inputSelected = inputSelected + 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 = getCmResultSummaryTableColDef(), - addActions = c('results') + colDefsInput = estimationGetCmResultSummaryTableColDef(), + addActions = c('results') # TODO wont work for esData ) selectedRow <- shiny::reactiveVal(value = NULL) shiny::observeEvent(resultTableOutputs$actionCount(), { - if(resultTableOutputs$actionType() == 'results'){ + if(resultTableOutputs$actionType() == 'results'){ # add an and here to only work for cmData selectedRow(data()[resultTableOutputs$actionIndex()$index,]) shiny::updateTabsetPanel(session, "resultPanel", selected = "Results") } }) - cohortMethodFullResultServer( + estimationCmFullResultServer( id = "cmFullResults", connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, selectedRow = selectedRow, actionCount = resultTableOutputs$actionCount ) + + + return(data) } ) } -getCmResultSummaryTableColDef <- function(){ +estimationGetCmResultSummaryTableColDef <- function(){ result <- list( analysisId = reactable::colDef(show = F), @@ -144,7 +145,12 @@ getCmResultSummaryTableColDef <- function(){ ) ), - targetId = reactable::colDef(show = F), + targetId = reactable::colDef(header = withTooltip( + "Target ID", + "The ID of the target cohort of interest" + ) + ), + target = reactable::colDef( header = withTooltip( "Target", @@ -153,7 +159,12 @@ getCmResultSummaryTableColDef <- function(){ minWidth = 300 ), - comparatorId = reactable::colDef(show = F), + comparatorId = reactable::colDef(header = withTooltip( + "Comparator ID", + "The ID of the comparator cohort of interest" + ) + ), + comparator = reactable::colDef( header = withTooltip( "Comparator", @@ -162,7 +173,12 @@ getCmResultSummaryTableColDef <- function(){ minWidth = 300 ), - outcomeId = reactable::colDef(show = F), + outcomeId = reactable::colDef(header = withTooltip( + "Outcome ID", + "The ID of the outcome of interest" + ) + ), + outcome = reactable::colDef( header = withTooltip( "Outcome", @@ -260,21 +276,24 @@ getCmResultSummaryTableColDef <- function(){ return(result) } -getCmResultData <- function( +estimationGetCmResultData <- function( connectionHandler, resultDatabaseSettings, - inputSelected + targetIds, + comparatorIds, + outcomeId, + runEvidenceSynthesis = F ) { - targetIds = inputSelected()$targetIds - outcomeIds = inputSelected()$outcomeIds - comparatorIds = inputSelected()$comparatorIds - analysisIds = inputSelected()$analysisIds + targetIds = targetIds() + comparatorIds = comparatorIds() + outcomeId = outcomeId() - if(is.null(comparatorIds) || is.null(targetIds) || is.null(outcomeIds) || is.null(analysisIds)){ + if(is.null(comparatorIds) || is.null(targetIds) || is.null(outcomeId) ){ return(NULL) } + sql <- " SELECT cma.analysis_id, @@ -333,7 +352,6 @@ FROM where cmr.target_id in (@targets) {@use_comparators}?{and cmr.comparator_id in (@comparators)} and cmr.outcome_id in (@outcomes) - {@use_analyses}?{and cmr.analysis_id in (@analyses)} ; " @@ -346,14 +364,148 @@ FROM targets = paste0(targetIds, collapse = ','), comparators = paste0(comparatorIds, collapse = ','), - outcomes = paste0(outcomeIds, collapse = ','), - analyses = paste0(analysisIds, collapse = ','), - + outcomes = paste0(outcomeId, collapse = ','), use_comparators = !is.null(comparatorIds), - use_analyses = !is.null(analysisIds) ) 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)) +} + + +# Function to format results +# used by both cm and sccs +computeTraditionalP <- function( + logRr, + seLogRr, + twoSided = TRUE, + upper = TRUE +) +{ + z <- logRr/seLogRr + + pUpperBound <- 1 - stats::pnorm(z) + pLowerBound <- stats::pnorm(z) + + if (twoSided) { + return(2 * pmin(pUpperBound, pLowerBound)) + } + else if (upper) { + return(pUpperBound) + } + else { + return(pLowerBound) + } +} diff --git a/R/cohort-method-systematicError.R b/R/estimation-cohort-method-systematicError.R similarity index 99% rename from R/cohort-method-systematicError.R rename to R/estimation-cohort-method-systematicError.R index cc89cafb..fa1ce54d 100644 --- a/R/cohort-method-systematicError.R +++ b/R/estimation-cohort-method-systematicError.R @@ -20,7 +20,7 @@ #' The module viewer for rendering the PLE systematic error objects #' #' @param id the unique reference id for the module -#' +#' @family {Estimation} #' @return #' The user interface to the cohort method systematic error module #' @@ -52,7 +52,7 @@ cohortMethodSystematicErrorViewer <- function(id) { #' @param selectedRow the selected row from the main results table #' @param connectionHandler the connection handler to the result databases #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {Estimation} #' @return #' the PLE systematic error content server #' diff --git a/R/estimation-main.R b/R/estimation-main.R new file mode 100644 index 00000000..21bb7bd4 --- /dev/null +++ b/R/estimation-main.R @@ -0,0 +1,414 @@ +# @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 +#' @family {Estimation} +#' @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 +#' @family {Estimation} +#' @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 + + shiny::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 +#' @family {Estimation} +#' @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"), + c("SCCS", "estimationSccsPlotsViewer", "estimationSccsPlots", "resultsPanel", "SCCS Plot") + ) + 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 <- getTandOs( + connectionHandler, + resultDatabaseSettings, + includeCharacterization = F, + includeCohortIncidence = F, + includeCohortMethod = "Cohort Method" %in% estimationTypes, + includePrediction = F, + includeSccs = "SCCS" %in% estimationTypes # 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]] + outcomes <- shiny::reactiveVal(outcomeDf) + initialOutcomes <- outcomeDf$outcomeId + names(initialOutcomes ) <- outcomeDf$outcomeName + + 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(outcomes()$outcomeId)>0){ + outcomesVector <- outcomes()$outcomeId + names(outcomesVector) <- outcomes()$outcomeName + + shinyWidgets::updatePickerInput( + session = session, + inputId = 'outcomeId', + label = 'Outcome: ', + choices = outcomesVector, + selected = outcomesVector[1] + ) + } + }) + # end observed targetId + + output$targetSelection <- shiny::renderUI({ + shiny::fluidRow( + shiny::div( + shinyWidgets::pickerInput( + inputId = session$ns('targetId'), + label = 'Target: ', + choices = targets, + selected = targets[1], + multiple = FALSE, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + dropupAuto = F, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 500 + ) + ), + shinyWidgets::pickerInput( + inputId = session$ns('outcomeId'), + label = 'Outcome: ', + choices = initialOutcomes, + selected = initialOutcomes[1], + multiple = FALSE, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + dropupAuto = F, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 500 + ) + ), + style = 'margin-left: 2%; width: 78%; display: inline-block; vertical-align: middle;' + ), + shiny::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(NULL) + comparatorIds <- shiny::reactiveVal(NULL) + targetIds <- shiny::reactiveVal(NULL) + outcomeId <- shiny::reactiveVal(NULL) + + 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 + #======================================= + if('Cohort Method' %in% estimationTypes){ + 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 + ) + } + + if('SCCS' %in% estimationTypes){ + estimationSccsDiagnosticServer( + id = 'estimationSccsDiagnostic', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + outcomeId = outcomeId + ) + + sccsData <- estimationSccsResultsServer( + id = 'estimationSccsResults', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + outcomeId = outcomeId + ) + + estimationSccsPlotsServer( + id = 'estimationSccsPlots', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + sccsData = sccsData + ) + } + + } + ) +} + + + + +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, + 'cm_result' + ) %in% tbls || + paste0( + resultDatabaseSettings$esTablePrefix, + 'sccs_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..81a5fe06 --- /dev/null +++ b/R/estimation-sccs-diagnostics.R @@ -0,0 +1,261 @@ +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("summaryValue", .after = "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 " + ) + ), + indication = reactable::colDef( + header = withTooltip( + "Indication", + "The indication 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-plots.R b/R/estimation-sccs-plots.R new file mode 100644 index 00000000..aad17c61 --- /dev/null +++ b/R/estimation-sccs-plots.R @@ -0,0 +1,163 @@ +estimationSccsPlotsViewer <- function(id=1) { + ns <- shiny::NS(id) + shinyWidgets::addSpinner( + output = shiny::plotOutput(ns('esSccsPlot')), + spin = 'rotating-plane' + ) +} + + +estimationSccsPlotsServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1), + sccsData +) { + shiny::moduleServer( + id, + function(input, output, session) { + + height <- shiny::reactive({ + if(is.null(sccsData()$indication)){ + return(100) + } + length(unique(sccsData()$indication))*200 + 200 + }) + + output$esSccsPlot <- shiny::renderPlot( + estimationCreateSccsPlot( + data = sccsData + ), + height = height + ) + + } + ) +} + +estimationCreateSccsPlot <- function(data) { + data <- data() + if(nrow(data) == 0){ + shiny::showNotification('No results to plot') + return(NULL) + } + data <- data[!is.na(data$calibratedRr),] + if(nrow(data) == 0){ + shiny::showNotification('No results to plot') + return(NULL) + } + data$database <- data$databaseName + data$type <- data$covariateName + data$indication[is.null(data$indication)] <- 'no indication' + data$indication[is.na(data$indication)] <- 'no indication' + + if(is.null(data)){ + shiny::showNotification('No results to plot') + return(NULL) + } + if(nrow(data) == 0){ + shiny::showNotification('No results to plot') + 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 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) + + # TODO loop over target-indications pairs + + ### Add table above 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 + ) + plotList <- list(tbl) # adding table first + + for(indication in unique(data$indication)){ # TODO do indication + target combo? + plotList[[length(plotList)+1]] <- ggplot2::ggplot( + data = data %>% dplyr::filter(.data$indication == !!indication), #restrict to indication + 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 %>% dplyr::filter(.data$indication == !!indication), + 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(indication) + + 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" + ) +} + + plot <- do.call( + gridExtra::grid.arrange, + list(grobs = plotList, ncol =1) + ) + + return(plot) +} diff --git a/R/sccs-results-full.R b/R/estimation-sccs-results-full.R similarity index 51% rename from R/sccs-results-full.R rename to R/estimation-sccs-results-full.R index 279349d8..f7977f29 100644 --- a/R/sccs-results-full.R +++ b/R/estimation-sccs-results-full.R @@ -1,4 +1,4 @@ -sccsFullResultViewer <- function(id) { +estimationSccsFullResultViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -16,11 +16,15 @@ sccsFullResultViewer <- function(id) { 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')) + shinyWidgets::addSpinner( + resultTableViewer(ns('powerTable')) + ) ), shiny::tabPanel( "Attrition", - shiny::plotOutput(ns("attritionPlot"), width = 600, height = 500), + shinyWidgets::addSpinner( + 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.") @@ -39,17 +43,23 @@ sccsFullResultViewer <- function(id) { ), shiny::tabPanel( "Age spline", - shiny::plotOutput(ns("ageSplinePlot")), + shinyWidgets::addSpinner( + shiny::plotOutput(ns("ageSplinePlot")) + ), shiny::div(shiny::strong("Figure 2a."), "Spline fitted for age.") ), shiny::tabPanel( "Season spline", - shiny::plotOutput(ns("seasonSplinePlot")), + shinyWidgets::addSpinner( + shiny::plotOutput(ns("seasonSplinePlot")) + ), shiny::div(shiny::strong("Figure 2b."), "Spline fitted for season") ), shiny::tabPanel( "Calendar time spline", - shiny::plotOutput(ns("calendarTimeSplinePlot")), + shinyWidgets::addSpinner( + shiny::plotOutput(ns("calendarTimeSplinePlot")) + ), shiny::div(shiny::strong("Figure 2c."), "Spline fitted for calendar time") ) ) @@ -57,12 +67,16 @@ sccsFullResultViewer <- function(id) { shiny::tabPanel( "Spanning", shiny::radioButtons(ns("spanningType"), label = "Type:", choices = c("Age", "Calendar time")), - shiny::plotOutput(ns("spanningPlot")), + shinyWidgets::addSpinner( + 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), + shinyWidgets::addSpinner( + 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)." @@ -70,7 +84,9 @@ sccsFullResultViewer <- function(id) { ), shiny::tabPanel( "Time to event", - shiny::plotOutput(ns("timeToEventPlot")), + shinyWidgets::addSpinner( + 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)." @@ -78,13 +94,17 @@ sccsFullResultViewer <- function(id) { ), shiny::tabPanel( "Event dep. observation", - shiny::plotOutput(ns("eventDepObservationPlot")), + shinyWidgets::addSpinner( + 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")), + shinyWidgets::addSpinner( + 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 @@ -97,7 +117,7 @@ sccsFullResultViewer <- function(id) { } -sccsFullResultServer <- function( +estimationSccsFullResultServer <- function( id, connectionHandler, resultDatabaseSettings, @@ -114,18 +134,21 @@ sccsFullResultServer <- function( shiny::updateTabsetPanel(session, "fullTabsetPanel", selected = "Power") }) + # show what was selected modifiedRow <- shiny::reactive({ selectedRow() %>% dplyr::select( "covariateName", + 'indication', "outcome", "description", "databaseName" ) %>% dplyr::rename( - 'Outcome' = .data$outcome, - 'Analysis' = .data$description, - 'Database' = .data$databaseName + Indication = "indication", + Outcome = "outcome", + Analysis = "description", + Database = "databaseName" ) }) @@ -218,13 +241,13 @@ sccsFullResultServer <- function( if (is.null(row)) { return(NULL) } else { - attrition <- getSccsAttrition( + attrition <- estimationGetSccsAttrition( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, databaseId = row$databaseId, analysisId = row$analysisId, - covariateId = row$covariateId + covariateId = row$covariateId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId ) drawAttritionDiagram(attrition) } @@ -235,11 +258,11 @@ sccsFullResultServer <- function( if (is.null(row)) { return(NULL) } else { - resTargetTable <- getSccsModel( + resTargetTable <- estimationGetSccsModel( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, exposureId = row$eraId, - outcomeId = row$outcomeId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId, databaseId = row$databaseId, analysisId = row$analysisId ) @@ -261,11 +284,11 @@ sccsFullResultServer <- function( if (is.null(row)) { return(NULL) } else { - timeTrend <- getSccsTimeTrend( + timeTrend <- estimationGetSccsTimeTrend( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, exposureId = row$eraId, - outcomeId = row$outcomeId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId, databaseId = row$databaseId, analysisId = row$analysisId ) @@ -283,10 +306,10 @@ sccsFullResultServer <- function( if (is.null(row)) { return(NULL) } else { - timeToEvent <- getSccsTimeToEvent( + timeToEvent <- estimationGetSccsTimeToEvent( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId, exposureId = row$eraId, covariateId = row$covariateId, databaseId = row$databaseId, @@ -301,10 +324,10 @@ sccsFullResultServer <- function( if (is.null(row)) { return(NULL) } else { - eventDepObservation <- getSccsEventDepObservation( + eventDepObservation <- estimationGetSccsEventDepObservation( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId, databaseId = row$databaseId, analysisId = row$analysisId ) @@ -318,19 +341,19 @@ sccsFullResultServer <- function( return(NULL) } else { if (input$spanningType == "Age") { - ageSpanning <- getSccsAgeSpanning( + ageSpanning <- estimationGetSccsAgeSpanning( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId, databaseId = row$databaseId, analysisId = row$analysisId ) plotSpanning(ageSpanning, type = "age") } else { - calendarTimeSpanning <- getSccsCalendarTimeSpanning( + calendarTimeSpanning <- estimationGetSccsCalendarTimeSpanning( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId, databaseId = row$databaseId, analysisId = row$analysisId ) @@ -345,10 +368,10 @@ sccsFullResultServer <- function( if (is.null(row)) { return(NULL) } else { - ageSpline <- getSccsSpline( + ageSpline <- estimationGetSccsSpline( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId, databaseId = row$databaseId, analysisId = row$analysisId, splineType = "age" @@ -365,10 +388,10 @@ sccsFullResultServer <- function( if (is.null(row)) { return(NULL) } else { - seasonSpline <- getSccsSpline( + seasonSpline <- estimationGetSccsSpline( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId, databaseId = row$databaseId, analysisId = row$analysisId, splineType = "season" @@ -385,10 +408,10 @@ sccsFullResultServer <- function( if (is.null(row)) { return(NULL) } else { - calendarTimeSpline <- getSccsSpline( + calendarTimeSpline <- estimationGetSccsSpline( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, + exposuresOutcomeSetId = row$exposuresOutcomeSetId, databaseId = row$databaseId, analysisId = row$analysisId, splineType = "calendar time" @@ -405,14 +428,18 @@ sccsFullResultServer <- function( if (is.null(row)) { return(NULL) } else { - controlEstimates <- getSccsControlEstimates( + controlEstimates <- estimationGetSccsControlEstimates( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, covariateId = row$covariateId, databaseId = row$databaseId, - analysisId = row$analysisId + analysisId = row$analysisId, + eraId = row$eraId ) - plotControlEstimates(controlEstimates) + plotControlEstimates( + controlEstimates = controlEstimates$plotResult, + ease = controlEstimates$ease + ) } }) @@ -421,7 +448,354 @@ sccsFullResultServer <- function( } +estimationGetSccsAttrition <- function( + connectionHandler, + resultDatabaseSettings, + databaseId, + analysisId, + covariateId, + exposuresOutcomeSetId +) { + sql <- " + SELECT * + FROM @schema.@sccs_table_prefixattrition + + WHERE database_id = '@database_id' + AND analysis_id = @analysis_id + AND exposures_outcome_set_id = @exposures_outcome_set_id + AND covariate_id = @covariate_id + " + connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + analysis_id = analysisId, + covariate_id = covariateId, + exposures_outcome_set_id = exposuresOutcomeSetId, + snakeCaseToCamelCase = TRUE + ) +} + + +estimationGetSccsModel <- function( + connectionHandler, + resultDatabaseSettings, + exposuresOutcomeSetId, + databaseId, + analysisId, + exposureId +) { + sql <- " + SELECT + CASE + WHEN era.era_name IS NULL THEN sc.covariate_name + ELSE CONCAT(sc.covariate_name, ' : ', era.era_name) + END as covariate_name, + scr.covariate_id, scr.rr, scr.ci_95_lb, scr.ci_95_ub + FROM @schema.@sccs_table_prefixcovariate_result scr + INNER JOIN @schema.@sccs_table_prefixcovariate sc ON ( + sc.exposures_outcome_set_id = scr.exposures_outcome_set_id AND + sc.database_id = scr.database_id AND + sc.analysis_id = scr.analysis_id AND + sc.covariate_id = scr.covariate_id + ) + LEFT JOIN @schema.@cg_table_prefixcohort_definition cd + ON cd.cohort_definition_id = sc.era_id + LEFT JOIN @schema.@sccs_table_prefixera era ON ( + era.exposures_outcome_set_id = scr.exposures_outcome_set_id AND + era.database_id = scr.database_id AND + era.analysis_id = scr.analysis_id AND + era.era_id = sc.era_id + ) + + WHERE scr.database_id = '@database_id' + AND scr.analysis_id = @analysis_id + --AND sc.era_id = @exposure_id + --AND scr.rr IS NOT NULL + AND scr.exposures_outcome_set_id = @exposures_outcome_set_id + " + + connectionHandler$queryDb(sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_id = databaseId, + analysis_id = analysisId, + exposure_id = exposureId, + exposures_outcome_set_id = exposuresOutcomeSetId, + snakeCaseToCamelCase = TRUE) +} + + +estimationGetSccsTimeTrend <- function( + connectionHandler, + resultDatabaseSettings, + exposureId, + exposuresOutcomeSetId, + databaseId, + analysisId +) { + sql <- " + SELECT * + FROM @schema.@sccs_table_prefixtime_trend + WHERE database_id = '@database_id' + AND analysis_id = @analysis_id + AND exposures_outcome_set_id = @exposures_outcome_set_id + " + connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + analysis_id = analysisId, + exposures_outcome_set_id = exposuresOutcomeSetId, + snakeCaseToCamelCase = TRUE + ) +} + +estimationGetSccsTimeToEvent <- function( + connectionHandler, + resultDatabaseSettings, + exposureId, + exposuresOutcomeSetId, + covariateId, + databaseId, + analysisId +) { + + sql <- " + SELECT pre_exposure_p + FROM @schema.@sccs_table_prefixdiagnostics_summary + + WHERE database_id = '@database_id' + AND covariate_id = @covariate_id + AND analysis_id = @analysis_id + AND exposures_outcome_set_id = @exposures_outcome_set_id + " + + p <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + analysis_id = analysisId, + exposures_outcome_set_id = exposuresOutcomeSetId, + covariate_id = covariateId, + snakeCaseToCamelCase = TRUE + ) + + # if NULL set to NA so code below works + if(is.null(p$preExposureP)){ + p$preExposureP <- NA + } + + sql <- " + SELECT * , @p as p + FROM @schema.@sccs_table_prefixtime_to_event + + WHERE database_id = '@database_id' + AND era_id = @exposure_id + AND analysis_id = @analysis_id + AND exposures_outcome_set_id = @exposures_outcome_set_id; + " + + timeToEvent <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + analysis_id = analysisId, + exposures_outcome_set_id = exposuresOutcomeSetId, + exposure_id = exposureId, + p = ifelse(is.na(p$preExposureP), -1, p$preExposureP), + snakeCaseToCamelCase = TRUE + ) + + + return(timeToEvent) +} + + +estimationGetSccsEventDepObservation <- function( + connectionHandler, + resultDatabaseSettings, + exposuresOutcomeSetId, + databaseId, + analysisId +) { + sql <- " + SELECT * + FROM @schema.@sccs_table_prefixevent_dep_observation + + WHERE database_id = '@database_id' + AND analysis_id = @analysis_id + AND exposures_outcome_set_id = @exposures_outcome_set_id; + " + connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + analysis_id = analysisId, + exposures_outcome_set_id = exposuresOutcomeSetId, + snakeCaseToCamelCase = TRUE + ) +} +estimationGetSccsAgeSpanning <- function( + connectionHandler, + resultDatabaseSettings, + exposuresOutcomeSetId, + databaseId, + analysisId +) { + sql <- " + SELECT * + FROM @schema.@sccs_table_prefixage_spanning + + WHERE database_id = '@database_id' + AND analysis_id = @analysis_id + AND exposures_outcome_set_id = @exposures_outcome_set_id + " + connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + analysis_id = analysisId, + exposures_outcome_set_id = exposuresOutcomeSetId, + snakeCaseToCamelCase = TRUE + ) +} +estimationGetSccsCalendarTimeSpanning <- function( + connectionHandler, + resultDatabaseSettings, + exposuresOutcomeSetId, + databaseId, + analysisId +) { + sql <- " + SELECT * + FROM @schema.@sccs_table_prefixcalendar_time_spanning + + WHERE database_id = '@database_id' + AND analysis_id = @analysis_id + AND exposures_outcome_set_id = @exposures_outcome_set_id + " + connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + analysis_id = analysisId, + exposures_outcome_set_id = exposuresOutcomeSetId, + snakeCaseToCamelCase = TRUE + ) +} +estimationGetSccsSpline <- function( + connectionHandler, + resultDatabaseSettings, + exposuresOutcomeSetId, + databaseId, + analysisId, + splineType = "age" +) { + + sql <- " + SELECT * + FROM @schema.@sccs_table_prefixspline + + WHERE database_id = '@database_id' + AND analysis_id = @analysis_id + AND exposures_outcome_set_id = @exposures_outcome_set_id + AND spline_type = '@spline_type'; + " + connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + spline_type = splineType, + analysis_id = analysisId, + exposures_outcome_set_id = exposuresOutcomeSetId, + snakeCaseToCamelCase = TRUE + ) +} + + + +estimationGetSccsControlEstimates <- function( + connectionHandler, + resultDatabaseSettings, + databaseId, + analysisId, + covariateId, + eraId +) { + + sql <- " + SELECT r.ci_95_lb, r.ci_95_ub, r.log_rr, r.se_log_rr, + r.calibrated_ci_95_lb, r.calibrated_ci_95_ub, r.calibrated_log_rr, + r.calibrated_se_log_rr, r.exposures_outcome_set_id, + e.true_effect_size, c.exposures_outcome_set_id + + FROM + @schema.@sccs_table_prefixresult r + INNER JOIN + @schema.@sccs_table_prefixexposure e + on r.exposures_outcome_set_id = e.exposures_outcome_set_id + + INNER JOIN + @schema.@sccs_table_prefixcovariate c + on e.era_id = c.era_id + and e.exposures_outcome_set_id = c.exposures_outcome_set_id + and c.database_id = r.database_id + and c.analysis_id = r.analysis_id + and c.covariate_id = r.covariate_id + + WHERE r.database_id = '@database_id' + AND r.analysis_id = @analysis_id + AND r.covariate_id = @covariate_id + AND e.true_effect_size is not NULL + -- AND e.era_id = @era_id + ; + " + + res <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + covariate_id = covariateId, + analysis_id = analysisId, + era_id = eraId, + snakeCaseToCamelCase = TRUE + ) + + # get ease for the plot + sql <- "SELECT top 1 ds.ease + FROM @schema.@sccs_table_prefixdiagnostics_summary ds + WHERE ds.database_id = '@database_id' + AND ds.analysis_id = @analysis_id + AND ds.covariate_id = @covariate_id;" + + ease <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_id = databaseId, + covariate_id = covariateId, + analysis_id = analysisId, + snakeCaseToCamelCase = TRUE + ) + + return(list( + plotResult = res, + ease = ease$ease + ) + ) +} diff --git a/R/sccs-results.R b/R/estimation-sccs-results.R similarity index 61% rename from R/sccs-results.R rename to R/estimation-sccs-results.R index 0f5b7e54..75fad592 100644 --- a/R/sccs-results.R +++ b/R/estimation-sccs-results.R @@ -1,4 +1,4 @@ -sccsResultsViewer <- function(id = "sccs-results") { +estimationSccsResultsViewer <- function(id = "sccs-results") { ns <- shiny::NS(id) shiny::tabsetPanel( @@ -8,18 +8,17 @@ sccsResultsViewer <- function(id = "sccs-results") { shiny::tabPanel( title = "Table", resultTableViewer(ns("resultSummaryTable")) - #) ), shiny::tabPanel( title = "Results", shiny::actionButton( - inputId = ns('goBackCmResults'), + inputId = ns('goBackSccsResults'), label = "Back To Result Summary", shiny::icon("arrow-left"), style="color: #fff; background-color: #337ab7; border-color: #2e6da4" ), - sccsFullResultViewer(ns("sccsFullResults")) + estimationSccsFullResultViewer(ns("sccsFullResults")) ) ) @@ -29,62 +28,67 @@ sccsResultsViewer <- function(id = "sccs-results") { } -sccsResultsServer <- function( +estimationSccsResultsServer <- function( id, connectionHandler, resultDatabaseSettings = list(port = 1), - inputSelected + targetIds, + outcomeId ) { ns <- shiny::NS(id) shiny::moduleServer(id, function(input, output, session) { shiny::observeEvent( - eventExpr = input$goBackCmResults, + eventExpr = input$goBackSccsResults, { shiny::updateTabsetPanel(session, "resultPanel", selected = "Table") } ) - data <- shiny::reactive({ - - exposure <- inputSelected()$exposure - if (is.character(exposure)) { - exposureGroup <- strsplit(exposure, " ")[[1]] - targetId <- exposureGroup[[1]] - indidcationId <- exposureGroup[[2]] - } else { - targetId <- -1 - indidcationId <- -1 - } - - getSccsResults( + sccsData <- shiny::reactive({ + estimationGetSccsResults( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - exposureIds = targetId, - outcomeIds = inputSelected()$outcome, - #databaseIds = inputSelected()$database, - analysisIds = inputSelected()$analysis, - indicationIds = indidcationId + exposureIds = targetIds, + outcomeIds = outcomeId ) }) + # add evidence synth if existsesData <- shiny::reactive({ + esData <- shiny::reactive({ + tryCatch( + { + estimationGetSccsEsResults( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + exposureIds = targetIds, + outcomeIds = outcomeId + ) + }, error = function(e){print('SCCS ES error');return(NULL)} + ) + }) + + data <- shiny::reactive({ + rbind(sccsData(), esData()) + }) + resultTableOutputs <- resultTableServer( id = "resultSummaryTable", df = data, - colDefsInput = getSccsResultSummaryTableColDef(), + colDefsInput = estimationGetSccsResultSummaryTableColDef(), addActions = c('results') ) selectedRow <- shiny::reactiveVal(value = NULL) shiny::observeEvent(resultTableOutputs$actionCount(), { - if(resultTableOutputs$actionType() == 'results'){ + if(resultTableOutputs$actionType() == 'results'){ # TODO only work if non meta selectedRow(data()[resultTableOutputs$actionIndex()$index,]) shiny::updateTabsetPanel(session, "resultPanel", selected = "Results") } }) - sccsFullResultServer( + estimationSccsFullResultServer( id = "sccsFullResults", connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, @@ -92,13 +96,14 @@ sccsResultsServer <- function( actionCount = resultTableOutputs$actionCount ) - + # return data for plot server + return(data) } ) } -getSccsResultSummaryTableColDef <- function(){ +estimationGetSccsResultSummaryTableColDef <- function(){ results <- list( @@ -108,6 +113,7 @@ getSccsResultSummaryTableColDef <- function(){ covariateAnalysisId = reactable::colDef(show = F), analysisId = reactable::colDef(show = F), outcomeId = reactable::colDef(show = F), + indicationId = reactable::colDef(show = F), outcomeSubjects = reactable::colDef(show = F), outcomeEvents = reactable::colDef(show = F), outcomeObservationPeriods = reactable::colDef(show = F), @@ -118,6 +124,7 @@ getSccsResultSummaryTableColDef <- function(){ observedDays = reactable::colDef(show = F), mdrr = reactable::colDef(show = F), unblind = reactable::colDef(show = F), + exposuresOutcomeSetId = reactable::colDef(show = F), logRr = reactable::colDef(show = F), seLogRr = reactable::colDef(show = F), @@ -139,6 +146,22 @@ getSccsResultSummaryTableColDef <- function(){ "Data source", "Data source" )), + target = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Target", + "Target Cohort" + ), + minWidth = 300 + ), + indication = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Indication", + "Target cohort is nested in this indication" + ), + minWidth = 300 + ), outcome = reactable::colDef( filterable = TRUE, header = withTooltip( @@ -216,18 +239,14 @@ getSccsResultSummaryTableColDef <- function(){ return(results) } -getSccsResults <- function(connectionHandler, +estimationGetSccsResults <- function(connectionHandler, resultDatabaseSettings, exposureIds, - outcomeIds, - #databaseIds, - analysisIds, - indicationIds = NULL) { - - if (any(indicationIds == -1)) { - indicationIds <- NULL - } - + outcomeIds + ) { + exposureIds <- exposureIds() + outcomeIds <- outcomeIds() + sql <- " SELECT @@ -241,7 +260,11 @@ getSccsResults <- function(connectionHandler, a.description, eos.outcome_id, cg1.cohort_name as outcome, - + cg2.cohort_name as target, + cg3.cohort_name as indication, + eos.nesting_cohort_id as indication_id, + eos.exposures_outcome_set_id, + sr.outcome_subjects, sr.outcome_events, sr.outcome_observation_periods, @@ -305,12 +328,19 @@ getSccsResults <- function(connectionHandler, inner join @schema.@cg_table_prefixcohort_definition cg1 on cg1.cohort_definition_id = eos.outcome_id + + inner join + @schema.@cg_table_prefixcohort_definition as cg2 + on cg2.cohort_definition_id = sc.era_id - WHERE sr.analysis_id IN (@analysis_ids) - -- AND sr.database_id IN (@database_ids) - AND eos.outcome_id IN (@outcome_ids) + left join + @schema.@cg_table_prefixcohort_definition as cg3 + on eos.nesting_cohort_id = cg3.cohort_definition_id + + WHERE + eos.outcome_id IN (@outcome_ids) AND sc.era_id IN (@exposure_ids) - {@use_indications} ? {and eos.nesting_cohort_id IN (@indication_ids)} : {and eos.nesting_cohort_id IS NULL} + ; " results <- connectionHandler$queryDb( @@ -320,12 +350,8 @@ getSccsResults <- function(connectionHandler, database_table = resultDatabaseSettings$databaseTable, sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - #database_ids = paste(quoteLiterals(databaseIds), collapse = ','), - analysis_ids = paste(analysisIds, collapse = ','), outcome_ids = paste(outcomeIds, collapse = ','), exposure_ids = paste(exposureIds, collapse = ','), - use_indications = !is.null(indicationIds), - indication_ids = indicationIds, snakeCaseToCamelCase = TRUE ) @@ -333,3 +359,114 @@ getSccsResults <- function(connectionHandler, } +estimationGetSccsEsResults <- function( + connectionHandler, + resultDatabaseSettings, + exposureIds, + outcomeIds +) { + + exposureIds <- exposureIds() + outcomeIds <- outcomeIds() + +sql <- "select distinct + ev.evidence_synthesis_description as database_name, + 0 as database_id, + cov.covariate_id, -- exists? + cov.covariate_name, + cov.era_id, + 0 as covariate_analysis_id, + esr.analysis_id, + a.description, + eos.outcome_id, + c3.cohort_name as outcome, + c1.cohort_name as target, + c4.cohort_name as indication, + eos.nesting_cohort_id as indication_id, + eos.exposures_outcome_set_id, + esr.outcome_subjects, + esr.outcome_events, + esr.outcome_observation_periods, + esr.covariate_subjects, + esr.covariate_days, + esr.covariate_eras, + esr.covariate_outcomes, + esr.observed_days, + esr.rr, + esr.ci_95_lb, + esr.ci_95_ub, + esr.p, + esr.log_rr, + esr.se_log_rr, + esr.calibrated_rr, + esr.calibrated_ci_95_lb, + esr.calibrated_ci_95_ub, + esr.calibrated_p, + esr.calibrated_log_rr, + esr.calibrated_se_log_rr, + NULL as llr, + esd.mdrr, + esd.unblind as unblind + + from + @schema.@es_table_prefixsccs_result as esr + inner join + @schema.@sccs_table_prefixexposures_outcome_set as eos + on + esr.exposures_outcome_set_id = eos.exposures_outcome_set_id + + inner join + @schema.@sccs_table_prefixcovariate as cov + on + esr.covariate_id = cov.covariate_id and + esr.analysis_id = cov.analysis_id and + esr.exposures_outcome_set_id = cov.exposures_outcome_set_id + + inner join + + @schema.@es_table_prefixsccs_diagnostics_summary as esd + on + esr.analysis_id = esd.analysis_id and + esr.exposures_outcome_set_id = esd.exposures_outcome_set_id and + esr.covariate_id = esd.covariate_id and + esr.evidence_synthesis_analysis_id = esd.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 = esr.analysis_id + + inner join + @schema.@es_table_prefixanalysis as ev + on ev.evidence_synthesis_analysis_id = esr.evidence_synthesis_analysis_id + + left join + @schema.@cg_table_prefixcohort_definition as c4 + on eos.nesting_cohort_id = c4.cohort_definition_id + + where + esr.calibrated_rr != 0 and + esd.unblind = 1 and + cov.era_id in (@target_ids) and + eos.outcome_id in (@outcome_id) + ;" + +result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + es_table_prefix = resultDatabaseSettings$esTablePrefix, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + outcome_id = paste0(outcomeIds, collapse = ','), + target_ids = paste0(exposureIds, collapse = ',') +) + +return(result) +} diff --git a/R/evidence-synth-cm.R b/R/evidence-synth-cm.R deleted file mode 100644 index ee61d549..00000000 --- a/R/evidence-synth-cm.R +++ /dev/null @@ -1,550 +0,0 @@ -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, - method = 'cm' - ) - ) - - 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 deleted file mode 100644 index 8394fb2f..00000000 --- a/R/evidence-synth-main.R +++ /dev/null @@ -1,332 +0,0 @@ -#' The location of the evidence synthesis module helper file -#' -#' @details -#' Returns the location of the evidence synthesis helper file -#' -#' @return -#' string location of the evidence synthesis helper file -#' -#' @export -evidenceSynthesisHelperFile <- function(){ - fileLoc <- system.file('evidence-synthesis-www', "evidence-synthesis.html", package = "OhdsiShinyModules") - return(fileLoc) -} - -#' The module viewer for exploring evidence-synthesis -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the evidence-synthesis viewer module -#' -#' @export -evidenceSynthesisViewer <- function(id=1) { - ns <- shiny::NS(id) - - shinydashboard::box( - status = 'info', - width = 12, - title = shiny::span( shiny::icon("sliders"), 'Evidence Synthesis'), - solidHeader = TRUE, - - - # add two buttons - CM or SCCs - shiny::tabsetPanel( - id = ns('typeTab'), - type = 'pills' - ) - - ) - -} - -checkSccsTablesPresent <- function(connectionHandler, resultDatabaseSettings) { - sql <- " - SELECT 1 as present FROM @schema.@sccs_table_prefixdiagnostics_summary; - " - present <- TRUE - tryCatch({ - connectionHandler$queryDb(sql = sql, - schema = resultDatabaseSettings$schema, - sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix) - }, error = function(...) { - present <<- FALSE - }) - - return(present) -} - -checkCmTablesPresent <- function(connectionHandler, resultDatabaseSettings) { - sql <- " - SELECT 1 as present FROM @schema.@cm_table_prefixdiagnostics_summary; - " - present <- TRUE - tryCatch({ - connectionHandler$queryDb(sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix) - }, error = function(...) { - present <<- FALSE - }) - - return(present) -} - -#' The module server for exploring PatientLevelPrediction -#' -#' @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 result schema and prefixes -#' -#' @return -#' The server for the PatientLevelPrediction module -#' -#' @export -evidenceSynthesisServer <- function( - id, - connectionHandler, - resultDatabaseSettings = list(port = 1) -) { - shiny::moduleServer( - id, - function(input, output, session) { - - showSccsResults <- checkSccsTablesPresent(connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings) - - showCmResults <- checkCmTablesPresent(connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings) - - if (showCmResults) { - shiny::insertTab( - inputId = "typeTab", - tab = - shiny::tabPanel( - title = 'Cohort Method', - evidenceSynthesisCmViewer(id = session$ns('cohortMethodTab')), - ), - select = TRUE - ) - - evidenceSynthesisCmServer( - id = 'cohortMethodTab', - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - } - - if (showSccsResults) { - shiny::insertTab( - inputId = "typeTab", - tab = shiny::tabPanel( - title = "Self Controlled Case Series", - evidenceSynthesisSccsViewer(id = session$ns('sccsTab')), - ), - select = !showCmResults - ) - - evidenceSynthesisSccsServer( - id = 'sccsTab', - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - } - } - ) -} - -# Function to get outcome ids -# used by both cm and sccs -getEsOutcomeIds <- function( - connectionHandler, - resultDatabaseSettings -) { - sql <- "select distinct - c1.cohort_name as outcome, - r.outcome_id - - 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.@cg_table_prefixcohort_definition as c1 - on c1.cohort_definition_id = r.outcome_id - - where - tco.outcome_of_interest = 1 - ;" - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix - ) - - output <- as.list(result$outcomeId) - names(output) <- result$outcome - - return(output) - -} - -# Function to format results -# used by both cm and sccs -computeTraditionalP <- function( - logRr, - seLogRr, - twoSided = TRUE, - upper = TRUE -) -{ - z <- logRr/seLogRr - - pUpperBound <- 1 - stats::pnorm(z) - pLowerBound <- stats::pnorm(z) - - if (twoSided) { - return(2 * pmin(pUpperBound, pLowerBound)) - } - else if (upper) { - return(pUpperBound) - } - else { - return(pLowerBound) - } -} - - - -# Functions to get column formatting and names -# used by both cm and sccs -getOACcombinations <- function( - connectionHandler, - resultDatabaseSettings, - method -){ - - if(method == 'cm'){ - sql <- "SELECT DISTINCT - CONCAT(cma.description, '_', cgcd2.cohort_name) as col_names - FROM - @schema.@cm_table_prefixdiagnostics_summary cmds - INNER JOIN @schema.@cm_table_prefixanalysis cma - ON cmds.analysis_id = cma.analysis_id - INNER JOIN @schema.@cg_table_prefixcohort_definition cgcd2 - ON cmds.comparator_id = cgcd2.cohort_definition_id - ;" - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix - ) - } - - if(method == 'sccs'){ - sql <- "SELECT distinct - CONCAT(a.description, '_', cov.covariate_name) as col_names - - FROM @schema.@sccs_table_prefixdiagnostics_summary ds - - INNER JOIN - @schema.@sccs_table_prefixanalysis a - on a.analysis_id = ds.analysis_id - - INNER JOIN - @schema.@sccs_table_prefixcovariate cov - on cov.covariate_id = ds.covariate_id and - cov.exposures_outcome_set_id = ds.exposures_outcome_set_id and - cov.analysis_id = ds.analysis_id - ;" - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix - ) - } - - res <- result$colNames - names(res) <- result$colNames - - return(res) -} - -getColDefsESDiag <- function( - connectionHandler, - resultDatabaseSettings, - method = 'cm' # 'cm' or 'sccs' -){ - - fixedColumns = list( - databaseName = reactable::colDef( - header = withTooltip( - "Database", - "The database name" - ), - sticky = "left" - ), - target = reactable::colDef( - header = withTooltip( - "Target", - "The target cohort of interest " - ), - sticky = "left" - ) - ) - - outcomes <- getEsOutcomeIds( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - analyses <- getOACcombinations( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - method = method - ) - colnameFormat <- merge(unique(names(analyses)), unique(names(outcomes))) - colnameFormat <- apply(colnameFormat, 1, function(x){paste(x, collapse = '_', sep = '_')}) - - styleList <- lapply( - colnameFormat, - FUN = function(x){ - reactable::colDef( - header = withTooltip( - substring(x,1,40), - x - ), - style = function(value) { - color <- 'orange' - if(is.na(value)){ - color <- 'black' - }else if(value == 'Pass'){ - color <- '#AFE1AF' - }else if(value == 'Fail'){ - color <- '#E97451' - } - list(background = color) - } - ) - } - ) - names(styleList) <- colnameFormat - result <- append(fixedColumns, styleList) - - return(result) -} diff --git a/R/evidence-synth-sccs.R b/R/evidence-synth-sccs.R deleted file mode 100644 index 86d139d3..00000000 --- a/R/evidence-synth-sccs.R +++ /dev/null @@ -1,537 +0,0 @@ -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) { - - outcomeIds <- getEsOutcomeIds( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - exposureIndicationInput <- .getSccsExposureIndicationSelection(connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings) - - inputSelected <- inputSelectionServer( - id = "input-selection-sccs", - inputSettingList = list( - exposureIndicationInput, - createInputSetting( - rowNumber = 2, - columnWidth = 12, - varName = 'outcomeIds', - uiFunction = 'shinyWidgets::virtualSelectInput', - uiInputs = list( - label = 'Outcome: ', - choices = outcomeIds, - multiple = F, - search = TRUE - ) - ) - ) - ) - - - - diagSumData <- shiny::reactive({ - getEvidenceSynthSccsDiagnostics( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - inputSelected = inputSelected, - exposure = inputSelected()$exposure, - outcomeIds = inputSelected()$outcomeIds - ) - }) - - # SCCS plots and tables - resultTableServer( - id = "diagnosticsSccsSummaryTable", - df = diagSumData, - colDefsInput = getColDefsESDiag( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - method = 'sccs' - ) - ) - - sccsData <- shiny::reactive({ - unique( - getSccsEstimation( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - exposure = inputSelected()$exposure, - 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 - ) - ) - ) - - } - ) - -} - -getSccsTargets <- function( - connectionHandler, - resultDatabaseSettings -){ - - output <- sccsGetExposureIndications( - connectionHandler, - resultDatabaseSettings - ) - return(output) - -} - -getSccsEstimation <- function( - connectionHandler, - resultDatabaseSettings, - exposure, - outcomeId -){ - - if (is.null(outcomeId)) { - return(NULL) - } - - if (is.character(exposure)) { - exposureGroup <- strsplit(exposure, " ")[[1]] - targetId <- exposureGroup[[1]] - indicationIds <- exposureGroup[[2]] - } else { - targetId <- -1 - indicationIds <- -1 - } - - if (any(indicationIds == -1)) { - indicationIds <- 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 - {@use_indications} ? {and eos.nesting_cohort_id IN (@indication_ids)} : {and eos.nesting_cohort_id IS NULL} - ;" - - 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, - indication_ids = indicationIds, - use_indications = !is.null(indicationIds) - ) - - 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 - {@use_indications} ? {and eos.nesting_cohort_id IN (@indication_ids)} : {and eos.nesting_cohort_id IS NULL} - ;" - - 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, - indication_ids = indicationIds, - use_indications = !is.null(indicationIds) - ) - - 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, - exposure, - outcomeIds -){ - - if(is.null(exposure)){ - return(NULL) - } - - if (is.character(exposure)) { - exposureGroup <- strsplit(exposure, " ")[[1]] - targetId <- exposureGroup[[1]] - indicationIds <- exposureGroup[[2]] - } else { - targetId <- -1 - indicationIds <- -1 - } - - if (any(indicationIds == -1)) { - indicationIds <- NULL - } - - sccsDiagTemp <- getSccsAllDiagnosticsSummary( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetIds = targetId, - indicationIds = indicationIds, - 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/R/helpers-componentsCreateCustomColDefList.R b/R/helpers-componentsCreateCustomColDefList.R index 5b4eda35..a6403d80 100644 --- a/R/helpers-componentsCreateCustomColDefList.R +++ b/R/helpers-componentsCreateCustomColDefList.R @@ -10,7 +10,7 @@ #' whatever raw column names are passed in #' @param customColDefOptions A list of lists, where the inner lists are any custom options from #' reactable::colDef for each column -#' +#' @family {Utils} #' @return A named list of reactable::colDef objects #' @export #' @family {Utils} @@ -55,7 +55,7 @@ createCustomColDefList <- function(rawColNames, niceColNames = NULL, result[[i]] <- do.call(reactable::colDef, colDefOptions) } - + names(result) <- rawColNames return(result) @@ -102,7 +102,7 @@ createCustomColDefList <- function(rawColNames, niceColNames = NULL, #' Make a label for an html button #' #' @param label The desired label for hte button -#' +#' @family {Utils} #' @return html code to make a button label #' @export #' @family {Utils} diff --git a/R/helpers-example.R b/R/helpers-example.R index 921073e8..a5949a97 100644 --- a/R/helpers-example.R +++ b/R/helpers-example.R @@ -3,7 +3,7 @@ #' @details #' Finds the location within the package of an sqlite database with example results for 1) CohortGenerator, #' 2) Characterization, 3) PatientLevelPrediction, 4) CohortMethod, 5) SelfControlledCaseSeries and 6) CohortIncidence -#' +#' @family {Example} #' @return #' The connection details to an example result database #' diff --git a/R/helpers-migrations.R b/R/helpers-migrations.R index b67f4ec2..e77e7cd5 100644 --- a/R/helpers-migrations.R +++ b/R/helpers-migrations.R @@ -3,7 +3,7 @@ #' Get Migrations #' @description #' Checks to see if migrations are present in the database for a given table prefix -#' +#' @family {Utils} #' @noRd getMigrations <- function(connectionHandler, resultDatabaseSettings, tablePrefix) { migrations <- data.frame() @@ -23,7 +23,7 @@ getMigrations <- function(connectionHandler, resultDatabaseSettings, tablePrefix #' Migration present #' @description #' Given a data.frame of migrations check if a migration number is present -#' +#' @family {Utils} #' @noRd migrationPresent <- function(migrations, migrationId) { if (nrow(migrations) == 0) { diff --git a/R/helpers-sccsPlots.R b/R/helpers-sccsPlots.R index e2b7f066..947557f5 100644 --- a/R/helpers-sccsPlots.R +++ b/R/helpers-sccsPlots.R @@ -120,7 +120,9 @@ plotTimeTrend <- function(timeTrend) { plotTimeToEventSccs <- function(timeToEvent) { - + if(nrow(timeToEvent) == 0){ + shiny::validate('No Rows') + } events <- timeToEvent %>% dplyr::transmute(.data$week, type = "Events", @@ -173,24 +175,21 @@ plotTimeToEventSccs <- function(timeToEvent) { drawAttritionDiagram <- function(attrition) { - formatNumber <- function(x) { - return(formatC(x, big.mark = ",")) - } - + addStep <- function(data, attrition, row) { data$leftBoxText[length(data$leftBoxText) + 1] <- paste(attrition$description[row], "\n", "Cases: ", - formatNumber(attrition$outcomeSubjects[row]), + format(attrition$outcomeSubjects[row], scientific = FALSE), "\n", "Outcomes: ", - formatNumber(attrition$outcomeEvents[row]), + format(attrition$outcomeEvents[row], scientific = FALSE), sep = "") data$rightBoxText[length(data$rightBoxText) + 1] <- paste("Cases: ", - formatNumber(data$currentCases - attrition$outcomeSubjects[row]), + format(data$currentCases - attrition$outcomeSubjects[row], scientific = FALSE), "\n", "Outcomes: ", - formatNumber(data$currentOutcomes - attrition$outcomeEvents[row]), + format(data$currentOutcomes - attrition$outcomeEvents[row], scientific = FALSE), sep = "") data$currentCases <- attrition$outcomeSubjects[row] data$currentOutcomes <- attrition$outcomeEvents[row] @@ -199,10 +198,10 @@ drawAttritionDiagram <- function(attrition) { data <- list(leftBoxText = c(paste("All outcomes occurrences:\n", "Cases: ", - formatNumber(attrition$outcomeSubjects[1]), + format(attrition$outcomeSubjects[1], scientific = FALSE), "\n", "Outcomes: ", - formatNumber(attrition$outcomeEvents[1]), + format(attrition$outcomeEvents[1], scientific = FALSE), sep = "")), rightBoxText = c(""), currentCases = attrition$outcomeSubjects[1], @@ -300,12 +299,23 @@ drawAttritionDiagram <- function(attrition) { } plotEventDepObservation <- function(eventDepObservation, maxMonths = 12) { + if(nrow(eventDepObservation) == 0){ + shiny::validate('No Rows') + } + eventDepObservation <- eventDepObservation %>% dplyr::filter(.data$monthsToEnd <= maxMonths) %>% dplyr::mutate( outcomes = pmax(0, .data$outcomes), censoring = ifelse(.data$censored == 1, "Censored", "Uncensored") ) + if(nrow(eventDepObservation) == 0){ + shiny::validate('No Rows after filtering') + } + if(is.infinite(max(eventDepObservation$monthsToEnd))){ + shiny::validate('Infinite max') + } + timeBreaks <- 0:ceiling(max(eventDepObservation$monthsToEnd)) timeLabels <- timeBreaks * 30.5 @@ -335,7 +345,20 @@ plotEventDepObservation <- function(eventDepObservation, maxMonths = 12) { } plotSpanning <- function(spanning, type = "age") { + + if(nrow(spanning) == 0){ + shiny::validate('No rows') + } + if (type == "age") { + + if(is.infinite(min(spanning$ageMonth))){ + shiny::validate('infinte min age month') + } + if(is.infinite(max(spanning$ageMonth))){ + shiny::validate('infinte max age month') + } + spanning <- spanning %>% dplyr::mutate(x = .data$ageMonth) labels <- seq(ceiling(min(spanning$ageMonth) / 12), floor(max(spanning$ageMonth) / 12)) @@ -537,7 +560,16 @@ cyclicSplineDesign <- function(x, knots, ord = 4) { X1 } -plotControlEstimates <- function(controlEstimates) { +plotControlEstimates <- function( + controlEstimates, + ease = NULL + ) { + if(nrow(controlEstimates) == 0){ + shiny::validate('No rows') + } + + titleText <- paste('Ease: ', ease) + size <- 2 labelY <- 0.7 d <- rbind(data.frame(yGroup = "Uncalibrated", @@ -556,7 +588,10 @@ plotControlEstimates <- function(controlEstimates) { d <- d[!is.na(d$ci95Lb),] d <- d[!is.na(d$ci95Ub),] if (nrow(d) == 0) { - return(NULL) + shiny::validate('No rows') + } + if (nrow(d) == 1) { + shiny::validate('Only one row so cannot aggregate') } d$Group <- as.factor(d$trueRr) d$Significant <- d$ci95Lb > d$trueRr | d$ci95Ub < d$trueRr @@ -630,7 +665,8 @@ plotControlEstimates <- function(controlEstimates) { strip.text.x = theme, strip.text.y = theme, strip.background = ggplot2::element_blank(), - legend.position = "none") + legend.position = "none") + + ggplot2::ggtitle(label = titleText) return(plot) } diff --git a/R/home-main.R b/R/home-main.R index 060ff1c1..e566173f 100644 --- a/R/home-main.R +++ b/R/home-main.R @@ -2,7 +2,7 @@ #' #' @details #' Returns the location of the home helper file -#' +#' @family {Home} #' @return #' string location of the home helper file #' @@ -16,7 +16,7 @@ homeHelperFile <- function(){ #' #' @details #' The user specifies the id for the module -#' +#' @family {Home} #' @param id the unique reference id for the module #' #' @return @@ -74,7 +74,7 @@ homeViewer <- function(id=1) { #' @param id the unique reference id for the module #' @param connectionHandler a connection to the database with the results #' @param resultDatabaseSettings a list containing the prediction result schema and connection details -#' +#' @family {Home} #' @return #' The server for the home module #' diff --git a/R/patient-level-prediction-calibration.R b/R/patient-level-prediction-calibration.R index 5f1ba549..ba241700 100644 --- a/R/patient-level-prediction-calibration.R +++ b/R/patient-level-prediction-calibration.R @@ -26,7 +26,7 @@ #' #' @return #' The user interface to the prediction model calibration module -#' +#' @family {PatientLevelPrediction} #' @export patientLevelPredictionCalibrationViewer <- function(id) { ns <- shiny::NS(id) @@ -79,7 +79,7 @@ patientLevelPredictionCalibrationViewer <- function(id) { #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the prediction calibration module #' diff --git a/R/patient-level-prediction-covariateSummary.R b/R/patient-level-prediction-covariateSummary.R index e9f6d237..0b854253 100644 --- a/R/patient-level-prediction-covariateSummary.R +++ b/R/patient-level-prediction-covariateSummary.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the covariate summary module #' @@ -85,7 +85,7 @@ patientLevelPredictionCovariateSummaryViewer <- function(id) { #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the covariate summary module #' diff --git a/R/patient-level-prediction-cutoff.R b/R/patient-level-prediction-cutoff.R index b0ede12f..776cf77f 100644 --- a/R/patient-level-prediction-cutoff.R +++ b/R/patient-level-prediction-cutoff.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the prediction cut-off module #' @@ -96,7 +96,7 @@ patientLevelPredictionCutoffViewer <- function(id) { #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the prediction cut-off module #' diff --git a/R/patient-level-prediction-designSummary.R b/R/patient-level-prediction-designSummary.R index 2f34649d..1e9d86c3 100644 --- a/R/patient-level-prediction-designSummary.R +++ b/R/patient-level-prediction-designSummary.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the prediction design module #' @@ -48,7 +48,7 @@ patientLevelPredictionDesignSummaryViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the prediction design module #' diff --git a/R/patient-level-prediction-diagnostics.R b/R/patient-level-prediction-diagnostics.R index 85121fe1..2732c176 100644 --- a/R/patient-level-prediction-diagnostics.R +++ b/R/patient-level-prediction-diagnostics.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the prediction diagnostic module #' @@ -62,7 +62,7 @@ patientLevelPredictionDiagnosticsViewer <- function(id) { #' @param modelDesignId the unique id for the model design #' @param connectionHandler the connection to the prediction result database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the prediction diagnostic module #' diff --git a/R/patient-level-prediction-discrimination.R b/R/patient-level-prediction-discrimination.R index 0fcca0af..d30dc0ab 100644 --- a/R/patient-level-prediction-discrimination.R +++ b/R/patient-level-prediction-discrimination.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the model discrimination results module #' @@ -149,7 +149,7 @@ patientLevelPredictionDiscriminationViewer <- function(id) { #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the model discrimination module #' diff --git a/R/patient-level-prediction-main.R b/R/patient-level-prediction-main.R index 3054f2f5..400f0a48 100644 --- a/R/patient-level-prediction-main.R +++ b/R/patient-level-prediction-main.R @@ -21,7 +21,7 @@ #' #' @details #' Returns the location of the prediction helper file -#' +#' @family {PatientLevelPrediction} #' @return #' string location of the prediction helper file #' @@ -37,7 +37,7 @@ patientLevelPredictionHelperFile <- function(){ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the PatientLevelPrediction viewer module #' @@ -117,7 +117,7 @@ patientLevelPredictionViewer <- function(id=1) { #' @param id the unique reference id for the module #' @param connectionHandler a connection to the database with the results #' @param resultDatabaseSettings a list containing the prediction result schema and connection details -#' +#' @family {PatientLevelPrediction} #' @return #' The server for the PatientLevelPrediction module #' diff --git a/R/patient-level-prediction-modelSummary.R b/R/patient-level-prediction-modelSummary.R index 1c2a7faf..8b0a7348 100644 --- a/R/patient-level-prediction-modelSummary.R +++ b/R/patient-level-prediction-modelSummary.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the summary module #' @@ -59,7 +59,7 @@ patientLevelPredictionModelSummaryViewer <- function(id) { #' @param connectionHandler the connection to the prediction result database #' @param resultDatabaseSettings a list containing the result schema and prefixes #' @param modelDesignId a reactable id specifying the prediction model design identifier -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the summary module #' @@ -276,12 +276,7 @@ getModelDesignPerformanceSummary <- function( inner join @schema.@plp_table_prefixmodel_designs as model_designs on model_designs.model_design_id = results.model_design_id - -- and results.target_id = model_designs.target_id - -- and results.outcome_id = model_designs.outcome_id and - -- results.tar_id = model_designs.tar_id and - -- results.population_setting_id = model_designs.population_setting_id - -- and results.plp_data_setting_id = model_designs.plp_data_setting_id - + LEFT JOIN (SELECT c.cohort_id, cd.cohort_name FROM @schema.@plp_table_prefixcohorts c inner join @schema.@cg_table_prefixcohort_definition cd @@ -293,11 +288,11 @@ getModelDesignPerformanceSummary <- function( on c.cohort_definition_id = cd.cohort_definition_id ) AS outcomes ON results.outcome_id = outcomes.cohort_id LEFT JOIN (select dd.database_id, md.cdm_source_abbreviation database_acronym - from @schema.@database_table_prefixdatabase_meta_data md inner join + from @schema.@database_table_prefix@database_table md inner join @schema.@plp_table_prefixdatabase_details dd on md.database_id = dd.database_meta_data_id) AS d ON results.development_database_id = d.database_id LEFT JOIN (select dd.database_id, md.cdm_source_abbreviation database_acronym - from @schema.@database_table_prefixdatabase_meta_data md inner join + from @schema.@database_table_prefix@database_table md inner join @schema.@plp_table_prefixdatabase_details dd on md.database_id = dd.database_meta_data_id) AS v ON results.validation_database_id = v.database_id LEFT JOIN @schema.@plp_table_prefixtars AS tars ON results.tar_id = tars.tar_id @@ -314,6 +309,7 @@ getModelDesignPerformanceSummary <- function( plp_table_prefix = resultDatabaseSettings$plpTablePrefix, model_design_id = modelDesignId(), database_table_prefix = resultDatabaseSettings$databaseTablePrefix, + database_table = resultDatabaseSettings$databaseTable, cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) diff --git a/R/patient-level-prediction-netbenefit.R b/R/patient-level-prediction-netbenefit.R index 9508bc3e..e3f276c1 100644 --- a/R/patient-level-prediction-netbenefit.R +++ b/R/patient-level-prediction-netbenefit.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the net-benefit module #' @@ -71,7 +71,7 @@ patientLevelPredictionNbViewer <- function(id) { #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the net-benefit module #' diff --git a/R/patient-level-prediction-settings.R b/R/patient-level-prediction-settings.R index 34093503..80731ea6 100644 --- a/R/patient-level-prediction-settings.R +++ b/R/patient-level-prediction-settings.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the settings module #' @@ -64,7 +64,7 @@ patientLevelPredictionSettingsViewer <- function(id) { #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the settings module #' diff --git a/R/patient-level-prediction-validation.R b/R/patient-level-prediction-validation.R index 0cdff2f7..11d55455 100644 --- a/R/patient-level-prediction-validation.R +++ b/R/patient-level-prediction-validation.R @@ -23,7 +23,7 @@ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {PatientLevelPrediction} #' @return #' The user interface to the validation module #' @@ -64,7 +64,7 @@ patientLevelPredictionValidationViewer <- function(id) { #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' +#' @family {PatientLevelPrediction} #' @return #' The server to the validation module #' diff --git a/R/phevaluator-main.R b/R/phevaluator-main.R index 8634c42c..6e5b3026 100644 --- a/R/phevaluator-main.R +++ b/R/phevaluator-main.R @@ -21,7 +21,7 @@ #' The location of the phevaluator module helper file #' #' @details Returns the location of the cohort-generator helper file -#' +#' @family {PheValuator} #' @return String location of the phevaluator helper file #' #' @export @@ -36,7 +36,7 @@ phevaluatorHelperFile <- function() { #' The viewer of the phevaluator module #' #' @param id The unique reference id for the module -#' +#' @family {PheValuator} #' @return The user interface to the phevaluator results viewer #' #' @export @@ -130,7 +130,7 @@ phevaluatorViewer <- function(id) { #' @param id The unique reference id for the module #' @param connectionHandler A connection to the database with the results #' @param resultDatabaseSettings A named list containing the cohort generator results database details (schema, table prefix) -#' +#' @family {PheValuator} #' @return The phevaluator main module server #' #' @export diff --git a/R/report-main.R b/R/report-main.R index 6e09d227..99529e92 100644 --- a/R/report-main.R +++ b/R/report-main.R @@ -21,7 +21,7 @@ #' #' @details #' Returns the location of the report helper file -#' +#' @family {Report} #' @return #' string location of the report helper file #' @@ -37,7 +37,7 @@ reportHelperFile <- function(){ #' The user specifies the id for the module #' #' @param id the unique reference id for the module -#' +#' @family {Report} #' @return #' The user interface to the home page module #' @@ -104,7 +104,7 @@ reportViewer <- function( #' @param username username for the connection to the results for quarto #' @param password password for the connection to the results for quarto #' @param dbms dbms for the connection to the results for quarto -#' +#' @family {Report} #' @return #' The server for the shiny app home #' @@ -116,7 +116,7 @@ reportServer <- function( server = Sys.getenv("RESULTS_SERVER"), username = Sys.getenv("RESULTS_USER"), password = Sys.getenv("RESULTS_PASSWORD"), - dbms = "postgresql" + dbms = Sys.getenv("RESULTS_DBMS") ) { shiny::moduleServer( id, @@ -125,7 +125,9 @@ reportServer <- function( # get input options tnos <- getTandOs( connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + includeCohortIncidence = F, # turning off for speed + includeSccs = F # turning off for speed ) ## update input selectors @@ -226,8 +228,13 @@ reportServer <- function( } subsetTargets <- tnos$groupedTs[[which(unlist(lapply(tnos$groupedTs, function(x) ifelse(is.null(x$cohortId), F, x$cohortId == input$targetId))))]]$subsets ind <- !is.na(subsetTargets$subsetId) - cts <- subsetTargets$subsetId[ind] - names(cts) <- subsetTargets$targetName[ind] + if(sum(ind)>0){ + cts <- subsetTargets$subsetId[ind] + names(cts) <- subsetTargets$targetName[ind] + } else{ + cts <- '' + names(cts) <- 'No indication' + } cmTargets(cts) } ) @@ -312,10 +319,18 @@ reportServer <- function( if(!is.null(input$cmSubsetId) & !is.null(input$targetId)){ if(input$cmSubsetId != ''){ multipler <- ifelse(input$cmSubsetId == 0, 1, 1000) - temp <- tnos$cs[[which(names(tnos$cs) == as.double(input$targetId)*multipler + as.double(input$cmSubsetId))]] - comps <- temp$comparatorId - names(comps) <- temp$comparatorName - comparators(comps) + if(length(which(names(tnos$cs) == as.double(input$targetId)*multipler + as.double(input$cmSubsetId)))>0){ + temp <- tnos$cs[[which(names(tnos$cs) == as.double(input$targetId)*multipler + as.double(input$cmSubsetId))]] + comps <- temp$comparatorId + names(comps) <- temp$comparatorName + comparators(comps) + } else{ + comps <- '' + names(comps) <- 'No Comparator' + comparators(comps) + } + } else{ + shiny::showNotification('No indication available') } } @@ -415,10 +430,21 @@ reportServer <- function( if(is.null(input$targetId)){ return(NULL) } - temp <- tnos$tos[[which(names(tnos$tos) == input$targetId)]] - os <- temp$outcomeId - names(os) <- temp$outcomeName - outcomes(os) + + multipler <- ifelse(input$cmSubsetId == 0, 1, 1000) + cmTargetId <- as.double(input$targetId)*multipler + as.double(input$cmSubsetId) + + if(length(which(names(tnos$tos) %in% c(input$targetId, cmTargetId) ))>0){ + temp <- tnos$tos[[which(names(tnos$tos) %in% c(input$targetId, cmTargetId))[1] ]] + os <- temp$outcomeId + names(os) <- temp$outcomeName + outcomes(os) + } else{ + os <- '' + names(os) <- 'None' + outcomes(os) + shiny::showNotification('No Outcomes') + } } ) @@ -585,7 +611,8 @@ reportServer <- function( width = 6, shiny::dateRangeInput( inputId = session$ns('dateRestriction'), - label = 'Study date restriction' + label = 'Study date restriction', + start = '1990-01-01' ) ), shiny::column( @@ -733,49 +760,84 @@ reportServer <- function( getTandOs <- function( connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + includeCharacterization = T, + includeCohortIncidence = T, + includeCohortMethod = T, + includePrediction = T, + includeSccs = T ){ # get cohorts - sql <- 'select * from @schema.@cg_table_prefixcohort_definition;' + sql <- 'select distinct * from @schema.@cg_table_prefixcohort_definition order by cohort_name;' cg <- connectionHandler$queryDb( sql = sql, schema = resultDatabaseSettings$schema, 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 +852,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 +867,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 +877,35 @@ 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 + + -- adding code to remove the negative controls + INNER JOIN + @schema.@sccs_table_prefixexposure e + ON e.exposures_outcome_set_id = ds.exposures_outcome_set_id + AND e.era_id = cov.era_id + where e.true_effect_size is NULL + + } + ) temp_t_o ;" @@ -824,25 +916,38 @@ 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 res <- merge( - res,cg[,c('cohortDefinitionId','cohortName')], - by.x = 'tid', + x = res, + y = cg[,c('cohortDefinitionId','cohortName')], + by.x = 'tid', by.y = 'cohortDefinitionId' ) %>% - dplyr::rename(targetName = 'cohortName') + dplyr::rename( + targetName = "cohortName" + ) + res <- merge( - res,cg[,c('cohortDefinitionId','cohortName')], + x = res, + y = cg[,c('cohortDefinitionId','cohortName')], by.x = 'oid', by.y = 'cohortDefinitionId' ) %>% - dplyr::rename(outcomeName = 'cohortName') + dplyr::rename( + outcomeName = "cohortName" + ) %>% + dplyr::arrange( + .data$targetName, + .data$outcomeName + ) tos <- lapply(unique(res$tid), function(tid){ data.frame( @@ -854,7 +959,7 @@ getTandOs <- function( # get target heirarchy groupedCohorts <- lapply(unique(res$tid), function(tid){ - data.frame( + list( cohortId = tid, cohortName = unique(res$targetName[res$tid == tid]), subsets = data.frame( @@ -873,11 +978,20 @@ 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' + ) + ) %>% dplyr::arrange( # adding order to make options orders + .data$targetName + ) + 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 +1000,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 @@ -909,7 +1021,7 @@ getTandOs <- function( by.x = 'comparatorId', by.y = 'cohortDefinitionId' ) %>% - dplyr::rename(comparatorName = 'cohortName') + dplyr::rename(comparatorName = "cohortName") cs <- lapply(unique(comps$targetId), function(tid){ data.frame( @@ -930,7 +1042,8 @@ getTandOs <- function( characterization = characterization, cohortIncidence = cohortIncidence, cohortMethod = cohortMethod, - prediction = prediction + prediction = prediction, + sccs = sccs ) ) diff --git a/R/sccs-diagnosticsSummary.R b/R/sccs-diagnosticsSummary.R deleted file mode 100644 index ccfe77a3..00000000 --- a/R/sccs-diagnosticsSummary.R +++ /dev/null @@ -1,465 +0,0 @@ -# @file sccs-diagnosticsSummary -# -# 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. - - -sccsDiagnosticsSummaryViewer <- function(id) { - ns <- shiny::NS(id) - - #shinydashboard::box( - # status = 'info', - # width = '100%', - # title = shiny::span('Diagnostic Results'), - # solidHeader = TRUE, - shiny::div( - shiny::tabsetPanel( - type = 'pills', - id = ns('diagnosticsTablePanel'), - shiny::tabPanel( - title = 'Summary', - resultTableViewer(ns("diagnosticsSummaryTable")) - ), - shiny::tabPanel( - title = 'Full', - resultTableViewer(ns("diagnosticsTable")) - ) - ) - ) - -} - -sccsDiagnosticsSummaryServer <- function( - id, - connectionHandler, - resultDatabaseSettings, - inputSelected -) { - - shiny::moduleServer( - id, - function(input, output, session) { - - - data <- shiny::reactive({ - exposure <- inputSelected()$exposure - - if (is.character(exposure)) { - exposureGroup <- strsplit(exposure, " ")[[1]] - targetId <- exposureGroup[[1]] - indidcationId <- exposureGroup[[2]] - } else { - targetId <- -1 - indidcationId <- -1 - } - - getSccsAllDiagnosticsSummary( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetIds = targetId, - outcomeIds = inputSelected()$outcome, - analysisIds = inputSelected()$analysis, - indicationIds = indidcationId - ) - }) - - data2 <- shiny::reactive({ # use CM diag function - diagnosticSummaryFormat( - data = data, - idCols = c('databaseName','target','covariateName'), - namesFrom = c('outcome','analysis') - ) - }) - - customColDefs <- list( - databaseName = reactable::colDef( - header = withTooltip( - "Database", - "The database name" - ) - ), - target = reactable::colDef( - header = withTooltip( - "Target", - "The target cohort of interest " - ) - ), - outcome = reactable::colDef( - header = withTooltip( - "Outcome", - "The outcome of interest " - ) - ), - analysis = reactable::colDef( - header = withTooltip( - "Analysis", - "The analysis name " - ) - ), - covariateName = reactable::colDef( - header = withTooltip( - "Time Period", - "The time period of interest" - ) - ), - mdrr = reactable::colDef( - header = withTooltip( - "mdrr", - "The minimum detectible relative risk" - ) - ), - ease = reactable::colDef( - header = withTooltip( - "ease", - "The ..." - ) - ), - timeTrendP = reactable::colDef( - header = withTooltip( - "timeTrendP", - "The ..." - ) - ), - preExposureP = reactable::colDef( - header = withTooltip( - "preExposureP", - "The ..." - ) - ), - mdrrDiagnostic = reactable::colDef( - header = withTooltip( - "mdrrDiagnostic", - "The ..." - ) - ), - easeDiagnostic = reactable::colDef( - header = withTooltip( - "easeDiagnostic", - "The ..." - ) - ), - timeTrendDiagnostic = reactable::colDef( - header = withTooltip( - "timeTrendDiagnostic", - "The ..." - ) - ), - preExposureDiagnostic = reactable::colDef( - header = withTooltip( - "preExposureDiagnostic", - "The ..." - ) - ), - - unblind = reactable::colDef( - header = withTooltip( - "unblind", - "If the value is 1 then the diagnostics passed and results can be unblinded" - ) - ) - - ) - - resultTableServer( - id = "diagnosticsTable", - df = data, - colDefsInput = customColDefs - ) - - - resultTableServer( - id = "diagnosticsSummaryTable", - df = data2, - colDefsInput = getColDefsSccsDiag( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - ) - - } - ) -} - - - -getSccsDiagAnalyses <- function( - connectionHandler, - resultDatabaseSettings -){ - - sql <- " - SELECT distinct - a.analysis_id, - a.description as analysis - - FROM - @schema.@sccs_table_prefixanalysis a - ; - " - result <- connectionHandler$queryDb( - sql, - schema = resultDatabaseSettings$schema, - sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, - snakeCaseToCamelCase = TRUE - ) - - res <- result$analysisId - names(res) <- result$analysis - - return(res) -} - - -getSccsDiagOutcomes <- function( - connectionHandler, - resultDatabaseSettings -){ - - sql <- " - SELECT distinct - c.cohort_name as outcome, - c.cohort_definition_id - - FROM @schema.@sccs_table_prefixdiagnostics_summary ds - inner join - @schema.@sccs_table_prefixexposures_outcome_set eos - on ds.exposures_outcome_set_id = eos.exposures_outcome_set_id - inner join - @schema.@cg_table_prefixcohort_definition as c - on c.cohort_definition_id = eos.outcome_id - ; - " - result <- connectionHandler$queryDb( - sql, - schema = resultDatabaseSettings$schema, - sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - snakeCaseToCamelCase = TRUE - ) - - res <- result$cohortDefinitionId - names(res) <- result$outcome - - return(res) -} - -getSccsDiagTargets <- function( - connectionHandler, - resultDatabaseSettings -){ - - sql <- " - SELECT distinct - c2.cohort_name as target, - c2.cohort_definition_id - - FROM @schema.@sccs_table_prefixdiagnostics_summary ds - - INNER JOIN - @schema.@sccs_table_prefixcovariate cov - on cov.covariate_id = ds.covariate_id and - cov.exposures_outcome_set_id = ds.exposures_outcome_set_id and - cov.analysis_id = ds.analysis_id and - cov.database_id = ds.database_id - - inner join - @schema.@cg_table_prefixcohort_definition as c2 - on cov.era_id = c2.cohort_definition_id - ; - " - result <- connectionHandler$queryDb( - sql, - schema = resultDatabaseSettings$schema, - sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - snakeCaseToCamelCase = TRUE - ) - - res <- result$cohortDefinitionId - names(res) <- result$target - - return(res) -} - - -getSccsAllDiagnosticsSummary <- function( - connectionHandler, - resultDatabaseSettings, - targetIds, - outcomeIds, - analysisIds = NULL, - indicationIds = NULL -) { - - if(is.null(targetIds) || is.null(outcomeIds)){ - return(NULL) - } - - if (any(indicationIds == -1)) { - indicationIds <- NULL - } - - sql <- " - SELECT - d.cdm_source_abbreviation as database_name, - c.cohort_name as outcome, - c2.cohort_name as target, - a.description as analysis, - cov.covariate_name, - ds.* - FROM @schema.@sccs_table_prefixdiagnostics_summary ds - inner join - @schema.@sccs_table_prefixexposures_outcome_set eos - on ds.exposures_outcome_set_id = eos.exposures_outcome_set_id - inner join - @schema.@cg_table_prefixcohort_definition as c - on c.cohort_definition_id = eos.outcome_id - - INNER JOIN - @schema.@database_table_prefix@database_table d - on d.database_id = ds.database_id - - INNER JOIN - @schema.@sccs_table_prefixanalysis a - on a.analysis_id = ds.analysis_id - - INNER JOIN - @schema.@sccs_table_prefixcovariate cov - on cov.covariate_id = ds.covariate_id and - cov.exposures_outcome_set_id = ds.exposures_outcome_set_id and - cov.analysis_id = ds.analysis_id and - cov.database_id = ds.database_id - - inner join - @schema.@cg_table_prefixcohort_definition as c2 - on cov.era_id = c2.cohort_definition_id - - - where - - c2.cohort_definition_id in (@target_ids) - and c.cohort_definition_id in (@outcome_ids) - {@use_analysis}?{and a.analysis_id in (@analysis_ids)} - {@use_indications} ? {and eos.nesting_cohort_id IN (@indication_ids)} : {and eos.nesting_cohort_id IS NULL} - ; - " - result <- connectionHandler$queryDb( - sql, - schema = resultDatabaseSettings$schema, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, - database_table_prefix = resultDatabaseSettings$databaseTablePrefix, - database_table = resultDatabaseSettings$databaseTable, - - target_ids = paste0(targetIds, collapse = ','), - outcome_ids = paste0(outcomeIds, collapse = ','), - analysis_ids = paste0(analysisIds, collapse = ','), - indication_ids = paste0(indicationIds, collapse = ','), - use_analysis = !is.null(analysisIds), - use_indications = !is.null(indicationIds), - snakeCaseToCamelCase = TRUE - ) - - result <- result %>% - dplyr::select(-c("analysisId","exposuresOutcomeSetId","databaseId","covariateId")) - - result$summaryValue <- apply( - X = result[, grep('Diagnostic', colnames(result))], - MARGIN = 1, - FUN = function(x){ - - if(sum(x %in% c('FAIL'))>0){ - return('Fail') - } else if(sum(x %in% c('WARNING')) >0){ - return(sum(x %in% c('WARNING'), na.rm = T)) - } else{ - return('Pass') - } - } - ) - return(result) - -} - - -getColDefsSccsDiag <- function( - connectionHandler, - resultDatabaseSettings -){ - - fixedColumns = list( - databaseName = reactable::colDef( - header = withTooltip( - "Database", - "The database name" - ), - sticky = "left" - ), - target = reactable::colDef( - header = withTooltip( - "Target", - "The target cohort of interest " - ), - sticky = "left" - ), - covariateName = reactable::colDef( - header = withTooltip( - "Time Period", - "The time period of interest" - ), - sticky = "left" - ) - ) - - outcomes <- getSccsDiagOutcomes( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - analyses <- getSccsDiagAnalyses( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - colnameFormat <- merge(unique(names(outcomes)), unique(names(analyses))) - colnameFormat <- apply(colnameFormat, 1, function(x){paste(x, collapse = '_', sep = '_')}) - - styleList <- lapply( - colnameFormat, - FUN = function(x){ - reactable::colDef( - header = withTooltip( - substring(x,1,40), - x - ), - style = function(value) { - color <- 'orange' - if(is.na(value)){ - color <- 'black' - }else if(value == 'Pass'){ - color <- '#AFE1AF' - }else if(value == 'Fail'){ - color <- '#E97451' - } - list(background = color) - } - ) - } - ) - names(styleList) <- colnameFormat - result <- append(fixedColumns, styleList) - - return(result) -} diff --git a/R/sccs-main.R b/R/sccs-main.R deleted file mode 100644 index 54a2168f..00000000 --- a/R/sccs-main.R +++ /dev/null @@ -1,212 +0,0 @@ -#' SCCS shiny module UI code -#' @description -#' Load the ui for the sccs module -#' @param id id for module -#' @export -sccsView <- function(id = "sccs-module") { - ns <- shiny::NS(id) - tags <- shiny::tags - - shinydashboard::box( - status = 'info', - width = 12, - title = shiny::span( shiny::icon("people-arrows"), 'Self Controlled Case Series'), - solidHeader = TRUE, - - - inputSelectionViewer(ns("input-selection-sccs")), - - shiny::conditionalPanel( - condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection-sccs")), - - shiny::tabsetPanel( - type = 'pills', - id = ns("mainTabsetPanel"), - - shiny::tabPanel( - title = "Diagnostics", - sccsDiagnosticsSummaryViewer(ns("sccsDiganostics")) - ), - shiny::tabPanel( - title = 'Results', - sccsResultsViewer(ns("sccsResults")), - ) - ) - - ) # end condition - ) -} - -#' Gets input selection box for use with SCCS exposure indication selection -#' @noRd -.getSccsExposureIndicationSelection <- function(connectionHandler, - resultDatabaseSettings) { - migrations <- getMigrations(connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - tablePrefix = resultDatabaseSettings$sccsTablePrefix) - - # Migration_2-v5_1_0.sql - useNestingIndications <- migrations %>% migrationPresent(2) - - if (useNestingIndications) { - # Requires migration in 5.1.0 of cohort generator - expIndicationsTbl <- sccsGetExposureIndications( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - } else { - # Backwards compatability - expIndicationsTbl <- sccsGetExposures( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - } - - expIndicationsTbl <- expIndicationsTbl %>% - dplyr::mutate(exposureIndicationId = paste(.data$exposureId, - .data$indicationId)) - - exposureChoices <- expIndicationsTbl %>% - shinyWidgets::prepare_choices(label = .data$indicationName, - value = .data$exposureIndicationId, - group_by = .data$exposureName, - alias = .data$exposureName) - - namesCallback <- function(inputSelected) { - if (is.null(inputSelected)) - return("") - - vars <- strsplit(inputSelected, " ")[[1]] - - res <- expIndicationsTbl %>% - dplyr::filter(.data$exposureId == vars[[1]], - .data$indicationId == vars[[2]]) %>% - dplyr::select("exposureName", - "indicationName") - - paste(res$exposureName, "\n\t-", res$indicationName) - } - - return( - createInputSetting( - rowNumber = 1, - columnWidth = 12, - varName = 'exposure', - uiFunction = 'shinyWidgets::virtualSelectInput', - updateFunction = "shinyWidgets::updateVirtualSelectInput", - uiInputs = list( - label = 'Target/Indication: ', - choices = exposureChoices, - multiple = FALSE, - search = TRUE, - searchGroup = TRUE, - hasOptionDescription = TRUE, - keepAlwaysOpen = FALSE - ), - namesCallback = namesCallback - ) - ) -} - - -#' The module server for exploring SCCS -#' -#' @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 prediction result schema and connection details -#' -#' @return -#' The server for the PatientLevelPrediction module -#' -#' @export -sccsServer <- function( - id, - connectionHandler, - resultDatabaseSettings = list(port = 1) -) { - ns <- shiny::NS(id) - - # create functions to result list - outcomes <- sccsGetOutcomes( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - analyses <- sccsGetAnalyses( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - shiny::moduleServer(id, function(input, output, session) { - - inputSettings <- list( - .getSccsExposureIndicationSelection(connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings), - createInputSetting( - rowNumber = 2, - columnWidth = 6, - varName = 'outcome', - uiFunction = 'shinyWidgets::virtualSelectInput', - updateFunction = "shinyWidgets::updateVirtualSelectInput", - uiInputs = list( - label = 'Outcome: ', - choices = outcomes, - selected = outcomes[1], - multiple = F, - search = TRUE - ) - ), - createInputSetting( - rowNumber = 2, - columnWidth = 6, - varName = 'analysis', - uiFunction = 'shinyWidgets::virtualSelectInput', - updateFunction = "shinyWidgets::updateVirtualSelectInput", - uiInputs = list( - label = 'Analysis: ', - choices = analyses, - selected = analyses, - multiple = T - ) - ) - ) - - inputSelected <- inputSelectionServer( - id = "input-selection-sccs", - inputSettingList = inputSettings - ) - - sccsDiagnosticsSummaryServer( - id = "sccsDiganostics", - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - inputSelected = inputSelected - ) - - sccsResultsServer( - id = "sccsResults", - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - inputSelected = inputSelected - ) - }) -} - -#' The location of the description module helper file -#' -#' @details -#' Returns the location of the description helper file -#' -#' @return -#' string location of the description helper file -#' -#' @export -sccsHelperFile <- function() { - fileLoc <- system.file('sccs-www', "sccs.html", package = utils::packageName()) - return(fileLoc) -} diff --git a/README.md b/README.md index 44958a89..62c2dbf2 100644 --- a/README.md +++ b/README.md @@ -12,8 +12,12 @@ The OHDSI tools often provide shiny interfaces for viewing and exploring results Current Modules ======== -- about module: this contains information about the shiny viewer and the types of OHDSI analyses -- prediction module: a module for exploring patient-level prediction results that were developed usign the OHDSI PatientLevelPrediction package +- about module: this contains information about the shiny viewer and the types of OHDSI analyses. +- cohort diagnostics module: a module for exploring CohortDiagnostics results. +- characterization module: a module for exploring Characterization and CohortIncidence results. +- estimation module: a module for exploring CohortMethod, SelfControlledCaseSeries and EvidenceSynthesis results. +- prediction module: a module for exploring patient-level prediction results that were developed usign the OHDSI PatientLevelPrediction package. +- report module: a module that uses ReportGenerator to create a report based on user specified inputs. Technology @@ -40,10 +44,6 @@ User Documentation ================== Documentation can be found on the [package website](https://ohdsi.github.io/OhdsiShinyModules/). -PDF versions of the documentation are also available: -Vignette: [AddingShinyModules.pdf](https://github.com/OHDSI/OhdsiShinyModules/blob/main/inst/doc/AddingShinyModules.pdf) -* Package manual: [OhdsiShinyModules manual](https://raw.githubusercontent.com/OHDSI/OhdsiShinyModules/main/extras/OhdsiShinyModules.pdf) - Support ======= * Developer questions/comments/feedback: OHDSI Forum diff --git a/_pkgdown.yml b/_pkgdown.yml index 59c63387..0521de2f 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -43,104 +43,52 @@ reference: contents: - OhdsiShinyModules - getLogoImage - - title: "About module" - desc: > - Modules for the information page. - contents: - - starts_with("about") - - title: "Report module" - desc: > - Modules for creating summary html report. - contents: - - starts_with("report") - - title: "SCCS module" - desc: > - Modules for viewing self controlled case series results. - contents: - - starts_with("sccs") - title: "Prediction module" desc: > Modules for prediction results. - contents: - - starts_with("patientLevelPrediction") - - title: "Decription module" + contents: has_concept("PatientLevelPrediction") + - title: "Characterization module" desc: > - Modules for the description analyses. - contents: - - starts_with("characterization") + Modules for the characterization analyses. + contents: has_concept("Characterization") + - title: "About module" + desc: > + Modules for the information page. + contents: has_concept("About") - title: "Cohort Generator module" desc: > Modules for the cohort generator package. - contents: - - starts_with("cohortGenerator") + contents: has_concept("CohortGenerator") - title: "Estimator module" desc: > - Modules for the CohortMethod package. - contents: - - starts_with("cohortMethod") + Modules for the CohortMethod, SCCS and Evidence Synthesis packages. + contents: has_concept("Estimation") - title: "Data diagnostics module" desc: > Modules for the DataDiagnostics package. - contents: - - dataDiagnosticDrillServer - - dataDiagnosticDrillViewer - - dataDiagnosticHelperFile - - dataDiagnosticServer - - dataDiagnosticSummaryServer - - dataDiagnosticSummaryViewer - - dataDiagnosticViewer - - dataDiagnosticHelperFile - - title: "Cohort Diagnostics module" + contents: has_concept("DataDiagnostics") + - title: "Cohort Diagnostic module" desc: > Modules for the CohortDiagnostics package. - contents: - - starts_with("cohortDiag") - - cohortCountsModule - - cohortCountsView - - cohortDefinitionsModule - - cohortDefinitionsView - - cohortOverlapView - - compareCohortCharacterizationView - - conceptsInDataSourceView - - createCdDatabaseDataSource - - databaseInformationView - - getCirceRenderedExpression - - getEnabledCdReports - - incidenceRatesView - - indexEventBreakdownView - - orpahanConceptsView - - timeDistributionsView - - visitContextView - - inclusionRulesView - - title: "Components module" - desc: > - Modules for the component functions shared across modules. - contents: - - createCustomColDefList - - createLargeSqlQueryDt - - LargeDataTable - - largeTableView - - largeTableServer - - makeButtonLabel - - resultTableServer - - resultTableViewer - - title: "Data sources module" - desc: > - Modules for the data sources results. - contents: - - starts_with("datasources") - - title: "Evidence synthesis module" - desc: > - Modules for the evidence synthesis (Meta) analysis results. - contents: - - starts_with("evidenceSynthesis") - - title: "Home module" - desc: > - Modules for the home page. - contents: - - starts_with("home") + contents: has_concept("CohortDiagnostics") + - title: Cohort Diagnostics + desc: "Run cohort diagnostics, deploy shiny" + contents: has_concept("CohortDiagnostics") + - title: "Report module" + desc: "Report generating module" + contents: has_concept("Report") - title: "PheValuator module" - desc: > - Modules for the PheValuator results. - contents: - - starts_with("phevaluator") \ No newline at end of file + desc: "PheValuator module" + contents: has_concept("PheValuator") + - title: Large Table + desc: "Utilities for tables that contain large amounts of rows" + contents: has_concept("LargeTables") + - title: Utils + desc: "Shared usable utility functions" + contents: has_concept("Utils") + - title: Example + desc: "Connection to example results database" + contents: has_concept("Example") + - title: Home + desc: "Home module functions" + contents: has_concept("Home") \ No newline at end of file diff --git a/docs/404.html b/docs/404.html index 52ada86d..5b48adcd 100644 --- a/docs/404.html +++ b/docs/404.html @@ -6,7 +6,7 @@ Page not found (404) • OhdsiShinyModules - + @@ -32,7 +32,7 @@ OhdsiShinyModules - 2.1.5 + 3.0.0 @@ -60,6 +60,30 @@
  • Adding Shiny Modules
    • +
  • + Characterization +
    • +
  • + Cohort Diagnostics +
    • +
  • + Cohort Method (Estimation) +
    • +
  • + Cohorts +
    • +
  • + Data Sources +
    • +
  • + Evidence Synthesis (Meta, Meta Analysis) +
    • +
  • + Prediction +
    • +
  • + Self-Controlled Case Series +
  • @@ -68,7 +92,7 @@
  • @@ -69,7 +93,7 @@