diff --git a/.github/workflows/build-docker-image.yml b/.github/workflows/build-docker-image.yml new file mode 100644 index 00000000..3aeab9e3 --- /dev/null +++ b/.github/workflows/build-docker-image.yml @@ -0,0 +1,73 @@ +name: build-and-push-ohdsi-docker-image-to-Docker-Hub + +on: + release: + types: [published] + workflow_dispatch: + +env: + DOCKER_IMAGE: ohdsi/ohdsi-shiny-modules + MAINTAINER: Jamie Gilbert + AUTHOR: Jamie Gilbert + APP_NAME: ohdsi-shiny-modules +jobs: + docker: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v2 + + - name: Cache Docker layers + uses: actions/cache@v2 + with: + path: /tmp/.buildx-cache + key: ${{ runner.os }}-buildx-${{ github.sha }} + restore-keys: | + ${{ runner.os }}-buildx- + + - name: Docker meta + id: docker_meta + uses: crazy-max/ghaction-docker-meta@v1 + with: + images: ${{ env.DOCKER_IMAGE }} + tag-match: v(.*) + tag-match-group: 1 + + - name: Set up QEMU + uses: docker/setup-qemu-action@v1 + - name: Set up Docker Buildx + uses: docker/setup-buildx-action@v1 + + - name: Login to Docker Hub + uses: docker/login-action@v1 + with: + username: ${{ secrets.DOCKER_HUB_USERNAME }} + password: ${{ secrets.DOCKER_HUB_ACCESS_TOKEN }} + + - name: Build Docker image and push to Docker Hub + id: build_and_push + uses: docker/build-push-action@v2 + with: + context: ./ + file: ./Dockerfile + cache-from: type=local,src=/tmp/.buildx-cache + cache-to: type=local,dest=/tmp/.buildx-cache,mode=max + platforms: linux/amd64,linux/arm64 + push: true + build-args: | + APP_NAME=${{ env.APP_NAME }} + GIT_BRANCH=${{ steps.docker_meta.outputs.version }} + GIT_COMMIT_ID_ABBREV=${{ steps.build_params.outputs.sha8 }} + GITHUB_PAT=${{ secrets.GH_TOKEN }} + tags: ${{ steps.docker_meta.outputs.tags }} + labels: | + ${{ steps.docker_meta.outputs.labels }} + maintainer=${{ env.MAINTAINER }} + org.opencontainers.image.authors=${{ env.AUTHOR }} + org.opencontainers.image.vendor=OHDSI + org.opencontainers.image.licenses=Apache-2.0 + + - name: Inspect Docker image + run: | + docker pull ${{ env.DOCKER_IMAGE }}:${{ steps.docker_meta.outputs.version }} + docker image inspect ${{ env.DOCKER_IMAGE }}:${{ steps.docker_meta.outputs.version }} diff --git a/DESCRIPTION b/DESCRIPTION index 7286c00b..17af1899 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: OhdsiShinyModules Type: Package Title: Repository of Shiny Modules for OHDSI Result Viewers -Version: 2.0.2 +Version: 2.1.0 Author: Jenna Reps Maintainer: Jenna Reps Description: Install this package to access useful shiny modules for building shiny apps to explore results using the OHDSI tools . diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 00000000..2a23f4aa --- /dev/null +++ b/Dockerfile @@ -0,0 +1,36 @@ +# Set base image +FROM ohdsi/broadsea-shiny + +ARG DEBIAN_FRONTEND=noninteractive +ARG CRAN=https://packagemanager.posit.co/cran/__linux__/focal/latest +ARG JAVA_PARAMS=-Xss100m + +# Set an argument for the app name +ARG APP_NAME +# Set arguments for the GitHub branch and commit id abbreviation +ARG GIT_BRANCH='main' +ARG GIT_COMMIT_ID_ABBREV + +ENV DATABASECONNECTOR_JAR_FOLDER /root + +# install additional required OS dependencies +RUN apt-get update && \ + apt-get install -y openjdk-8-jre && \ + apt-get clean && \ + rm -rf /var/lib/apt/lists/* + +# Sets CRAN to latest (or user specified) version +RUN echo "options(repos=c(CRAN='$CRAN'))" >> /root/.Rprofile +# Specify java params +RUN echo "options(java.parameters = '$JAVA_PARAMS')" >> /root/.Rprofile +RUN R -e 'install.packages(c("remotes", "rJava", "dplyr", "DatabaseConnector", "shiny", "RSQLite"))' +# run java conf for r +RUN R CMD javareconf +RUN R -e "DatabaseConnector::downloadJdbcDrivers('postgresql', pathToDriver='/root')" +RUN R -e "remotes::install_github('OHDSI/ResultModelManager', update='always')" +# install git ref or branch +RUN R -e "ref <- Sys.getenv('GIT_COMMIT_ID_ABBREV', unset=Sys.getenv('GIT_BRANCH')); remotes::install_github('OHDSI/OhdsiShinyModules', ref=ref, update='always')" + +# Expose default Shiny app port +EXPOSE 3838 + diff --git a/NEWS.md b/NEWS.md index 75a87848..ea52fb05 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,10 @@ +OhdsiShinyModules v2.1.0 +======================== +Support for data models from SCCS version 5.2.0 +Support for data models from Cohort Method version 5.2.0 +Fixes for CohortDiagnostics Orpahan concept table by re-writing with DB level pagination +Automated release of Docker Images upon package release + OhdsiShinyModules v2.0.2 ======================== edited characterization server to work with new aggregate features method in characterization package diff --git a/R/OhdsiShinyModules.R b/R/OhdsiShinyModules.R index a76b1be8..be906dcd 100644 --- a/R/OhdsiShinyModules.R +++ b/R/OhdsiShinyModules.R @@ -1,6 +1,6 @@ # @file OhdsiShinyModules.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/about-main.R b/R/about-main.R index beb36d3c..d3019a49 100644 --- a/R/about-main.R +++ b/R/about-main.R @@ -1,6 +1,6 @@ # @file about-main.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/characterization-aggregateFeatures.R b/R/characterization-aggregateFeatures.R index f3628ca9..0f64b826 100644 --- a/R/characterization-aggregateFeatures.R +++ b/R/characterization-aggregateFeatures.R @@ -1,6 +1,6 @@ # @file characterization-aggregateFeatures.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # @@ -106,31 +106,6 @@ characterizationAggregateFeaturesServer <- function( id, function(input, output, session) { - types <- c( - 'Target (first exposure)', - 'Outcome (all exposures)', - 'Target with outcome (all exposures) during TAR (T index)', - 'Target with outcome (all exposures) during TAR (O index)', - 'Target without outcome (all exposures) during TAR', - 'Target (all exposures)', - 'Outcome (first exposure)', - 'Target with outcome (first exposure) during TAR (T index)', - 'Target without outcome (first exposure) during TAR', - 'Target with outcome (first exposure) during TAR (O index)' - ) - typesTranslate <- c( - 'T', - 'O', - 'TnO', - 'OnT', - 'TnOc', - 'allT', - 'firstO', - 'TnfirstO', - 'TnfirstOc', - 'firstOnT' - ) - # get the possible options options <- getAggregateFeatureOptions( connectionHandler = connectionHandler, @@ -211,11 +186,11 @@ characterizationAggregateFeaturesServer <- function( , createInputSetting( rowNumber = 2, - columnWidth = 3, - varName = 'database1', + columnWidth = 6, + varName = 'database', uiFunction = 'shinyWidgets::pickerInput', uiInputs = list( - label = 'Database 1: ', + label = 'Database: ', choices = databases, selected = databases[1], multiple = F, @@ -233,63 +208,26 @@ characterizationAggregateFeaturesServer <- function( createInputSetting( rowNumber = 2, columnWidth = 3, - varName = 'type1', + varName = 'firstO', uiFunction = 'shinyWidgets::pickerInput', uiInputs = list( - label = 'Type 1: ', - choices = types, - selected = types[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 = 'database2', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Database 2: ', - 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 - ) + label = 'Restrict to first O: ', + choices = c(T,F), + selected = T, + multiple = F ) ) , createInputSetting( rowNumber = 2, columnWidth = 3, - varName = 'type2', + varName = 'index', uiFunction = 'shinyWidgets::pickerInput', uiInputs = list( - label = 'Type 2: ', - choices = types, - selected = types[2], - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) + label = 'Index: ', + choices = c('T', 'O'), + selected = 'T', + multiple = F ) ) ) @@ -305,10 +243,9 @@ characterizationAggregateFeaturesServer <- function( 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, - database1 = inputSelected()$database1, - database2 = inputSelected()$database2, - type1 = typesTranslate[types == inputSelected()$type1], - type2 = typesTranslate[types == inputSelected()$type2] + database = inputSelected()$database, + firstO = inputSelected()$firstO, + index = inputSelected()$index ) }) @@ -345,20 +282,36 @@ characterizationAggregateFeaturesServer <- function( name = "Covariate Name", filterable = T ), - comp1 = reactable::colDef( - name = "Selection 1 mean", + comp1T = reactable::colDef( + name = "T without O mean", format = reactable::colFormat(digits = 2, percent = T) ), - comp1sd = reactable::colDef( - name = "Selection 1 stdev", + comp1sdT = reactable::colDef( + name = "T without O stdev", format = reactable::colFormat(digits = 2) ), - comp2 = reactable::colDef( - name = "Selection 2 mean", + comp2T = reactable::colDef( + name = "T with O mean", format = reactable::colFormat(digits = 2, percent = T) ), - comp2sd = reactable::colDef( - name = "Selection 2 stdev", + 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 @@ -389,22 +342,38 @@ characterizationAggregateFeaturesServer <- function( name = "Covariate Name", filterable = T ), - comp1 = reactable::colDef( - name = "Selection 1 mean", + comp1T = reactable::colDef( + name = "T without O mean", format = reactable::colFormat(digits = 2) - ), - comp1sd = reactable::colDef( - name = "Selection 1 stdev", + ), + comp1sdT = reactable::colDef( + name = "T without O stdev", format = reactable::colFormat(digits = 2) ), - comp2 = reactable::colDef( - name = "Selection 2 mean", + comp2T = reactable::colDef( + name = "T with O mean", format = reactable::colFormat(digits = 2) - ), - comp2sd = reactable::colDef( - name = "Selection 2 stdev", + ), + 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( @@ -553,6 +522,7 @@ getAggregateFeatureDatabases <- function( } # pulls all data for a target and outcome +# edited to only use Ts and TnOs characterizationGetAggregateData <- function( connectionHandler, resultDatabaseSettings, @@ -562,19 +532,24 @@ characterizationGetAggregateData <- function( riskWindowEnd, startAnchor, endAnchor, - database1, - database2, - type1, - type2 + database, + firstO, + index ){ if(is.null(targetId)){ return(NULL) } - if( (database1 == database2) & (type1 == type2) ){ - 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 @@ -598,7 +573,7 @@ characterizationGetAggregateData <- function( start_anchor = startAnchor, risk_window_end = riskWindowEnd, end_anchor = endAnchor, - database_id = database1, + database_id = database, type = type1 ) @@ -616,7 +591,6 @@ characterizationGetAggregateData <- function( 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, @@ -627,7 +601,7 @@ characterizationGetAggregateData <- function( start_anchor = startAnchor, risk_window_end = riskWindowEnd, end_anchor = endAnchor, - database_id = database2, + database_id = database, type = type2 ) @@ -638,25 +612,62 @@ characterizationGetAggregateData <- function( shiny::incProgress(2/5, detail = paste("Got second runId and CohortId")) - sql <- "SELECT cov.*, cov_ref.COVARIATE_NAME, an_ref.ANALYSIS_NAME, - case when (cov.DATABASE_ID = '@database_id1' and cov.COHORT_DEFINITION_ID = @cohortDef1 and cov.RUN_ID in (@run_id1)) then 'comp1' else 'comp2' end as label - FROM @schema.@c_table_prefixCOVARIATES cov - INNER JOIN - @schema.@c_table_prefixCOVARIATE_REF cov_ref - ON cov.covariate_id = cov_ref.covariate_id - and cov.run_id = cov_ref.run_id - and cov.database_id = cov_ref.database_id - INNER JOIN - @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 - WHERE - ( - (cov.DATABASE_ID = '@database_id1' and cov.COHORT_DEFINITION_ID = @cohortDef1 and cov.RUN_ID in (@run_id1)) - OR - (cov.DATABASE_ID = '@database_id2' and cov.COHORT_DEFINITION_ID = @cohortDef2 and cov.RUN_ID in (@run_id2)) - );" + 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")) @@ -664,46 +675,83 @@ characterizationGetAggregateData <- function( sql = sql, schema = resultDatabaseSettings$schema, c_table_prefix = resultDatabaseSettings$cTablePrefix, - cohortDef1 = settingsFirst$cohortDefinitionId[1], - cohortDef2 = settingsSecond$cohortDefinitionId[1], - database_id1 = database1, - database_id2 = database2, - run_id1 = paste(settingsFirst$runId, collapse = ','), - run_id2 = paste(settingsSecond$runId, collapse = ',') + 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 cov.*, cov_ref.COVARIATE_NAME, an_ref.ANALYSIS_NAME, - case when (cov.DATABASE_ID = '@database_id1' and cov.COHORT_DEFINITION_ID = @cohortDef1 and cov.RUN_ID in (@run_id1)) then 'comp1' else 'comp2' end as label - FROM @schema.@c_table_prefixCOVARIATES_CONTINUOUS cov - INNER JOIN - @schema.@c_table_prefixCOVARIATE_REF cov_ref - ON cov.covariate_id = cov_ref.covariate_id - and cov.run_id = cov_ref.run_id - and cov.database_id = cov_ref.database_id - INNER JOIN - @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 - WHERE - ( - (cov.DATABASE_ID = '@database_id1' and cov.COHORT_DEFINITION_ID = @cohortDef1 and cov.RUN_ID in (@run_id1)) - OR - (cov.DATABASE_ID = '@database_id2' and cov.COHORT_DEFINITION_ID = @cohortDef2 and cov.RUN_ID in (@run_id2)) - );" + 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, - cohortDef1 = settingsFirst$cohortDefinitionId[1], - cohortDef2 = settingsSecond$cohortDefinitionId[1], - database_id1 = database1, - database_id2 = database2, - run_id1 = paste(settingsFirst$runId, collapse = ','), - run_id2 = paste(settingsSecond$runId, collapse = ',') + 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")) @@ -725,48 +773,26 @@ characterizationFeaturePlot <- function( return(NULL) } - valueColumns <- c("covariateName", "covariateId", valueColumn) - - - shiny::withProgress(message = 'Generating plots', value = 0, { + # 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] - comp1 <- data %>% - dplyr::filter(.data$label == 'comp1') %>% - dplyr::select(dplyr::all_of(valueColumns)) %>% - dplyr::rename(comp1 = dplyr::all_of(valueColumn)) #.data[[valueColumn]]) # not sure how to do this ERROR? + maxval <- max(max(data$comp1),max(data$comp2)) - shiny::incProgress(1/5, detail = paste("Filtered comparision 1")) - - comp2 <- data %>% - dplyr::filter(.data$label == 'comp2') %>% - dplyr::select(dplyr::all_of(valueColumns)) %>% - dplyr::rename(comp2 = dplyr::all_of(valueColumn)) # not sure this will work ERROR? - - shiny::incProgress(2/5, detail = paste("Filtered comparision 2")) - - analysisIds <- data %>% - dplyr::select(c("covariateName", "covariateId", "analysisName")) %>% - dplyr::distinct() - - shiny::incProgress(3/5, detail = paste("Extracting analysisNames")) - - maxval <- max(max(comp1$comp1, na.rm = T), max(comp2$comp2, na.rm = T)) - - allData <- merge(comp1, comp2, by = c('covariateName','covariateId'), all = T) - allData[is.na(allData)] <- 0 - allData <- merge(allData, analysisIds, by = c('covariateName','covariateId') , all.x = T) - - shiny::incProgress(4/5, detail = paste("Merged data")) - - plot <- plotly::plot_ly(x = allData$comp1, - showlegend = F) %>% - plotly::add_markers(y = allData$comp2, - color=factor(allData$analysisName), + 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(allData$covariateName), - '\n',descGetName(allData$covariateName), - '\n',descGetTime(allData$covariateName) + '\n',descGetType(data$covariateName), + '\n',descGetName(data$covariateName), + '\n',descGetTime(data$covariateName) ), showlegend = T ) %>% @@ -779,9 +805,6 @@ characterizationFeaturePlot <- function( #legend = l, showlegend = T, legend = list(orientation = 'h', y = -0.3), showlegend = T) - shiny::incProgress(5/5, detail = paste("Finished")) - - }) return(plot) } @@ -808,76 +831,40 @@ characterizationFeatureTable <- function( return(NULL) } - shiny::withProgress(message = 'Generating Table', value = 0, { - - if(!'standardDeviation' %in% colnames(data)){ - # adding standard dev for binary features - data <- data %>% - dplyr::mutate( - standardDeviation = sqrt(data$averageValue * (1-data$averageValue)) - ) - } - - comp1 <- data %>% - dplyr::filter(.data$label == 'comp1') %>% - dplyr::select( - c( - "covariateId", - "covariateName", - "averageValue", - "standardDeviation" - ) - ) %>% - dplyr::rename( - comp1 = "averageValue", - comp1sd = "standardDeviation" - ) + # 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 + } - - shiny::incProgress(1/4, detail = paste("Filtered comparision 1")) - - comp2 <- data %>% - dplyr::filter(.data$label == 'comp2') %>% - dplyr::select( - c( - "covariateId", - "covariateName", - "averageValue", - "standardDeviation" - ) + data <- data %>% + dplyr::mutate( + standardizedMeanDiff = (.data[[comp1Name]] - .data[[comp2Name]])/(sqrt((.data[[comp1sdName]]^2 + .data[[comp2sdName]]^2))) ) %>% - dplyr::rename( - comp2 = "averageValue", - comp2sd = "standardDeviation" - ) - - shiny::incProgress(2/4, detail = paste("Filtered comparision 2")) - - analysisIds <- data %>% - dplyr::select(c("covariateName", "covariateId", "analysisName")) %>% - dplyr::distinct() - - shiny::incProgress(3/4, detail = paste("Extracting analysisIds")) - - allData <- merge( - comp1, - comp2, - by = c('covariateId', 'covariateName'), - all = T + dplyr::select( + "covariateName", + "analysisName", + comp1Name, + comp1sdName, + comp2Name, + comp2sdName, + "standardizedMeanDiff" ) - allData[is.na(allData)] <- 0 - allData <- merge(allData, analysisIds, by = c('covariateId', 'covariateName'), all.x = T) - allData <- allData %>% - dplyr::mutate( - standardizedMeanDiff = (.data$comp1 - .data$comp2)/(sqrt((.data$comp1sd^2 + .data$comp2sd^2)/2)) - ) - - # multiple binary by 100 and make to 2dp? + if(sum(is.null(data$standardizedMeanDiff))>0){ + data$standardizedMeanDiff[is.null(data$standardizedMeanDiff)] <- 0 + } - shiny::incProgress(4/4, detail = paste("Finished")) + if(sum(!is.finite(data$standardizedMeanDiff))>0){ + data$standardizedMeanDiff[!is.finite(data$standardizedMeanDiff)] <- 0 + } - }) - - return(allData) + return(data) } diff --git a/R/characterization-cohorts.R b/R/characterization-cohorts.R index 811c607f..ea314c98 100644 --- a/R/characterization-cohorts.R +++ b/R/characterization-cohorts.R @@ -1,6 +1,6 @@ # @file characterization-timeToEvent.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/characterization-dechallengeRechallenge.R b/R/characterization-dechallengeRechallenge.R index e924812a..b05d2125 100644 --- a/R/characterization-dechallengeRechallenge.R +++ b/R/characterization-dechallengeRechallenge.R @@ -1,6 +1,6 @@ # @file characterization-DechallengeRechallenge.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/characterization-incidence.R b/R/characterization-incidence.R index 1097675e..73c22c55 100644 --- a/R/characterization-incidence.R +++ b/R/characterization-incidence.R @@ -1,6 +1,6 @@ # @file characterization-incidence.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/characterization-main.R b/R/characterization-main.R index a105c107..1cf1b21a 100644 --- a/R/characterization-main.R +++ b/R/characterization-main.R @@ -1,6 +1,6 @@ # @file characterization-main.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # @@ -243,4 +243,4 @@ getCharacterizationTypes <- function( } return(results) -} \ No newline at end of file +} diff --git a/R/characterization-timeToEvent.R b/R/characterization-timeToEvent.R index b6430ea2..8b0f6041 100644 --- a/R/characterization-timeToEvent.R +++ b/R/characterization-timeToEvent.R @@ -1,6 +1,6 @@ # @file characterization-timeToEvent.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-diagnostics-characterization.R b/R/cohort-diagnostics-characterization.R index b15e04cc..02a88887 100644 --- a/R/cohort-diagnostics-characterization.R +++ b/R/cohort-diagnostics-characterization.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-diagnostics-cohort-overlap.R b/R/cohort-diagnostics-cohort-overlap.R index 5b538d11..016c5556 100644 --- a/R/cohort-diagnostics-cohort-overlap.R +++ b/R/cohort-diagnostics-cohort-overlap.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-diagnostics-compareCharacterization.R b/R/cohort-diagnostics-compareCharacterization.R index 9a289fe0..58d5e177 100644 --- a/R/cohort-diagnostics-compareCharacterization.R +++ b/R/cohort-diagnostics-compareCharacterization.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-conceptsInDataSource.R b/R/cohort-diagnostics-conceptsInDataSource.R index db5604cc..825e58aa 100644 --- a/R/cohort-diagnostics-conceptsInDataSource.R +++ b/R/cohort-diagnostics-conceptsInDataSource.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-counts.R b/R/cohort-diagnostics-counts.R index c6f9d846..262c41ea 100644 --- a/R/cohort-diagnostics-counts.R +++ b/R/cohort-diagnostics-counts.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-databaseInformation.R b/R/cohort-diagnostics-databaseInformation.R index 0bafcb69..74f4c671 100644 --- a/R/cohort-diagnostics-databaseInformation.R +++ b/R/cohort-diagnostics-databaseInformation.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-definition.R b/R/cohort-diagnostics-definition.R index 937f2176..27733ec4 100644 --- a/R/cohort-diagnostics-definition.R +++ b/R/cohort-diagnostics-definition.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-incidenceRates.R b/R/cohort-diagnostics-incidenceRates.R index 4f7ffb1d..3d23eeff 100644 --- a/R/cohort-diagnostics-incidenceRates.R +++ b/R/cohort-diagnostics-incidenceRates.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-inclusionRules.R b/R/cohort-diagnostics-inclusionRules.R index 567eaa49..8122a1fa 100644 --- a/R/cohort-diagnostics-inclusionRules.R +++ b/R/cohort-diagnostics-inclusionRules.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-indexEventBreakdown.R b/R/cohort-diagnostics-indexEventBreakdown.R index d5e8ad7e..07476663 100644 --- a/R/cohort-diagnostics-indexEventBreakdown.R +++ b/R/cohort-diagnostics-indexEventBreakdown.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-main-ui.R b/R/cohort-diagnostics-main-ui.R index 8d3ccae3..b4291c3c 100644 --- a/R/cohort-diagnostics-main-ui.R +++ b/R/cohort-diagnostics-main-ui.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-main.R b/R/cohort-diagnostics-main.R index 5e669248..7c557d0e 100644 --- a/R/cohort-diagnostics-main.R +++ b/R/cohort-diagnostics-main.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of CohortDiagnostics # diff --git a/R/cohort-diagnostics-orphanConcepts.R b/R/cohort-diagnostics-orphanConcepts.R index 8568fb68..935eadc4 100644 --- a/R/cohort-diagnostics-orphanConcepts.R +++ b/R/cohort-diagnostics-orphanConcepts.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # @@ -28,7 +28,7 @@ orpahanConceptsView <- function(id) { collapsed = TRUE, title = "Orphan Concepts", width = "100%", - shiny::htmlTemplate(system.file("cohort-diagnostics-www", "orphanConcepts.html", package = utils::packageName())) + shiny::htmlTemplate(system.file("cohort-diagnostics-www", "orphanConcepts.html", package = utils::packageName())) ), shinydashboard::box( status = "warning", @@ -41,75 +41,49 @@ orpahanConceptsView <- function(id) { shinydashboard::box( title = NULL, width = NULL, - htmltools::withTags( - table( - width = "100%", - shiny::tags$tr( - shiny::tags$td( - shiny::radioButtons( - inputId = ns("orphanConceptsType"), - label = "Filters", - choices = c("All", "Standard Only", "Non Standard Only"), - selected = "All", - inline = TRUE - ) - ), - shiny::tags$td(shiny::HTML("       ")), - shiny::tags$td( - shiny::radioButtons( - inputId = ns("orphanConceptsColumFilterType"), - label = "Display", - choices = c("All", "Persons", "Records"), - selected = "All", - inline = TRUE - ) - ) - ) + shiny::fluidRow( + shiny::column(width = 4, + shiny::radioButtons( + inputId = ns("orphanConceptsType"), + label = "Filters", + choices = c("All" = 0, "Standard Only" = 1, "Non Standard Only" = 2), + selected = 0, + inline = TRUE + ) + ), + shiny::column(width = 4, + shiny::radioButtons( + inputId = ns("orphanConceptsColumFilterType"), + label = "Display", + choices = c("All" = 0, "Persons" = 1, "Records" = 2), + selected = 0, + inline = TRUE + ) + ), + shiny::column(width = 4, + shiny::textInput(inputId = ns("generalSearchString"), + label = "", + placeholder = "Search concepts") ) ), - shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("orphanConceptsTable"))), - reactableCsvDownloadButton(ns, "orphanConceptsTable") + shiny::fluidRow( + shiny::column(width = 6, + shiny::selectInput(inputId = ns("sortBy"), + label = "Sort By", + choices = NULL) + ), + shiny::column(width = 2, + shiny::radioButtons(inputId = ns("shortByAsc"), + choices = c(ascending = "ASC", descending = "DESC"), + selected = "DESC", + label = "order") + ) + ), + largeTableView(id = ns("orphanConceptsTable"), selectedPageSize = 50) ) ) } - -getOrphanConceptResult <- function(dataSource, - databaseIds, - cohortId, - conceptSetId = NULL) { - sql <- "SELECT oc.*, - cs.concept_set_name, - c.concept_name, - c.vocabulary_id, - c.concept_code, - c.standard_concept - FROM @schema.@orphan_table_name oc - INNER JOIN @schema.@cs_table_name cs - ON oc.cohort_id = cs.cohort_id - AND oc.concept_set_id = cs.concept_set_id - INNER JOIN @vocabulary_database_schema.@concept_table c - ON oc.concept_id = c.concept_id - WHERE oc.cohort_id = @cohort_id - AND database_id in (@database_ids) - {@concept_set_id != \"\"} ? { AND oc.concept_set_id IN (@concept_set_id)};" - data <- - dataSource$connectionHandler$queryDb( - sql = sql, - schema = dataSource$schema, - vocabulary_database_schema = dataSource$vocabularyDatabaseSchema, - cohort_id = cohortId, - database_ids = quoteLiterals(databaseIds), - orphan_table_name = dataSource$prefixTable("orphan_concept"), - cs_table_name = dataSource$prefixTable("concept_sets"), - concept_table = dataSource$prefixVocabTable("concept"), - concept_set_id = conceptSetId, - snakeCaseToCamelCase = TRUE - ) %>% - tidyr::tibble() - return(data) -} - orphanConceptsModule <- function(id, dataSource, selectedCohort, @@ -122,140 +96,121 @@ orphanConceptsModule <- function(id, shiny::moduleServer(id, function(input, output, session) { output$selectedCohorts <- shiny::renderUI({ selectedCohort() }) - # Orphan concepts table -------------------- - orphanConceptsDataReactive <- shiny::reactive(x = { - shiny::validate(shiny::need(length(targetCohortId()) > 0, "No cohorts chosen")) - data <- getOrphanConceptResult( - dataSource = dataSource, - cohortId = targetCohortId(), - databaseIds = selectedDatabaseIds() - ) - - if (!hasData(data)) { - return(NULL) - } - data <- data %>% - dplyr::arrange(dplyr::desc(.data$conceptCount)) - return(data) - }) - - # Reactive below developed for testing purposes - # Focuses on filtering the standard vs. non-standard codes - filteringStandardConceptsReactive <- shiny::reactive(x = { - data <- orphanConceptsDataReactive() - shiny::validate(shiny::need(hasData(data), "There is no data for the selected combination.")) - - - if (hasData(selectedConceptSets())) { - if (!is.null(selectedConceptSets())) { - if (length(conceptSetIds()) > 0) { - data <- data %>% - dplyr::filter(.data$conceptSetId %in% conceptSetIds()) - } else { - data <- data[0,] - } - } + inputButtonParams <- shiny::reactive({ + conceptSets <- conceptSetIds() + if (length(conceptSets) == 0) { + conceptSets <- NULL } - if (input$orphanConceptsType == "Standard Only") { - data <- data %>% - dplyr::filter(.data$standardConcept == "S") - } else if (input$orphanConceptsType == "Non Standard Only") { - data <- data %>% - dplyr::filter(is.na(.data$standardConcept) | - ( - all(!is.na(.data$standardConcept), .data$standardConcept != "S") - )) - } - - return (data) - + params <- list( + database_ids = quoteLiterals(selectedDatabaseIds()), + cohort_id = targetCohortId(), + concept_set_id = conceptSets, + use_concept_set_id = length(conceptSets) > 0, + schema = dataSource$schema, + vocabulary_database_schema = dataSource$vocabularyDatabaseSchema, + orphan_table_name = dataSource$prefixTable("orphan_concept"), + cs_table_name = dataSource$prefixTable("concept_sets"), + concept_table = dataSource$prefixVocabTable("concept"), + search_str = input$generalSearchString, + sort_by = input$sortBy, + sort_by_asc = ifelse(input$shortByAsc == "DESC", "DESC", "ASC") # Prevent sql injection + ) + + return(params) }) - output$orphanConceptsTable <- reactable::renderReactable(expr = { - data <- filteringStandardConceptsReactive() - shiny::validate(shiny::need(hasData(data), "There is no data for the selected combination.")) - + databaseSubGrp <- ", + MAX(CASE WHEN oc.database_id = '@db_id_i' THEN oc.concept_count END) AS concept_count_@db_id_i, + MAX(CASE WHEN oc.database_id = '@db_id_i' THEN oc.concept_subjects END) AS subject_count_@db_id_i" - data <- data %>% - dplyr::select( - "databaseId", - "cohortId", - "conceptId", - "conceptSubjects", - "conceptCount" - ) %>% - dplyr::group_by( - .data$databaseId, - .data$cohortId, - .data$conceptId - ) %>% - dplyr::summarise( - conceptSubjects = sum(.data$conceptSubjects), - conceptCount = sum(.data$conceptCount), - .groups = "keep" - ) %>% - dplyr::ungroup() %>% - dplyr::arrange( - .data$databaseId, - .data$cohortId - ) %>% - dplyr::inner_join( - data %>% - dplyr::select( - "conceptId", - "databaseId", - "cohortId", - "conceptName", - "vocabularyId", - "conceptCode" - ), - by = c("databaseId", "cohortId", "conceptId") - ) %>% - dplyr::rename( - "persons" = "conceptSubjects", - "records" = "conceptCount" - ) %>% - dplyr::arrange(dplyr::desc(abs(dplyr::across( - c("records", "persons") - )))) + sql <- " + SELECT + c.concept_id, + c.concept_name, + c.vocabulary_id, + c.concept_code, + CASE WHEN c.standard_concept = 'S' THEN 'Standard' ELSE 'Non-standard' END as standard_concept + %s + FROM @schema.@orphan_table_name oc + INNER JOIN @schema.@cs_table_name cs + ON oc.cohort_id = cs.cohort_id + AND oc.concept_set_id = cs.concept_set_id + INNER JOIN @vocabulary_database_schema.@concept_table c + ON oc.concept_id = c.concept_id + WHERE oc.cohort_id = @cohort_id + AND database_id in (@database_ids) + {@search_str != ''} ? {AND lower(CONCAT(c.concept_id, c.concept_name, c.vocabulary_id, c.concept_code)) LIKE lower('%%@search_str%%')} + {@use_concept_set_id} ? { AND oc.concept_set_id IN (@concept_set_id)} + GROUP BY + c.concept_id, + c.concept_name, + c.vocabulary_id, + c.concept_code, + c.standard_concept + {@sort_by != \"\"} ? {ORDER BY @sort_by @sort_by_asc} + " - keyColumnFields <- - c("conceptId", "conceptName", "vocabularyId", "conceptCode") - if (input$orphanConceptsColumFilterType == "Persons") { - dataColumnFields <- c("persons") - countLocation <- 1 - } else if (input$orphanConceptsColumFilterType == "Records") { - dataColumnFields <- c("records") - countLocation <- 1 - } else { - dataColumnFields <- c("persons", "records") - countLocation <- 2 - } - countsForHeader <- - getDisplayTableHeaderCount( - dataSource = dataSource, - databaseIds = data$databaseId %>% unique(), - cohortIds = data$cohortId %>% unique(), - source = "cohort", - fields = input$orphanConceptsColumFilterType + shiny::observe({ + databaseIds <- selectedDatabaseIds() + dbSelectCols <- "" + + columnDefinitions <- list( + conceptId = reactable::colDef(name = "Concept Id"), + conceptName = reactable::colDef(name = "Concept Name", minWidth = 200), + vocabularyId = reactable::colDef(name = "Vocabulary Id"), + conceptCode = reactable::colDef(name = "Concept Code"), + standardConcept = reactable::colDef(name = "Standard Concept") + ) + + columnGroups <- list() + sortByColumns <- c("Concept Id" = "c.concept_id", + "Concept Name" = "c.concept_name", + "Vocabulary Id" = "c.vocabulary_id", + "Concept Code" = "c.concept_code") + for (dbid in databaseIds) { + dbCols <- SqlRender::render(databaseSubGrp, db_id_i = dbid) + dbSelectCols <- paste(dbSelectCols, dbCols) + + columnIdCount <- SqlRender::snakeCaseToCamelCase(paste0("concept_count_", dbid)) + columnIdSubject <- SqlRender::snakeCaseToCamelCase(paste0("subject_count_", dbid)) + + columnDefinitions[[columnIdCount]] <- reactable::colDef(name = "Records", + cell = formatDataCellValueInDisplayTable(), + show = input$orphanConceptsColumFilterType %in% c(0,2)) + columnDefinitions[[columnIdSubject]] <- reactable::colDef(name = "Persons", + cell = formatDataCellValueInDisplayTable(), + show = input$orphanConceptsColumFilterType %in% c(0,1)) + + databaseName <- databaseTable %>% + dplyr::filter(.data$databaseId == dbid) %>% + dplyr::select("databaseName") %>% + dplyr::pull() + + columnGroups[[length(columnGroups) + 1]] <- reactable::colGroup( + name = databaseName, + columns = c(columnIdCount, columnIdSubject), + align = "center" ) - showDataAsPercent <- FALSE - ## showDataAsPercent set based on UI selection - proportion + cNames <- names(sortByColumns) + sortByColumns <- c(sortByColumns, paste0("concept_count_", dbid), paste0("subject_count_", dbid)) + names(sortByColumns) <- c(cNames, paste(databaseName, "Records"), paste(databaseName, "Subjects")) + } + + shiny::updateSelectInput(inputId = "sortBy", choices = sortByColumns, selected = sortByColumns[[5]]) + + baseQuery <- sprintf(sql, dbSelectCols) + ldt <- LargeDataTable$new(connectionHandler = dataSource$connectionHandler, + baseQuery = baseQuery) + + largeTableServer(id = "orphanConceptsTable", + ldt, + inputParams = inputButtonParams, + columns = columnDefinitions, + columnGroups = columnGroups) - displayTable <- getDisplayTableGroupedByDatabaseId( - data = data, - databaseTable = databaseTable, - headerCount = countsForHeader, - keyColumns = keyColumnFields, - countLocation = countLocation, - dataColumns = dataColumnFields, - showDataAsPercent = showDataAsPercent, - sort = TRUE - ) - return(displayTable) }) }) diff --git a/R/cohort-diagnostics-shared.R b/R/cohort-diagnostics-shared.R index 2aaf5d04..aa88fdca 100644 --- a/R/cohort-diagnostics-shared.R +++ b/R/cohort-diagnostics-shared.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of CohortDiagnostics # @@ -248,7 +248,6 @@ getDisplayTableGroupedByDatabaseId <- function(data, keyColumns = keyColumns, dataColumns = dataColumns ) - data <- data %>% tidyr::pivot_longer( cols = dplyr::all_of(dataColumns), @@ -282,6 +281,7 @@ getDisplayTableGroupedByDatabaseId <- function(data, } data <- data %>% + dplyr::distinct() %>% tidyr::pivot_wider( id_cols = dplyr::all_of(keyColumns), names_from = "type", @@ -455,6 +455,7 @@ getDisplayTableGroupedByDatabaseId <- function(data, ) } + dataTable <- reactable::reactable( data = data, diff --git a/R/cohort-diagnostics-timeDistributions.R b/R/cohort-diagnostics-timeDistributions.R index 23234c4f..436c7b80 100644 --- a/R/cohort-diagnostics-timeDistributions.R +++ b/R/cohort-diagnostics-timeDistributions.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-diagnostics-visitContext.R b/R/cohort-diagnostics-visitContext.R index 881d39ad..3b4b1771 100644 --- a/R/cohort-diagnostics-visitContext.R +++ b/R/cohort-diagnostics-visitContext.R @@ -1,4 +1,4 @@ -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-generator-main.R b/R/cohort-generator-main.R index 54c7a33b..5c524c9a 100644 --- a/R/cohort-generator-main.R +++ b/R/cohort-generator-main.R @@ -1,6 +1,6 @@ # @file cohortgenerator-main.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-method-attrition.R b/R/cohort-method-attrition.R index 08a08387..2d75a966 100644 --- a/R/cohort-method-attrition.R +++ b/R/cohort-method-attrition.R @@ -1,6 +1,6 @@ # @file cohort-method-attrition # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-method-covariateBalance.R b/R/cohort-method-covariateBalance.R index b68788ce..52f56bee 100644 --- a/R/cohort-method-covariateBalance.R +++ b/R/cohort-method-covariateBalance.R @@ -1,6 +1,6 @@ # @file cohort-method-covariateBalance # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-method-diagnosticsSummary.R b/R/cohort-method-diagnosticsSummary.R index 89086184..dc04aa5e 100644 --- a/R/cohort-method-diagnosticsSummary.R +++ b/R/cohort-method-diagnosticsSummary.R @@ -1,6 +1,6 @@ # @file cohort-method-diagnosticsSummary # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # @@ -150,13 +150,6 @@ cohortMethodDiagnosticsSummaryServer <- function( ), format = reactable::colFormat(digits = 4) ), - attritionFraction = reactable::colDef( - header = withTooltip( - "Attrition fraction", - "The ..." - ), - format = reactable::colFormat(digits = 4) - ), balanceDiagnostic = reactable::colDef( header = withTooltip( "balanceDiagnostic", @@ -181,12 +174,6 @@ cohortMethodDiagnosticsSummaryServer <- function( "The ..." ) ), - attritionDiagnostic = reactable::colDef( - header = withTooltip( - "attritionDiagnostic", - "The ..." - ) - ), equipoiseDiagnostic = reactable::colDef( header = withTooltip( "equipoiseDiagnostic", @@ -342,13 +329,11 @@ getCmDiagnosticsData <- function( cmds.shared_max_sdm, cmds.equipoise, cmds.mdrr, - cmds.attrition_fraction, cmds.ease, cmds.balance_diagnostic, cmds.shared_balance_diagnostic, -- added back cmds.equipoise_diagnostic, cmds.mdrr_diagnostic, - cmds.attrition_diagnostic, cmds.ease_diagnostic, cmds.unblind FROM diff --git a/R/cohort-method-kaplainMeier.R b/R/cohort-method-kaplainMeier.R index 1d330ce2..290887b6 100644 --- a/R/cohort-method-kaplainMeier.R +++ b/R/cohort-method-kaplainMeier.R @@ -1,6 +1,6 @@ # @file cohort-method-kaplainMeier # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-method-main.R b/R/cohort-method-main.R index 51b9cf1f..ba8c9181 100644 --- a/R/cohort-method-main.R +++ b/R/cohort-method-main.R @@ -1,6 +1,6 @@ # @file cohort-method-main.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/cohort-method-populationCharacteristics.R b/R/cohort-method-populationCharacteristics.R index b5466fbb..c37cde83 100644 --- a/R/cohort-method-populationCharacteristics.R +++ b/R/cohort-method-populationCharacteristics.R @@ -1,6 +1,6 @@ # @file cohort-method-populationCharacteristics # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-method-power.R b/R/cohort-method-power.R index aa359027..aa57bf91 100644 --- a/R/cohort-method-power.R +++ b/R/cohort-method-power.R @@ -1,6 +1,6 @@ # @file cohort-method-power # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-method-propensityModel.R b/R/cohort-method-propensityModel.R index 650d1713..53877b20 100644 --- a/R/cohort-method-propensityModel.R +++ b/R/cohort-method-propensityModel.R @@ -1,6 +1,6 @@ # @file cohort-method-propensityModel # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-method-propensityScoreDistribution.R b/R/cohort-method-propensityScoreDistribution.R index 7d5d3a93..08ae4384 100644 --- a/R/cohort-method-propensityScoreDistribution.R +++ b/R/cohort-method-propensityScoreDistribution.R @@ -1,6 +1,6 @@ # @file cohort-method-propensityScoreDistribution # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-method-resultSummary.R b/R/cohort-method-resultSummary.R index 4fd147b1..14db71ba 100644 --- a/R/cohort-method-resultSummary.R +++ b/R/cohort-method-resultSummary.R @@ -1,6 +1,6 @@ # @file cohort-method-resultSummary # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/cohort-method-systematicError.R b/R/cohort-method-systematicError.R index d0efaec0..cc89cafb 100644 --- a/R/cohort-method-systematicError.R +++ b/R/cohort-method-systematicError.R @@ -1,6 +1,6 @@ # @file cohort-method-systematicError # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/components-inputselection.R b/R/components-inputselection.R index 6a4da1ec..27e42b94 100644 --- a/R/components-inputselection.R +++ b/R/components-inputselection.R @@ -43,7 +43,8 @@ createInputSetting <- function( options = shinyWidgets::pickerOptions() ), updateFunction = NULL, - collapse = F + collapse = F, + namesCallback = NULL ){ result <- list( @@ -54,7 +55,8 @@ createInputSetting <- function( uiFunction = uiFunction, uiInputs = uiInputs, updateFunction = updateFunction, - collapse = collapse + collapse = collapse, + namesCallback = namesCallback ) class(result) <- 'inputSetting' @@ -141,18 +143,25 @@ inputSelectionServer <- function( width = inputSettingList[[x]]$columnWidth, shiny::tags$b(paste0(inputSettingList[[x]]$uiInputs$label)), if(!is.null(inputSettingList[[x]]$uiInputs$choices)){ - # adding below incase a vector with no names is used - if(is.null(names(inputSettingList[[x]]$uiInputs$choices))){ - names(inputSettingList[[x]]$uiInputs$choices) <- inputSettingList[[x]]$uiInputs$choices + inputVar <- paste0('input_',x) + if (!is.null(inputSettingList[[x]]$namesCallback)) { + namesVec <- inputSettingList[[x]]$namesCallback(input[[inputVar]]) + } else { + # adding below incase a vector with no names is used + if(is.null(names(inputSettingList[[x]]$uiInputs$choices))){ + names(inputSettingList[[x]]$uiInputs$choices) <- inputSettingList[[x]]$uiInputs$choices + } + + namesVec <- names(inputSettingList[[x]]$uiInputs$choices)[inputSettingList[[x]]$uiInputs$choices %in% input[[inputVar]]] + } - # add selections on new row unless collapse is F if(!inputSettingList[[x]]$collapse){ shiny::HTML( - paste("

", names(inputSettingList[[x]]$uiInputs$choices)[inputSettingList[[x]]$uiInputs$choices %in% input[[paste0('input_',x)]]], '

') + paste("

", namesVec, '

') ) } else{ - paste(names(inputSettingList[[x]]$uiInputs$choices)[inputSettingList[[x]]$uiInputs$choices %in% input[[paste0('input_',x)]]], collapse = ', ') + paste(namesVec, collapse = ', ') } } else{ diff --git a/R/data-diagnostic-drill.R b/R/data-diagnostic-drill.R index e9142cfe..2da1c2a5 100644 --- a/R/data-diagnostic-drill.R +++ b/R/data-diagnostic-drill.R @@ -1,6 +1,6 @@ # @file data-diagnostic-drill.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/data-diagnostic-main.R b/R/data-diagnostic-main.R index 064b15a3..8a460c12 100644 --- a/R/data-diagnostic-main.R +++ b/R/data-diagnostic-main.R @@ -1,6 +1,6 @@ # @file data-diagnostic-main.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/data-diagnostic-summary.R b/R/data-diagnostic-summary.R index 27c19d11..b9b72614 100644 --- a/R/data-diagnostic-summary.R +++ b/R/data-diagnostic-summary.R @@ -1,6 +1,6 @@ # @file data-diagnostic-summary.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/datasources-main.R b/R/datasources-main.R index 5b168873..9dd221bf 100644 --- a/R/datasources-main.R +++ b/R/datasources-main.R @@ -1,6 +1,6 @@ # @file datasources-main.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/evidence-synth-sccs.R b/R/evidence-synth-sccs.R index 791c7207..839242dc 100644 --- a/R/evidence-synth-sccs.R +++ b/R/evidence-synth-sccs.R @@ -40,55 +40,29 @@ evidenceSynthesisSccsServer <- function( shiny::moduleServer( id, function(input, output, session) { - - targetIds <- getSccsTargetIds( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) + outcomeIds <- getEsOutcomeIds( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings ) - + + exposureIndicationInput <- .getSccsExposureIndicationSelection(connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings) + inputSelected <- inputSelectionServer( id = "input-selection-sccs", inputSettingList = list( + exposureIndicationInput, 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, + rowNumber = 2, + columnWidth = 12, varName = 'outcomeIds', - uiFunction = 'shinyWidgets::pickerInput', + uiFunction = 'shinyWidgets::virtualSelectInput', 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 - ) + search = TRUE ) ) ) @@ -98,16 +72,15 @@ evidenceSynthesisSccsServer <- function( diagSumData <- shiny::reactive({ getEvidenceSynthSccsDiagnostics( - connectionHandler = connectionHandler, + connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, inputSelected = inputSelected, - targetIds = inputSelected()$targetIds, + exposure = inputSelected()$exposure, outcomeIds = inputSelected()$outcomeIds ) }) # SCCS plots and tables - resultTableServer( id = "diagnosticsSccsSummaryTable", df = diagSumData, @@ -122,7 +95,7 @@ evidenceSynthesisSccsServer <- function( getSccsEstimation( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputSelected()$targetIds, + exposure = inputSelected()$exposure, outcomeId = inputSelected()$outcomeIds ) ) @@ -206,15 +179,12 @@ evidenceSynthesisSccsServer <- function( } - -# TODO update this for SCCS -#getSccsDiagTargets -getSccsTargetIds <- function( +getSccsTargets <- function( connectionHandler, resultDatabaseSettings ){ - output <- getSccsDiagTargets( + output <- sccsGetExposureIndications( connectionHandler, resultDatabaseSettings ) @@ -223,14 +193,28 @@ getSccsTargetIds <- function( } getSccsEstimation <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - outcomeId + connectionHandler, + resultDatabaseSettings, + exposure, + outcomeId ){ - if(is.null(targetId)){ + + 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, @@ -299,6 +283,7 @@ getSccsEstimation <- function( 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( @@ -308,7 +293,9 @@ getSccsEstimation <- function( sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, cg_table_prefix = resultDatabaseSettings$cgTablePrefix, outcome_id = outcomeId, - target_id = targetId + target_id = targetId, + indication_ids = indicationIds, + use_indications = !is.null(indicationIds) ) sql <- "select distinct @@ -377,6 +364,7 @@ getSccsEstimation <- function( 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( @@ -386,7 +374,9 @@ getSccsEstimation <- function( sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, cg_table_prefix = resultDatabaseSettings$cgTablePrefix, outcome_id = outcomeId, - target_id = targetId + target_id = targetId, + indication_ids = indicationIds, + use_indications = !is.null(indicationIds) ) return(rbind(result,result2)) @@ -498,21 +488,35 @@ createPlotForSccsAnalysis <- function( } getEvidenceSynthSccsDiagnostics <- function( - connectionHandler, - resultDatabaseSettings, - inputSelected, - targetIds, - outcomeIds + connectionHandler, + resultDatabaseSettings, + inputSelected, + exposure, + outcomeIds ){ - if(is.null(targetIds)){ + 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 = targetIds, + targetIds = targetId, + indicationIds = indicationIds, outcomeIds = outcomeIds ) diff --git a/R/helpers-migrations.R b/R/helpers-migrations.R new file mode 100644 index 00000000..b67f4ec2 --- /dev/null +++ b/R/helpers-migrations.R @@ -0,0 +1,33 @@ + +#' @title +#' Get Migrations +#' @description +#' Checks to see if migrations are present in the database for a given table prefix +#' +#' @noRd +getMigrations <- function(connectionHandler, resultDatabaseSettings, tablePrefix) { + migrations <- data.frame() + # Handle case where no migrations are present + tryCatch({ + migrations <- connectionHandler$queryDb("SELECT * FROM @schema.@table_prefixmigration ORDER BY migration_order", + snakeCaseToCamelCase = TRUE, + schema = resultDatabaseSettings$schema, + table_prefix = tablePrefix) + }, error = function(err) { + warning("Schema does not contain migrations table.") + }) + + return(migrations) +} + +#' Migration present +#' @description +#' Given a data.frame of migrations check if a migration number is present +#' +#' @noRd +migrationPresent <- function(migrations, migrationId) { + if (nrow(migrations) == 0) { + return(FALSE) + } + return(migrationId %in% migrations$migrationOrder) +} diff --git a/R/helpers-sccsDataPulls.R b/R/helpers-sccsDataPulls.R index ee3ac178..0bea14ff 100644 --- a/R/helpers-sccsDataPulls.R +++ b/R/helpers-sccsDataPulls.R @@ -35,6 +35,40 @@ sccsGetOutcomes <- function( } +sccsGetExposureIndications <- function(connectionHandler, + resultDatabaseSettings) { + + sql <- "SELECT + e.era_id AS exposure_id, + c2.cohort_name as exposure_name, + coalesce(c.cohort_definition_id, -1) as indication_id, + coalesce(c.cohort_name, 'No indication') as indication_name + + FROM @schema.@sccs_table_prefixexposures_outcome_set eos + LEFT JOIN @schema.@cg_table_prefixcohort_definition c on eos.nesting_cohort_id = c.cohort_definition_id + + INNER JOIN @schema.@sccs_table_prefixcovariate cov + ON eos.exposures_outcome_set_id = cov.exposures_outcome_set_id + + INNER JOIN @schema.@sccs_table_prefixexposure e + ON eos.exposures_outcome_set_id = e.exposures_outcome_set_id + AND cov.era_id = e.era_id + + INNER JOIN @schema.@cg_table_prefixcohort_definition c2 on e.era_id = c2.cohort_definition_id + GROUP BY c.cohort_definition_id, c.cohort_name, e.era_id, c2.cohort_name + " + result <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + snakeCaseToCamelCase = TRUE + ) + + result +} + + sccsGetExposures <- function( connectionHandler, resultDatabaseSettings @@ -42,14 +76,26 @@ sccsGetExposures <- function( # Note Query rew-written from dplyr because of data type/casting issues with null values in left joins sql <- " select distinct - c.cohort_name as name, + c1.cohort_name as name, e.era_id as exposure_id - from - @schema.@cg_table_prefixcohort_definition as c - inner join - @schema.@sccs_table_prefixexposure as e - on e.era_id = c.cohort_definition_id; + from @schema.@sccs_table_prefixresult r + + INNER JOIN @schema.@sccs_table_prefixexposures_outcome_set eos + ON r.exposures_outcome_set_id = eos.exposures_outcome_set_id + + INNER JOIN @schema.@sccs_table_prefixcovariate cov + ON r.exposures_outcome_set_id = cov.exposures_outcome_set_id + AND r.analysis_id = cov.analysis_id + AND r.covariate_id = cov.covariate_id + + INNER JOIN @schema.@sccs_table_prefixexposure e + ON r.exposures_outcome_set_id = e.exposures_outcome_set_id + AND cov.era_id = e.era_id + + INNER JOIN @schema.@cg_table_prefixcohort_definition as c1 on c1.cohort_definition_id = e.era_id + WHERE e.true_effect_size IS NULL + ; " exposures <- connectionHandler$queryDb( sql, @@ -58,10 +104,9 @@ sccsGetExposures <- function( sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, snakeCaseToCamelCase = TRUE ) - + result <- exposures$exposureId names(result) <- exposures$name - return(result) } diff --git a/R/patient-level-prediction-calibration.R b/R/patient-level-prediction-calibration.R index 196d2675..5f1ba549 100644 --- a/R/patient-level-prediction-calibration.R +++ b/R/patient-level-prediction-calibration.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-calibration.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/patient-level-prediction-covariateSummary.R b/R/patient-level-prediction-covariateSummary.R index 3932e8bf..e9f6d237 100644 --- a/R/patient-level-prediction-covariateSummary.R +++ b/R/patient-level-prediction-covariateSummary.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-covariateSummary.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/patient-level-prediction-cutoff.R b/R/patient-level-prediction-cutoff.R index 7ecdf08b..b0ede12f 100644 --- a/R/patient-level-prediction-cutoff.R +++ b/R/patient-level-prediction-cutoff.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-cutoff.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/patient-level-prediction-designSummary.R b/R/patient-level-prediction-designSummary.R index 4d20f365..2f34649d 100644 --- a/R/patient-level-prediction-designSummary.R +++ b/R/patient-level-prediction-designSummary.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-designSummary.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/patient-level-prediction-diagnostics.R b/R/patient-level-prediction-diagnostics.R index 2eba56b1..85121fe1 100644 --- a/R/patient-level-prediction-diagnostics.R +++ b/R/patient-level-prediction-diagnostics.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-diagnostics.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/patient-level-prediction-discrimination.R b/R/patient-level-prediction-discrimination.R index d6fbce33..0fcca0af 100644 --- a/R/patient-level-prediction-discrimination.R +++ b/R/patient-level-prediction-discrimination.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-discrimination.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/patient-level-prediction-main.R b/R/patient-level-prediction-main.R index c7789606..943b63e8 100644 --- a/R/patient-level-prediction-main.R +++ b/R/patient-level-prediction-main.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-main.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of PatientLevelPrediction # diff --git a/R/patient-level-prediction-modelSummary.R b/R/patient-level-prediction-modelSummary.R index c036c51b..1c2a7faf 100644 --- a/R/patient-level-prediction-modelSummary.R +++ b/R/patient-level-prediction-modelSummary.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-modelSummary.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/patient-level-prediction-netbenefit.R b/R/patient-level-prediction-netbenefit.R index b9ff261f..9508bc3e 100644 --- a/R/patient-level-prediction-netbenefit.R +++ b/R/patient-level-prediction-netbenefit.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-netbenefit.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/patient-level-prediction-settings.R b/R/patient-level-prediction-settings.R index 72aacda2..cdc20874 100644 --- a/R/patient-level-prediction-settings.R +++ b/R/patient-level-prediction-settings.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-settings.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/patient-level-prediction-validation.R b/R/patient-level-prediction-validation.R index 6d81010c..0cdff2f7 100644 --- a/R/patient-level-prediction-validation.R +++ b/R/patient-level-prediction-validation.R @@ -1,6 +1,6 @@ # @file patient-level-prediction-validation.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/phevaluator-main.R b/R/phevaluator-main.R index 159941e3..2573bd41 100644 --- a/R/phevaluator-main.R +++ b/R/phevaluator-main.R @@ -1,6 +1,6 @@ # @file phevaluator-main.R # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # diff --git a/R/sccs-diagnosticsSummary.R b/R/sccs-diagnosticsSummary.R index d1dfa314..ccfe77a3 100644 --- a/R/sccs-diagnosticsSummary.R +++ b/R/sccs-diagnosticsSummary.R @@ -1,6 +1,6 @@ # @file sccs-diagnosticsSummary # -# Copyright 2023 Observational Health Data Sciences and Informatics +# Copyright 2024 Observational Health Data Sciences and Informatics # # This file is part of OhdsiShinyModules # @@ -55,13 +55,24 @@ sccsDiagnosticsSummaryServer <- function( 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 = inputSelected()$exposure, + targetIds = targetId, outcomeIds = inputSelected()$outcome, - analysisIds = inputSelected()$analysis + analysisIds = inputSelected()$analysis, + indicationIds = indidcationId ) }) @@ -289,13 +300,18 @@ getSccsAllDiagnosticsSummary <- function( resultDatabaseSettings, targetIds, outcomeIds, - analysisIds = NULL + analysisIds = NULL, + indicationIds = NULL ) { - if(is.null(targetIds)){ + if(is.null(targetIds) || is.null(outcomeIds)){ return(NULL) } - + + if (any(indicationIds == -1)) { + indicationIds <- NULL + } + sql <- " SELECT d.cdm_source_abbreviation as database_name, @@ -337,6 +353,7 @@ getSccsAllDiagnosticsSummary <- function( 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( @@ -350,8 +367,9 @@ getSccsAllDiagnosticsSummary <- function( 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 ) diff --git a/R/sccs-main.R b/R/sccs-main.R index aea3c873..1c5c45ac 100644 --- a/R/sccs-main.R +++ b/R/sccs-main.R @@ -6,28 +6,28 @@ sccsView <- function(id = "sccs-module") { ns <- shiny::NS(id) tags <- shiny::tags - + shinydashboard::box( - status = 'info', + status = 'info', width = 12, title = shiny::span( shiny::icon("people-arrows"), 'Self Controlled Case Series'), solidHeader = TRUE, - + infoHelperViewer( id = "helper", helpLocation= system.file("sccs-www", "sccs.html", package = utils::packageName()) ), - + 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")) @@ -37,11 +37,83 @@ sccsView <- function(id = "sccs-module") { sccsResultsViewer(ns("sccsResults")), ) ) - + ) # end condition ) } +#' @noRd +#' Gets input selection box for use with SCCS exposure indication selection +.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 #' @@ -65,99 +137,65 @@ sccsServer <- function( # create functions to result list outcomes <- sccsGetOutcomes( - connectionHandler = connectionHandler, + connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings ) - exposures <- sccsGetExposures( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) + analyses <- sccsGetAnalyses( - connectionHandler = connectionHandler, + 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 = list( - createInputSetting( - rowNumber = 1, - columnWidth = 6, - varName = 'exposure', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Target: ', - choices = exposures, - selected = exposures[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 = 'outcome', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Outcome: ', - choices = outcomes, - selected = outcomes[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 = 'analysis', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Analysis: ', - choices = analyses, - selected = analyses, - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) - ) + id = "input-selection-sccs", + inputSettingList = inputSettings ) - - + sccsDiagnosticsSummaryServer( id = "sccsDiganostics", connectionHandler = connectionHandler, - resultDatabaseSettings, + resultDatabaseSettings = resultDatabaseSettings, inputSelected = inputSelected ) - + sccsResultsServer( id = "sccsResults", connectionHandler = connectionHandler, - resultDatabaseSettings, + resultDatabaseSettings = resultDatabaseSettings, inputSelected = inputSelected ) }) diff --git a/R/sccs-results-full.R b/R/sccs-results-full.R index f2774fbe..66ab1b4f 100644 --- a/R/sccs-results-full.R +++ b/R/sccs-results-full.R @@ -362,7 +362,7 @@ sccsFullResultServer <- function( } else { controlEstimates <- getSccsControlEstimates( connectionHandler = connectionHandler, - resultDatabaseSettings, + resultDatabaseSettings = resultDatabaseSettings, covariateId = row$covariateId, databaseId = row$databaseId, analysisId = row$analysisId diff --git a/R/sccs-results.R b/R/sccs-results.R index bd6e8390..0f5b7e54 100644 --- a/R/sccs-results.R +++ b/R/sccs-results.R @@ -47,13 +47,25 @@ sccsResultsServer <- function( ) data <- shiny::reactive({ - results <- getSccsResults( + + exposure <- inputSelected()$exposure + if (is.character(exposure)) { + exposureGroup <- strsplit(exposure, " ")[[1]] + targetId <- exposureGroup[[1]] + indidcationId <- exposureGroup[[2]] + } else { + targetId <- -1 + indidcationId <- -1 + } + + getSccsResults( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - exposureIds = inputSelected()$exposure, + exposureIds = targetId, outcomeIds = inputSelected()$outcome, #databaseIds = inputSelected()$database, - analysisIds = inputSelected()$analysis + analysisIds = inputSelected()$analysis, + indicationIds = indidcationId ) }) @@ -209,7 +221,13 @@ getSccsResults <- function(connectionHandler, exposureIds, outcomeIds, #databaseIds, - analysisIds) { + analysisIds, + indicationIds = NULL) { + + if (any(indicationIds == -1)) { + indicationIds <- NULL + } + sql <- " SELECT @@ -292,6 +310,7 @@ getSccsResults <- function(connectionHandler, -- AND sr.database_id IN (@database_ids) AND 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( @@ -305,6 +324,8 @@ getSccsResults <- function(connectionHandler, 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 ) diff --git a/docs/404.html b/docs/404.html index 00fcf582..b66baa0b 100644 --- a/docs/404.html +++ b/docs/404.html @@ -32,7 +32,7 @@ OhdsiShinyModules - 1.0.2 + 2.1.0 diff --git a/docs/articles/AddingShinyModules.html b/docs/articles/AddingShinyModules.html index c5d68caa..92b0fbdb 100644 --- a/docs/articles/AddingShinyModules.html +++ b/docs/articles/AddingShinyModules.html @@ -69,7 +69,7 @@