diff --git a/.github/workflows/R_CMD_check_Hades_minor.yml b/.github/workflows/R_CMD_check_Hades_minor.yml
deleted file mode 100644
index 3d1144c97..000000000
--- a/.github/workflows/R_CMD_check_Hades_minor.yml
+++ /dev/null
@@ -1,128 +0,0 @@
-#Designed to be a fast github actions check - longer running actions to only run on releases
-on:
- pull_request:
- branches:
- - '**'
- - '!main'
-
-name: R-CMD-check-minor
-
-jobs:
- R-CMD-check-minor:
- runs-on: ${{ matrix.config.os }}
-
- name: ${{ matrix.config.os }} (${{ matrix.config.r }})
-
- strategy:
- max-parallel: 1
- fail-fast: false
- matrix:
- config:
- - {os: windows-latest, r: 'release'} # Does not appear to have Java 32-bit, hence the --no-multiarch
- - {os: macOS-latest, r: 'release'}
-
- env:
- GITHUB_PAT: ${{ secrets.GH_TOKEN }}
- BRANCH_NAME: ${{ github.head_ref || github.ref_name }}
- R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
- RSPM: ${{ matrix.config.rspm }}
- #CDM5_ORACLE_CDM_SCHEMA: ${{ secrets.CDM5_ORACLE_CDM_SCHEMA }}
- #CDM5_ORACLE_OHDSI_SCHEMA: ${{ secrets.CDM5_ORACLE_OHDSI_SCHEMA }}
- #CDM5_ORACLE_PASSWORD: ${{ secrets.CDM5_ORACLE_PASSWORD }}
- #CDM5_ORACLE_SERVER: ${{ secrets.CDM5_ORACLE_SERVER }}
- #CDM5_ORACLE_USER: ${{ secrets.CDM5_ORACLE_USER }}
- CDM5_POSTGRESQL_CDM_SCHEMA: ${{ secrets.CDM5_POSTGRESQL_CDM_SCHEMA }}
- CDM5_POSTGRESQL_OHDSI_SCHEMA: ${{ secrets.CDM5_POSTGRESQL_OHDSI_SCHEMA }}
- CDM5_POSTGRESQL_PASSWORD: ${{ secrets.CDM5_POSTGRESQL_PASSWORD }}
- CDM5_POSTGRESQL_SERVER: ${{ secrets.CDM5_POSTGRESQL_SERVER }}
- CDM5_POSTGRESQL_USER: ${{ secrets.CDM5_POSTGRESQL_USER }}
- #CDM5_SQL_SERVER_CDM_SCHEMA: ${{ secrets.CDM5_SQL_SERVER_CDM_SCHEMA }}
- #CDM5_SQL_SERVER_OHDSI_SCHEMA: ${{ secrets.CDM5_SQL_SERVER_OHDSI_SCHEMA }}
- #CDM5_SQL_SERVER_PASSWORD: ${{ secrets.CDM5_SQL_SERVER_PASSWORD }}
- #CDM5_SQL_SERVER_SERVER: ${{ secrets.CDM5_SQL_SERVER_SERVER }}
- #CDM5_SQL_SERVER_USER: ${{ secrets.CDM5_SQL_SERVER_USER }}
- #CDM5_REDSHIFT_CDM_SCHEMA: ${{ secrets.CDM5_REDSHIFT_CDM_SCHEMA }}
- #CDM5_REDSHIFT_OHDSI_SCHEMA: ${{ secrets.CDM5_REDSHIFT_OHDSI_SCHEMA }}
- #CDM5_REDSHIFT_PASSWORD: ${{ secrets.CDM5_REDSHIFT_PASSWORD }}
- #CDM5_REDSHIFT_SERVER: ${{ secrets.CDM5_REDSHIFT_SERVER }}
- #CDM5_REDSHIFT_USER: ${{ secrets.CDM5_REDSHIFT_USER }}
-
- steps:
- - uses: actions/checkout@v2
-
- - uses: r-lib/actions/setup-r@v1
- with:
- r-version: ${{ matrix.config.r }}
-
- - uses: r-lib/actions/setup-tinytex@v1
-
- - uses: r-lib/actions/setup-pandoc@v1
-
- - name: Query dependencies
- run: |
- install.packages('remotes')
- saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
- writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version")
- shell: Rscript {0}
-
- - name: Cache R packages
- if: runner.os != 'Windows'
- uses: actions/cache@v2
- with:
- path: ${{ env.R_LIBS_USER }}
- key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}
- restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-
-
- - name: Install system dependencies
- if: runner.os == 'Linux'
- run: |
- while read -r cmd
- do
- eval sudo $cmd
- done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))')
-
- - name: Install libssh
- if: runner.os == 'Linux'
- run: |
- sudo apt-get install libssh-dev
- - name: Install dependencies
- run: |
- remotes::install_deps(dependencies = TRUE, INSTALL_opts=c("--no-multiarch"))
- remotes::install_cran("rcmdcheck")
- shell: Rscript {0}
-
- - name: Install covr
- if: runner.os == 'macOS'
- run: |
- remotes::install_cran("covr")
- shell: Rscript {0}
-
- - name: Remove check folder if exists
- if: runner.os == 'macOS'
- run: unlink("check", recursive = TRUE)
- shell: Rscript {0}
-
- - name: Check
- env:
- _R_CHECK_CRAN_INCOMING_REMOTE_: false
- run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--no-multiarch"), build_args = c("--no-manual", "--compact-vignettes=gs+qpdf"), error_on = "warning", check_dir = "check")
- shell: Rscript {0}
-
- - name: Upload check results
- if: failure()
- uses: actions/upload-artifact@v2
- with:
- name: ${{ runner.os }}-r${{ matrix.config.r }}-results
- path: check
-
- - name: Upload source package
- if: success() && runner.os == 'macOS' && github.event_name != 'pull_request' && github.ref == 'refs/heads/main'
- uses: actions/upload-artifact@v2
- with:
- name: package_tarball
- path: check/*.tar.gz
-
- - name: Test coverage
- if: runner.os == 'macOS'
- run: covr::codecov()
- shell: Rscript {0}
diff --git a/DESCRIPTION b/DESCRIPTION
index a64d41011..98800272f 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
Package: CohortDiagnostics
Type: Package
Title: Diagnostics for OHDSI Cohorts
-Version: 3.1.2
+Version: 3.2.0
Date: 2022-12-19
Authors@R: c(
person("Gowtham", "Rao", email = "rao@ohdsi.org", role = c("aut", "cre")),
@@ -38,42 +38,33 @@ Imports:
SqlRender (>= 1.9.0),
stringr,
tidyr (>= 1.2.0),
- CohortGenerator (>= 0.5.0)
+ CohortGenerator (>= 0.8.0),
+ remotes
Suggests:
- CirceR,
- DT,
Eunomia,
- ggplot2,
- htmltools,
- knitr,
- lubridate,
- pool,
- plotly,
- purrr,
- RColorBrewer,
- remotes,
- rmarkdown,
ROhdsiWebApi (>= 1.2.0),
RSQLite (>= 2.2.1),
scales,
- shiny,
- shinydashboard,
- shinyWidgets,
testthat,
withr,
- zip
+ zip,
+ knitr,
+ shiny,
+ OhdsiShinyModules
Remotes:
ohdsi/Eunomia,
ohdsi/FeatureExtraction,
ohdsi/ResultModelManager,
ohdsi/ROhdsiWebApi,
ohdsi/CirceR,
- ohdsi/CohortGenerator
+ ohdsi/CohortGenerator,
+ ohdsi/OhdsiShinyModules
License: Apache License
VignetteBuilder: knitr
URL: https://ohdsi.github.io/CohortDiagnostics, https://github.com/OHDSI/CohortDiagnostics
BugReports: https://github.com/OHDSI/CohortDiagnostics/issues
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.3
Encoding: UTF-8
Language: en-US
StagedInstall: no
+Config/testthat/edition: 3
diff --git a/NAMESPACE b/NAMESPACE
index 4cf26a2ae..2626704ae 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -16,10 +16,10 @@ export(runCohortRelationshipDiagnostics)
export(runCohortTimeSeriesDiagnostics)
export(uploadResults)
import(DatabaseConnector)
-import(dplyr)
importFrom(CohortGenerator,getCohortTableNames)
importFrom(FeatureExtraction,createDefaultCovariateSettings)
importFrom(FeatureExtraction,createTemporalCovariateSettings)
+importFrom(dplyr,"%>%")
importFrom(grDevices,rgb)
importFrom(methods,is)
importFrom(rlang,.data)
diff --git a/NEWS.md b/NEWS.md
index 7c5d05a72..b4e814573 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,3 +1,17 @@
+CohortDiagnostics 3.2.0
+=======================
+
+1. Do not run orphan concepts checks for any subset cohorts
+
+2. Remove use of lookback period for IR calculations - this is now a setting of the call to the package
+
+3. Added data migration to support subsets in database schema (allow future functionality to take care of them)
+
+4. Added functionality to `launchDiagnosticsExplorer` to make publishing to poist connect/shinyapps.io more straightforward (still requires removal of ggiraph)
+
+5. Moved most shiny code to `OHDSI/OhdsiShinyModules`
+
+
CohortDiagnostics 3.1.2
=======================
Bug Fixes:
diff --git a/R/CohortCharacterizationDiagnostics.R b/R/CohortCharacterizationDiagnostics.R
index 690c81905..74f65d3fd 100644
--- a/R/CohortCharacterizationDiagnostics.R
+++ b/R/CohortCharacterizationDiagnostics.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -65,7 +65,7 @@ getCohortCharacteristics <- function(connectionDetails = NULL,
results$covariateRef <- featureExtractionOutput$covariateRef
} else {
covariateIds <- results$covariateRef %>%
- dplyr::select(covariateId)
+ dplyr::select("covariateId")
Andromeda::appendToTable(
results$covariateRef,
featureExtractionOutput$covariateRef %>%
@@ -80,7 +80,7 @@ getCohortCharacteristics <- function(connectionDetails = NULL,
if ("covariates" %in% names(featureExtractionOutput) &&
dplyr::pull(dplyr::count(featureExtractionOutput$covariates)) > 0) {
covariates <- featureExtractionOutput$covariates %>%
- dplyr::rename(cohortId = cohortDefinitionId) %>%
+ dplyr::rename("cohortId" = "cohortDefinitionId") %>%
dplyr::left_join(populationSize, by = "cohortId", copy = TRUE) %>%
dplyr::mutate(p = sumValue / populationSize)
@@ -98,18 +98,18 @@ getCohortCharacteristics <- function(connectionDetails = NULL,
covariates <- covariates %>%
dplyr::mutate(sd = sqrt(p * (1 - p))) %>%
dplyr::select(-p) %>%
- dplyr::rename(mean = averageValue) %>%
+ dplyr::rename("mean" = "averageValue") %>%
dplyr::select(-populationSize)
if (FeatureExtraction::isTemporalCovariateData(featureExtractionOutput)) {
covariates <- covariates %>%
dplyr::select(
- cohortId,
- timeId,
- covariateId,
- sumValue,
- mean,
- sd
+ "cohortId",
+ "timeId",
+ "covariateId",
+ "sumValue",
+ "mean",
+ "sd"
)
if (length(is.na(covariates$timeId)) > 0) {
covariates[is.na(covariates$timeId), ]$timeId <- -1
@@ -118,12 +118,12 @@ getCohortCharacteristics <- function(connectionDetails = NULL,
covariates <- covariates %>%
dplyr::mutate(timeId = 0) %>%
dplyr::select(
- cohortId,
- timeId,
- covariateId,
- sumValue,
- mean,
- sd
+ "cohortId",
+ "timeId",
+ "covariateId",
+ "sumValue",
+ "mean",
+ "sd"
)
}
if ("covariates" %in% names(results)) {
@@ -146,12 +146,12 @@ getCohortCharacteristics <- function(connectionDetails = NULL,
covariates <- covariates %>%
dplyr::mutate(sumValue = -1) %>%
dplyr::select(
- cohortId,
- timeId,
- covariateId,
- sumValue,
- mean,
- sd
+ "cohortId",
+ "timeId",
+ "covariateId",
+ "sumValue",
+ "mean",
+ "sd"
)
if (length(is.na(covariates$timeId)) > 0) {
covariates[is.na(covariates$timeId), ]$timeId <- -1
@@ -163,12 +163,12 @@ getCohortCharacteristics <- function(connectionDetails = NULL,
timeId = 0
) %>%
dplyr::select(
- cohortId,
- timeId,
- covariateId,
- sumValue,
- mean,
- sd
+ "cohortId",
+ "timeId",
+ "covariateId",
+ "sumValue",
+ "mean",
+ "sd"
)
}
if ("covariates" %in% names(results)) {
diff --git a/R/CohortDiagnostics.R b/R/CohortDiagnostics.R
index ce76c4c30..4000bc030 100644
--- a/R/CohortDiagnostics.R
+++ b/R/CohortDiagnostics.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -21,7 +21,7 @@
#' @importFrom grDevices rgb
#' @importFrom stats aggregate
#' @importFrom utils write.csv install.packages menu unzip setTxtProgressBar txtProgressBar packageName
-#' @import dplyr
+#' @importFrom dplyr %>%
#' @importFrom rlang .data
#' @importFrom methods is
#' @importFrom FeatureExtraction createDefaultCovariateSettings createTemporalCovariateSettings
diff --git a/R/CohortLevelDiagnostics.R b/R/CohortLevelDiagnostics.R
index bbe61d67e..19fa236ea 100644
--- a/R/CohortLevelDiagnostics.R
+++ b/R/CohortLevelDiagnostics.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
diff --git a/R/CohortRelationship.R b/R/CohortRelationship.R
index 9ee7e252e..ed56c1f01 100644
--- a/R/CohortRelationship.R
+++ b/R/CohortRelationship.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
diff --git a/R/ConceptIds.R b/R/ConceptIds.R
index 02ba96bec..32f89a29e 100644
--- a/R/ConceptIds.R
+++ b/R/ConceptIds.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
diff --git a/R/ConceptSetUtils.R b/R/ConceptSetUtils.R
new file mode 100644
index 000000000..ec54929fe
--- /dev/null
+++ b/R/ConceptSetUtils.R
@@ -0,0 +1,103 @@
+# Copyright 2023 Observational Health Data Sciences and Informatics
+#
+# This file is part of CohortDiagnostics
+#
+# 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.
+
+.findOrphanConcepts <- function(connectionDetails = NULL,
+ connection = NULL,
+ cdmDatabaseSchema,
+ vocabularyDatabaseSchema = cdmDatabaseSchema,
+ tempEmulationSchema = NULL,
+ conceptIds = c(),
+ useCodesetTable = FALSE,
+ codesetId = 1,
+ conceptCountsDatabaseSchema = cdmDatabaseSchema,
+ conceptCountsTable = "concept_counts",
+ conceptCountsTableIsTemp = FALSE,
+ instantiatedCodeSets = "#InstConceptSets",
+ orphanConceptTable = "#recommended_concepts") {
+ if (is.null(connection)) {
+ connection <- DatabaseConnector::connect(connectionDetails)
+ on.exit(DatabaseConnector::disconnect(connection))
+ }
+ sql <- SqlRender::loadRenderTranslateSql(
+ "OrphanCodes.sql",
+ packageName = utils::packageName(),
+ dbms = connection@dbms,
+ tempEmulationSchema = tempEmulationSchema,
+ vocabulary_database_schema = vocabularyDatabaseSchema,
+ work_database_schema = conceptCountsDatabaseSchema,
+ concept_counts_table = conceptCountsTable,
+ concept_counts_table_is_temp = conceptCountsTableIsTemp,
+ concept_ids = conceptIds,
+ use_codesets_table = useCodesetTable,
+ orphan_concept_table = orphanConceptTable,
+ instantiated_code_sets = instantiatedCodeSets,
+ codeset_id = codesetId
+ )
+ DatabaseConnector::executeSql(connection, sql)
+ ParallelLogger::logTrace("- Fetching orphan concepts from server")
+ sql <- "SELECT * FROM @orphan_concept_table;"
+ orphanConcepts <-
+ DatabaseConnector::renderTranslateQuerySql(
+ sql = sql,
+ connection = connection,
+ tempEmulationSchema = tempEmulationSchema,
+ orphan_concept_table = orphanConceptTable,
+ snakeCaseToCamelCase = TRUE
+ ) %>%
+ tidyr::tibble()
+
+ ParallelLogger::logTrace("- Dropping orphan temp tables")
+ sql <-
+ SqlRender::loadRenderTranslateSql(
+ "DropOrphanConceptTempTables.sql",
+ packageName = utils::packageName(),
+ dbms = connection@dbms,
+ tempEmulationSchema = tempEmulationSchema
+ )
+ DatabaseConnector::executeSql(
+ connection = connection,
+ sql = sql,
+ progressBar = FALSE,
+ reportOverallTime = FALSE
+ )
+ return(orphanConcepts)
+}
+
+createConceptCountsTable <- function(connectionDetails = NULL,
+ connection = NULL,
+ cdmDatabaseSchema,
+ tempEmulationSchema = NULL,
+ conceptCountsDatabaseSchema = cdmDatabaseSchema,
+ conceptCountsTable = "concept_counts",
+ conceptCountsTableIsTemp = FALSE) {
+ ParallelLogger::logInfo("Creating internal concept counts table")
+ if (is.null(connection)) {
+ connection <- DatabaseConnector::connect(connectionDetails)
+ on.exit(DatabaseConnector::disconnect(connection))
+ }
+ sql <-
+ SqlRender::loadRenderTranslateSql(
+ "CreateConceptCountTable.sql",
+ packageName = utils::packageName(),
+ dbms = connection@dbms,
+ tempEmulationSchema = tempEmulationSchema,
+ cdm_database_schema = cdmDatabaseSchema,
+ work_database_schema = conceptCountsDatabaseSchema,
+ concept_counts_table = conceptCountsTable,
+ table_is_temp = conceptCountsTableIsTemp
+ )
+ DatabaseConnector::executeSql(connection, sql)
+}
diff --git a/R/ConceptSets.R b/R/ConceptSets.R
index 36d63fae9..ee6308b28 100644
--- a/R/ConceptSets.R
+++ b/R/ConceptSets.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -94,6 +94,17 @@ extractConceptSetsJsonFromCohortJson <- function(cohortJson) {
return(dplyr::bind_rows(conceptSetExpression))
}
+getParentCohort <- function(cohort, cohortDefinitionSet) {
+ if (is.null(cohort$subsetParent) || cohort$cohortId == cohort$subsetParent) {
+ return(cohort)
+ }
+
+ return(getParentCohort(
+ cohortDefinitionSet %>% dplyr::filter(.data$cohortId == cohort$subsetParent),
+ cohortDefinitionSet
+ ))
+}
+
combineConceptSetsFromCohorts <- function(cohorts) {
# cohorts should be a dataframe with at least cohortId, sql and json
@@ -126,30 +137,40 @@ combineConceptSetsFromCohorts <- function(cohorts) {
for (i in (1:nrow(cohorts))) {
cohort <- cohorts[i, ]
- sql <-
+
+ if (isTRUE(cohort$isSubset)) {
+ parent <- getParentCohort(cohort, cohorts)
+ cohortSql <- parent$sql
+ cohortJson <- parent$json
+ } else {
+ cohortSql <- cohort$sql
+ cohortJson <- cohort$json
+ }
+
+ sqlCs <-
extractConceptSetsSqlFromCohortSql(cohortSql = cohort$sql)
- json <-
+ jsonCs <-
extractConceptSetsJsonFromCohortJson(cohortJson = cohort$json)
- if (nrow(sql) == 0 || nrow(json) == 0) {
+ if (nrow(sqlCs) == 0 || nrow(jsonCs) == 0) {
ParallelLogger::logInfo(
"Cohort Definition expression does not have a concept set expression. ",
"Skipping Cohort: ",
cohort$cohortName
)
} else {
- if (!length(sql$conceptSetId %>% unique()) == length(json$conceptSetId %>% unique())) {
+ if (!length(sqlCs$conceptSetId %>% unique()) == length(jsonCs$conceptSetId %>% unique())) {
stop(
"Mismatch in concept set IDs between SQL and JSON for cohort ",
cohort$cohortFullName
)
}
- if (length(sql) > 0 && length(json) > 0) {
+ if (length(sqlCs) > 0 && length(jsonCs) > 0) {
conceptSetCounter <- conceptSetCounter + 1
conceptSets[[conceptSetCounter]] <-
tidyr::tibble(
cohortId = cohort$cohortId,
- dplyr::inner_join(x = sql, y = json, by = "conceptSetId")
+ dplyr::inner_join(x = sqlCs %>% dplyr::distinct(), y = jsonCs %>% dplyr::distinct(), by = "conceptSetId")
)
}
}
@@ -158,25 +179,25 @@ combineConceptSetsFromCohorts <- function(cohorts) {
return(NULL)
}
conceptSets <- dplyr::bind_rows(conceptSets) %>%
- dplyr::arrange(cohortId, conceptSetId)
+ dplyr::arrange(.data$cohortId, .data$conceptSetId)
uniqueConceptSets <- conceptSets %>%
- dplyr::select(conceptSetExpression) %>%
- dplyr::distinct() %>%
- dplyr::mutate(uniqueConceptSetId = dplyr::row_number())
+ dplyr::select("conceptSetExpression") %>%
+ dplyr::mutate(uniqueConceptSetId = dplyr::row_number()) %>%
+ dplyr::distinct()
conceptSets <- conceptSets %>%
dplyr::inner_join(uniqueConceptSets, by = "conceptSetExpression") %>%
dplyr::distinct() %>%
dplyr::relocate(
- uniqueConceptSetId,
- cohortId,
- conceptSetId
+ "uniqueConceptSetId",
+ "cohortId",
+ "conceptSetId"
) %>%
dplyr::arrange(
- uniqueConceptSetId,
- cohortId,
- conceptSetId
+ .data$uniqueConceptSetId,
+ .data$cohortId,
+ .data$conceptSetId
)
return(conceptSets)
}
@@ -225,60 +246,62 @@ mergeTempTables <-
instantiateUniqueConceptSets <- function(uniqueConceptSets,
connection,
- cdmDatabaseSchema,
- vocabularyDatabaseSchema = cdmDatabaseSchema,
+ vocabularyDatabaseSchema,
tempEmulationSchema,
conceptSetsTable = "#inst_concept_sets") {
ParallelLogger::logInfo("Instantiating concept sets")
- sql <- sapply(
- split(uniqueConceptSets, 1:nrow(uniqueConceptSets)),
- function(x) {
- sub(
- "SELECT [0-9]+ as codeset_id",
- sprintf("SELECT %s as codeset_id", x$uniqueConceptSetId),
- x$conceptSetSql
+
+ if (nrow(uniqueConceptSets) > 0) {
+ sql <- sapply(
+ split(uniqueConceptSets, 1:nrow(uniqueConceptSets)),
+ function(x) {
+ sub(
+ "SELECT [0-9]+ as codeset_id",
+ sprintf("SELECT %s as codeset_id", x$uniqueConceptSetId),
+ x$conceptSetSql
+ )
+ }
+ )
+
+ batchSize <- 100
+ tempTables <- c()
+ pb <- utils::txtProgressBar(style = 3)
+ for (start in seq(1, length(sql), by = batchSize)) {
+ utils::setTxtProgressBar(pb, start / length(sql))
+ tempTable <-
+ paste("#", paste(sample(letters, 20, replace = TRUE), collapse = ""), sep = "")
+ tempTables <- c(tempTables, tempTable)
+ end <- min(start + batchSize - 1, length(sql))
+ sqlSubset <- sql[start:end]
+ sqlSubset <- paste(sqlSubset, collapse = "\n\n UNION ALL\n\n")
+ sqlSubset <-
+ sprintf(
+ "SELECT *\nINTO %s\nFROM (\n %s\n) tmp;",
+ tempTable,
+ sqlSubset
+ )
+ sqlSubset <-
+ SqlRender::render(sqlSubset, vocabulary_database_schema = vocabularyDatabaseSchema)
+ sqlSubset <- SqlRender::translate(sqlSubset,
+ targetDialect = connection@dbms,
+ tempEmulationSchema = tempEmulationSchema
+ )
+ DatabaseConnector::executeSql(connection,
+ sqlSubset,
+ progressBar = FALSE,
+ reportOverallTime = FALSE
)
}
- )
+ utils::setTxtProgressBar(pb, 1)
+ close(pb)
- batchSize <- 100
- tempTables <- c()
- pb <- utils::txtProgressBar(style = 3)
- for (start in seq(1, length(sql), by = batchSize)) {
- utils::setTxtProgressBar(pb, start / length(sql))
- tempTable <-
- paste("#", paste(sample(letters, 20, replace = TRUE), collapse = ""), sep = "")
- tempTables <- c(tempTables, tempTable)
- end <- min(start + batchSize - 1, length(sql))
- sqlSubset <- sql[start:end]
- sqlSubset <- paste(sqlSubset, collapse = "\n\n UNION ALL\n\n")
- sqlSubset <-
- sprintf(
- "SELECT *\nINTO %s\nFROM (\n %s\n) tmp;",
- tempTable,
- sqlSubset
- )
- sqlSubset <-
- SqlRender::render(sqlSubset, vocabulary_database_schema = vocabularyDatabaseSchema)
- sqlSubset <- SqlRender::translate(sqlSubset,
- targetDialect = connection@dbms,
+ mergeTempTables(
+ connection = connection,
+ tableName = conceptSetsTable,
+ tempTables = tempTables,
tempEmulationSchema = tempEmulationSchema
)
- DatabaseConnector::executeSql(connection,
- sqlSubset,
- progressBar = FALSE,
- reportOverallTime = FALSE
- )
}
- utils::setTxtProgressBar(pb, 1)
- close(pb)
-
- mergeTempTables(
- connection = connection,
- tableName = conceptSetsTable,
- tempTables = tempTables,
- tempEmulationSchema = tempEmulationSchema
- )
}
getCodeSetId <- function(criterion) {
@@ -298,7 +321,7 @@ getCodeSetIds <- function(criterionList) {
return(NULL)
} else {
return(dplyr::tibble(domain = names(criterionList), codeSetIds = codeSetIds)
- %>% filter(!is.na(codeSetIds)))
+ %>% dplyr::filter(!is.na(codeSetIds)))
}
}
@@ -326,6 +349,7 @@ runConceptSetDiagnostics <- function(connection,
ParallelLogger::logInfo("Starting concept set diagnostics")
startConceptSetDiagnostics <- Sys.time()
subset <- dplyr::tibble()
+
if (runIncludedSourceConcepts) {
subsetIncluded <- subsetToRequiredCohorts(
cohorts = cohorts,
@@ -360,7 +384,10 @@ runConceptSetDiagnostics <- function(connection,
return()
}
- conceptSets <- combineConceptSetsFromCohorts(subset)
+ # We need to get concept sets from all cohorts in case subsets are present and
+ # Added incrementally after cohort generation
+ conceptSets <- combineConceptSetsFromCohorts(cohorts)
+ conceptSets <- conceptSets %>% dplyr::filter(.data$cohortId %in% subset$cohortId)
if (is.null(conceptSets)) {
ParallelLogger::logInfo(
@@ -387,7 +414,12 @@ runConceptSetDiagnostics <- function(connection,
uniqueConceptSets <-
conceptSets[!duplicated(conceptSets$uniqueConceptSetId), ] %>%
- dplyr::select(-cohortId, -conceptSetId)
+ dplyr::select(-"cohortId", -"conceptSetId")
+
+ if (nrow(uniqueConceptSets) == 0) {
+ ParallelLogger::logInfo("No concept sets found - skipping")
+ return(NULL)
+ }
timeExecution(
exportFolder,
@@ -398,7 +430,6 @@ runConceptSetDiagnostics <- function(connection,
instantiateUniqueConceptSets(
uniqueConceptSets = uniqueConceptSets,
connection = connection,
- cdmDatabaseSchema = cdmDatabaseSchema,
vocabularyDatabaseSchema = vocabularyDatabaseSchema,
tempEmulationSchema = tempEmulationSchema,
conceptSetsTable = "#inst_concept_sets"
@@ -468,36 +499,37 @@ runConceptSetDiagnostics <- function(connection,
tidyr::tibble()
counts <- counts %>%
- dplyr::rename(uniqueConceptSetId = conceptSetId) %>%
+ dplyr::distinct() %>%
+ dplyr::rename("uniqueConceptSetId" = "conceptSetId") %>%
dplyr::inner_join(
conceptSets %>% dplyr::select(
- uniqueConceptSetId,
- cohortId,
- conceptSetId
- ),
+ "uniqueConceptSetId",
+ "cohortId",
+ "conceptSetId"
+ ) %>% dplyr::distinct(),
by = "uniqueConceptSetId"
) %>%
- dplyr::select(-uniqueConceptSetId) %>%
+ dplyr::select(-"uniqueConceptSetId") %>%
dplyr::mutate(databaseId = !!databaseId) %>%
dplyr::relocate(
- databaseId,
- cohortId,
- conceptSetId,
- conceptId
+ "databaseId",
+ "cohortId",
+ "conceptSetId",
+ "conceptId"
) %>%
dplyr::distinct()
counts <- counts %>%
dplyr::group_by(
- databaseId,
- cohortId,
- conceptSetId,
- conceptId,
- sourceConceptId
+ .data$databaseId,
+ .data$cohortId,
+ .data$conceptSetId,
+ .data$conceptId,
+ .data$sourceConceptId
) %>%
dplyr::summarise(
- conceptCount = max(conceptCount),
- conceptSubjects = max(conceptSubjects)
+ conceptCount = max(.data$conceptCount),
+ conceptSubjects = max(.data$conceptSubjects)
) %>%
dplyr::ungroup()
@@ -583,7 +615,7 @@ runConceptSetDiagnostics <- function(connection,
guess_max = min(1e7)
)
- getBreakdownIndexEvents <- function(cohort) {
+ getCohortIndexEventBreakdown <- function(cohort) {
ParallelLogger::logInfo(
"- Breaking down index events for cohort '",
cohort$cohortName,
@@ -596,14 +628,28 @@ runConceptSetDiagnostics <- function(connection,
cohortIds = cohort$cohortId,
parent = "runConceptSetDiagnostics",
expr = {
+ if (isTRUE(cohort$isSubset)) {
+ parent <- getParentCohort(cohort, cohorts)
+ jsonDef <- parent$json
+ } else {
+ jsonDef <- cohort$json
+ }
+
cohortDefinition <-
- RJSONIO::fromJSON(cohort$json, digits = 23)
+ RJSONIO::fromJSON(jsonDef, digits = 23)
+
primaryCodesetIds <-
lapply(
cohortDefinition$PrimaryCriteria$CriteriaList,
getCodeSetIds
- ) %>%
- dplyr::bind_rows()
+ )
+
+ if (length(primaryCodesetIds)) {
+ primaryCodesetIds <- dplyr::bind_rows(primaryCodesetIds)
+ } else {
+ primaryCodesetIds <- data.frame()
+ }
+
if (nrow(primaryCodesetIds) == 0) {
warning(
"No primary event criteria concept sets found for cohort id: ",
@@ -624,9 +670,13 @@ runConceptSetDiagnostics <- function(connection,
return(tidyr::tibble())
}
primaryCodesetIds <- conceptSets %>%
- dplyr::filter(cohortId %in% cohort$cohortId) %>%
- dplyr::select(codeSetIds = conceptSetId, uniqueConceptSetId) %>%
- dplyr::inner_join(primaryCodesetIds, by = "codeSetIds")
+ dplyr::filter(.data$cohortId %in% cohort$cohortId) %>%
+ dplyr::select(
+ codeSetIds = "conceptSetId",
+ "uniqueConceptSetId"
+ ) %>%
+ dplyr::distinct() %>%
+ dplyr::inner_join(primaryCodesetIds %>% dplyr::distinct(), by = "codeSetIds")
pasteIds <- function(row) {
return(dplyr::tibble(
@@ -640,10 +690,15 @@ runConceptSetDiagnostics <- function(connection,
split(primaryCodesetIds, primaryCodesetIds$domain),
pasteIds
)
- primaryCodesetIds <- dplyr::bind_rows(primaryCodesetIds)
+
+ if (length(primaryCodesetIds) == 0) {
+ primaryCodesetIds <- data.frame()
+ } else {
+ primaryCodesetIds <- dplyr::bind_rows(primaryCodesetIds)
+ }
getCounts <- function(row) {
- domain <- domains[domains$domain == row$domain, ]
+ domain <- domains %>% dplyr::filter(.data$domain == row$domain)
sql <-
SqlRender::loadRenderTranslateSql(
"CohortEntryBreakdown.sql",
@@ -709,10 +764,16 @@ runConceptSetDiagnostics <- function(connection,
return(counts)
}
- counts <-
- lapply(split(primaryCodesetIds, 1:nrow(primaryCodesetIds)), getCounts) %>%
- dplyr::bind_rows() %>%
- dplyr::arrange(conceptCount)
+
+ if (nrow(primaryCodesetIds) > 0) {
+ counts <-
+ lapply(split(primaryCodesetIds, 1:nrow(primaryCodesetIds)), getCounts) %>%
+ dplyr::bind_rows() %>%
+ dplyr::arrange(.data$conceptCount)
+ } else {
+ counts <- data.frame()
+ }
+
if (nrow(counts) > 0) {
counts$cohortId <- cohort$cohortId
@@ -731,7 +792,7 @@ runConceptSetDiagnostics <- function(connection,
data <-
lapply(
split(subsetBreakdown, subsetBreakdown$cohortId),
- getBreakdownIndexEvents
+ getCohortIndexEventBreakdown
)
data <- dplyr::bind_rows(data)
if (nrow(data) > 0) {
@@ -806,7 +867,7 @@ runConceptSetDiagnostics <- function(connection,
exportFolder,
taskName = "orphanConcepts",
parent = "runConceptSetDiagnostics",
- cohortIds = paste("concept_set-", conceptSet$name),
+ cohortIds = paste("concept_set-", conceptSet$conceptSetName),
expr = {
data[[i]] <- .findOrphanConcepts(
connection = connection,
@@ -848,30 +909,31 @@ runConceptSetDiagnostics <- function(connection,
reportOverallTime = FALSE
)
}
+
data <- dplyr::bind_rows(data) %>%
dplyr::distinct() %>%
- dplyr::rename(uniqueConceptSetId = codesetId) %>%
+ dplyr::rename("uniqueConceptSetId" = "codesetId") %>%
dplyr::inner_join(
conceptSets %>%
dplyr::select(
- uniqueConceptSetId,
- cohortId,
- conceptSetId
- ),
+ "uniqueConceptSetId",
+ "cohortId",
+ "conceptSetId"
+ ) %>% dplyr::distinct(),
by = "uniqueConceptSetId"
) %>%
- dplyr::select(-uniqueConceptSetId) %>%
+ dplyr::select(-"uniqueConceptSetId") %>%
dplyr::select(
- cohortId,
- conceptSetId,
- conceptId,
- conceptCount,
- conceptSubjects
+ "cohortId",
+ "conceptSetId",
+ "conceptId",
+ "conceptCount",
+ "conceptSubjects"
) %>%
dplyr::group_by(
- cohortId,
- conceptSetId,
- conceptId
+ .data$cohortId,
+ .data$conceptSetId,
+ .data$conceptId
) %>%
dplyr::summarise(
conceptCount = max(conceptCount),
@@ -936,21 +998,20 @@ runConceptSetDiagnostics <- function(connection,
resolvedConceptIds <-
DatabaseConnector::renderTranslateQuerySql(
connection = connection,
- sql = "SELECT *
- FROM #inst_concept_sets;",
+ sql = "SELECT * FROM #inst_concept_sets;",
tempEmulationSchema = tempEmulationSchema,
snakeCaseToCamelCase = TRUE
) %>%
dplyr::tibble() %>%
- dplyr::rename(uniqueConceptSetId = codesetId) %>%
- dplyr::inner_join(conceptSets,
+ dplyr::rename("uniqueConceptSetId" = "codesetId") %>%
+ dplyr::inner_join(conceptSets %>% dplyr::distinct(),
by = "uniqueConceptSetId"
) %>%
dplyr::select(
- cohortId,
- conceptSetId,
- conceptId
- )
+ "cohortId",
+ "conceptSetId",
+ "conceptId"
+ ) %>% dplyr::distinct()
resolvedConceptIds <- makeDataExportable(
x = resolvedConceptIds,
diff --git a/R/DataSourceInformation.R b/R/DataSourceInformation.R
index de9e2b785..1b1be6211 100644
--- a/R/DataSourceInformation.R
+++ b/R/DataSourceInformation.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -91,7 +91,7 @@ getCdmDataSourceInformation <-
sourceReleaseDate <- as.Date(NA)
if ("sourceReleaseDate" %in% colnames(cdmDataSource)) {
- if (class(cdmDataSource$sourceReleaseDate) != "Date") {
+ if (!is(cdmDataSource$sourceReleaseDate, "Date")) {
try(
sourceReleaseDate <-
max(as.Date(cdmDataSource$sourceReleaseDate)),
@@ -104,7 +104,7 @@ getCdmDataSourceInformation <-
cdmReleaseDate <- as.Date(NA)
if ("cdmReleaseDate" %in% colnames(cdmDataSource)) {
- if (class(cdmDataSource$cdmReleaseDate) != "Date") {
+ if (!is(cdmDataSource$cdmReleaseDate, "Date")) {
try(cdmReleaseDate <- max(as.Date(cdmDataSource$cdmReleaseDate)),
silent = TRUE
)
diff --git a/R/ExportCharacterization.R b/R/ExportCharacterization.R
index d4d344ed7..c82a1f9bb 100644
--- a/R/ExportCharacterization.R
+++ b/R/ExportCharacterization.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
diff --git a/R/IncidenceRates.R b/R/IncidenceRates.R
index b74908de7..743d1167f 100644
--- a/R/IncidenceRates.R
+++ b/R/IncidenceRates.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -210,6 +210,7 @@ computeIncidenceRates <- function(connection,
cohorts,
instantiatedCohorts,
recordKeepingFile,
+ washoutPeriod,
incremental) {
ParallelLogger::logInfo("Computing incidence rates")
startIncidenceRate <- Sys.time()
@@ -236,13 +237,6 @@ computeIncidenceRates <- function(connection,
"'"
)
- # TODO: do we really want to get this from the cohort definition?
- cohortExpression <- RJSONIO::fromJSON(row$json, digits = 23)
- washoutPeriod <- cohortExpression$PrimaryCriteria$ObservationWindow[["PriorDays"]]
- if (is.null(washoutPeriod)) {
- washoutPeriod <- 0
- }
-
timeExecution(
exportFolder,
taskName = "getIncidenceRate",
diff --git a/R/InclusionRules.R b/R/InclusionRules.R
index 5fb8dbea0..8648f10f9 100644
--- a/R/InclusionRules.R
+++ b/R/InclusionRules.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
diff --git a/R/Incremental.R b/R/Incremental.R
index 34373f55b..b49dfb199 100644
--- a/R/Incremental.R
+++ b/R/Incremental.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -188,14 +188,14 @@ writeToCsv.tbl_Andromeda <-
batchSize <- 1e5
cohortIds <- data %>%
- distinct(cohortId) %>%
- pull()
+ dplyr::distinct("cohortId") %>%
+ dplyr::pull()
tempName <- paste0(fileName, "2")
processChunk <- function(chunk, pos) {
chunk <- chunk %>%
- filter(!cohort_id %in% cohortIds)
+ dplyr::filter(!.data$cohort_id %in% cohortIds)
readr::write_csv(chunk, tempName, append = (pos != 1))
}
diff --git a/R/MetaDataDiagnostics.R b/R/MetaDataDiagnostics.R
index 9c9b29138..1ca3caf51 100644
--- a/R/MetaDataDiagnostics.R
+++ b/R/MetaDataDiagnostics.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -14,113 +14,6 @@
# See the License for the specific language governing permissions and
# limitations under the License.
-.findOrphanConcepts <- function(connectionDetails = NULL,
- connection = NULL,
- cdmDatabaseSchema,
- vocabularyDatabaseSchema = cdmDatabaseSchema,
- tempEmulationSchema = NULL,
- conceptIds = c(),
- useCodesetTable = FALSE,
- codesetId = 1,
- conceptCountsDatabaseSchema = cdmDatabaseSchema,
- conceptCountsTable = "concept_counts",
- conceptCountsTableIsTemp = FALSE,
- instantiatedCodeSets = "#InstConceptSets",
- orphanConceptTable = "#recommended_concepts") {
- if (is.null(connection)) {
- connection <- DatabaseConnector::connect(connectionDetails)
- on.exit(DatabaseConnector::disconnect(connection))
- }
- sql <- SqlRender::loadRenderTranslateSql(
- "OrphanCodes.sql",
- packageName = utils::packageName(),
- dbms = connection@dbms,
- tempEmulationSchema = tempEmulationSchema,
- vocabulary_database_schema = vocabularyDatabaseSchema,
- work_database_schema = conceptCountsDatabaseSchema,
- concept_counts_table = conceptCountsTable,
- concept_counts_table_is_temp = conceptCountsTableIsTemp,
- concept_ids = conceptIds,
- use_codesets_table = useCodesetTable,
- orphan_concept_table = orphanConceptTable,
- instantiated_code_sets = instantiatedCodeSets,
- codeset_id = codesetId
- )
- DatabaseConnector::executeSql(connection, sql)
- ParallelLogger::logTrace("- Fetching orphan concepts from server")
- sql <- "SELECT * FROM @orphan_concept_table;"
- orphanConcepts <-
- DatabaseConnector::renderTranslateQuerySql(
- sql = sql,
- connection = connection,
- tempEmulationSchema = tempEmulationSchema,
- orphan_concept_table = orphanConceptTable,
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- # For debugging:
- # x <- querySql(connection, "SELECT * FROM #starting_concepts;")
- # View(x)
- #
- # x <- querySql(connection, "SELECT * FROM #concept_synonyms;")
- # View(x)
- #
- # x <- querySql(connection, "SELECT * FROM #search_strings;")
- # View(x)
- #
- # x <- querySql(connection, "SELECT * FROM #search_str_top1000;")
- # View(x)
- #
- # x <- querySql(connection, "SELECT * FROM #search_string_subset;")
- # View(x)
- #
- # x <- querySql(connection, "SELECT * FROM #recommended_concepts;")
- # View(x)
-
- ParallelLogger::logTrace("- Dropping orphan temp tables")
- sql <-
- SqlRender::loadRenderTranslateSql(
- "DropOrphanConceptTempTables.sql",
- packageName = utils::packageName(),
- dbms = connection@dbms,
- tempEmulationSchema = tempEmulationSchema
- )
- DatabaseConnector::executeSql(
- connection = connection,
- sql = sql,
- progressBar = FALSE,
- reportOverallTime = FALSE
- )
- return(orphanConcepts)
-}
-
-createConceptCountsTable <- function(connectionDetails = NULL,
- connection = NULL,
- cdmDatabaseSchema,
- tempEmulationSchema = NULL,
- conceptCountsDatabaseSchema = cdmDatabaseSchema,
- conceptCountsTable = "concept_counts",
- conceptCountsTableIsTemp = FALSE) {
- ParallelLogger::logInfo("Creating internal concept counts table")
- if (is.null(connection)) {
- connection <- DatabaseConnector::connect(connectionDetails)
- on.exit(DatabaseConnector::disconnect(connection))
- }
- sql <-
- SqlRender::loadRenderTranslateSql(
- "CreateConceptCountTable.sql",
- packageName = utils::packageName(),
- dbms = connection@dbms,
- tempEmulationSchema = tempEmulationSchema,
- cdm_database_schema = cdmDatabaseSchema,
- work_database_schema = conceptCountsDatabaseSchema,
- concept_counts_table = conceptCountsTable,
- table_is_temp = conceptCountsTableIsTemp
- )
- DatabaseConnector::executeSql(connection, sql)
-}
-
saveDatabaseMetaData <- function(databaseId,
databaseName,
databaseDescription,
@@ -166,7 +59,7 @@ getVocabularyVersion <- function(connection, vocabularyDatabaseSchema) {
snakeCaseToCamelCase = TRUE
) %>%
dplyr::tibble() %>%
- dplyr::rename(vocabularyVersion = vocabularyVersion) %>%
+ dplyr::rename("vocabularyVersion" = "vocabularyVersion") %>%
dplyr::pull(vocabularyVersion) %>%
unique()
diff --git a/R/Private.R b/R/Private.R
index 188b074ea..c8381f1a9 100644
--- a/R/Private.R
+++ b/R/Private.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -20,7 +20,7 @@ createIfNotExist <-
recursive = TRUE,
errorMessage = NULL) {
if (is.null(errorMessage) |
- !class(errorMessage) == "AssertColection") {
+ !is(errorMessage, "AssertColection")) {
errorMessage <- checkmate::makeAssertCollection()
}
if (!is.null(type)) {
@@ -129,7 +129,7 @@ makeDataExportable <- function(x,
if ("cohortDefinitionId" %in% colnames(x)) {
x <- x %>%
- dplyr::rename(cohortId = cohortDefinitionId)
+ dplyr::rename("cohortId" = "cohortDefinitionId")
}
resultsDataModel <- getResultsDataModelSpecifications()
@@ -140,27 +140,27 @@ makeDataExportable <- function(x,
}
fieldsInDataModel <- resultsDataModel %>%
- dplyr::filter(tableName == !!tableName) %>%
+ dplyr::filter(.data$tableName == !!tableName) %>%
dplyr::pull(columnName) %>%
SqlRender::snakeCaseToCamelCase() %>%
unique()
requiredFieldsInDataModel <- resultsDataModel %>%
- dplyr::filter(tableName == !!tableName) %>%
+ dplyr::filter(.data$tableName == !!tableName) %>%
dplyr::filter(isRequired == "Yes") %>%
dplyr::pull(columnName) %>%
SqlRender::snakeCaseToCamelCase() %>%
unique()
primaryKeyInDataModel <- resultsDataModel %>%
- dplyr::filter(tableName == !!tableName) %>%
+ dplyr::filter(.data$tableName == !!tableName) %>%
dplyr::filter(primaryKey == "Yes") %>%
dplyr::pull(columnName) %>%
SqlRender::snakeCaseToCamelCase() %>%
unique()
columnsToApplyMinCellValue <- resultsDataModel %>%
- dplyr::filter(tableName == !!tableName) %>%
+ dplyr::filter(.data$tableName == !!tableName) %>%
dplyr::filter(minCellCount == "Yes") %>%
dplyr::pull(columnName) %>%
SqlRender::snakeCaseToCamelCase() %>%
diff --git a/R/ResultsDataModel.R b/R/ResultsDataModel.R
index c908ab3ef..b8ec4fcd7 100644
--- a/R/ResultsDataModel.R
+++ b/R/ResultsDataModel.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -26,6 +26,8 @@ getResultsDataModelSpecifications <- function() {
system.file("settings", "resultsDataModelSpecification.csv", package = utils::packageName())
resultsDataModelSpecifications <-
readr::read_csv(file = pathToCsv, col_types = readr::cols())
+
+ colnames(resultsDataModelSpecifications) <- SqlRender::snakeCaseToCamelCase(colnames(resultsDataModelSpecifications))
return(resultsDataModelSpecifications)
}
@@ -37,210 +39,13 @@ getResultsDataModelSpecifications <- function() {
#' @export
getDefaultVocabularyTableNames <- function() {
getResultsDataModelSpecifications() %>%
- dplyr::filter(isVocabularyTable == "Yes") %>%
- dplyr::pull(tableName) %>%
+ dplyr::filter(.data$isVocabularyTable == "Yes") %>%
+ dplyr::pull(.data$tableName) %>%
unique() %>%
sort() %>%
SqlRender::snakeCaseToCamelCase()
}
-fixTableMetadataForBackwardCompatibility <- function(table, tableName) {
- if (tableName %in% c("cohort")) {
- if (!"metadata" %in% colnames(table)) {
- data <- list()
- for (i in (1:nrow(table))) {
- data[[i]] <- table[i, ]
- colnamesDf <- colnames(data[[i]])
- metaDataList <- list()
- for (j in (1:length(colnamesDf))) {
- metaDataList[[colnamesDf[[j]]]] <- data[[i]][colnamesDf[[j]]] %>% dplyr::pull()
- }
- data[[i]]$metadata <-
- RJSONIO::toJSON(metaDataList, pretty = TRUE, digits = 23)
- }
- table <- dplyr::bind_rows(data)
- }
- if ("referent_concept_id" %in% colnames(table)) {
- table <- table %>%
- dplyr::select(-referent_concept_id)
- }
- }
- if (tableName %in% c("covariate_value", "temporal_covariate_value")) {
- if (!"sum_value" %in% colnames(table)) {
- table$sum_value <- -1
- }
- }
- return(table)
-}
-
-checkFixColumnNames <-
- function(table,
- tableName,
- zipFileName,
- specifications = getResultsDataModelSpecifications()) {
- if (tableName %in% c(
- "cohort", "phenotype_description",
- "covariate_value", "temporal_covariate_value"
- )) {
- table <- fixTableMetadataForBackwardCompatibility(
- table = table,
- tableName = tableName
- )
- }
- observeredNames <- colnames(table)[order(colnames(table))]
-
- tableSpecs <- specifications %>%
- dplyr::filter(tableName == !!tableName)
-
- optionalNames <- tableSpecs %>%
- dplyr::filter(optional == "Yes") %>%
- dplyr::select(columnName)
-
- expectedNames <- tableSpecs %>%
- dplyr::select(columnName) %>%
- dplyr::anti_join(dplyr::filter(optionalNames, !columnName %in% observeredNames),
- by = "columnName"
- ) %>%
- dplyr::arrange(columnName) %>%
- dplyr::pull()
-
- if (!checkmate::testNames(observeredNames, must.include = expectedNames)) {
- stop(
- sprintf(
- "Column names of table %s in zip file %s do not match specifications.\n- Observed columns: %s\n- Expected columns: %s",
- tableName,
- zipFileName,
- paste(observeredNames, collapse = ", "),
- paste(expectedNames, collapse = ", ")
- )
- )
- }
-
- sharedFields <- intersect(
- x = observeredNames,
- y = tableSpecs$columnName
- )
- table <- table %>%
- dplyr::select(dplyr::all_of(sharedFields))
- return(table)
- }
-
-checkAndFixDataTypes <-
- function(table,
- tableName,
- zipFileName,
- specifications = getResultsDataModelSpecifications()) {
- tableSpecs <- specifications %>%
- filter(tableName == !!tableName)
-
- observedTypes <- sapply(table, class)
- for (i in 1:length(observedTypes)) {
- columnName <- names(observedTypes)[i]
- expectedType <-
- gsub("\\(.*\\)", "", tolower(tableSpecs$dataType[tableSpecs$columnName == columnName]))
- if (expectedType == "bigint" || expectedType == "float") {
- if (observedTypes[i] != "numeric" && observedTypes[i] != "double") {
- ParallelLogger::logDebug(
- sprintf(
- "Field %s in table %s in zip file %s is of type %s, but was expecting %s. Attempting to convert.",
- columnName,
- tableName,
- zipFileName,
- observedTypes[i],
- expectedType
- )
- )
- table <- mutate_at(table, i, as.numeric)
- }
- } else if (expectedType == "int") {
- if (observedTypes[i] != "integer") {
- ParallelLogger::logDebug(
- sprintf(
- "Field %s in table %s in zip file %s is of type %s, but was expecting %s. Attempting to convert.",
- columnName,
- tableName,
- zipFileName,
- observedTypes[i],
- expectedType
- )
- )
- table <- mutate_at(table, i, as.integer)
- }
- } else if (expectedType == "varchar") {
- if (observedTypes[i] != "character") {
- ParallelLogger::logDebug(
- sprintf(
- "Field %s in table %s in zip file %s is of type %s, but was expecting %s. Attempting to convert.",
- columnName,
- tableName,
- zipFileName,
- observedTypes[i],
- expectedType
- )
- )
- table <- mutate_at(table, i, as.character)
- }
- } else if (expectedType == "date") {
- if (observedTypes[i] != "Date") {
- ParallelLogger::logDebug(
- sprintf(
- "Field %s in table %s in zip file %s is of type %s, but was expecting %s. Attempting to convert.",
- columnName,
- tableName,
- zipFileName,
- observedTypes[i],
- expectedType
- )
- )
- table <- mutate_at(table, i, as.Date)
- }
- }
- }
- return(table)
- }
-
-checkAndFixDuplicateRows <-
- function(table,
- tableName,
- zipFileName,
- specifications = getResultsDataModelSpecifications()) {
- primaryKeys <- specifications %>%
- dplyr::filter(tableName == !!tableName &
- primaryKey == "Yes") %>%
- dplyr::select(columnName) %>%
- dplyr::pull()
- duplicatedRows <- duplicated(table[, primaryKeys])
- if (any(duplicatedRows)) {
- ParallelLogger::logInfo(
- sprintf(
- "Table %s in zip file %s has duplicate rows. Removing %s records.",
- tableName,
- zipFileName,
- sum(duplicatedRows)
- )
- )
- return(table[!duplicatedRows, ])
- } else {
- return(table)
- }
- }
-
-appendNewRows <-
- function(data,
- newData,
- tableName,
- specifications = getResultsDataModelSpecifications()) {
- if (nrow(data) > 0) {
- primaryKeys <- specifications %>%
- dplyr::filter(tableName == !!tableName &
- primaryKey == "Yes") %>%
- dplyr::select(columnName) %>%
- dplyr::pull()
- newData <- newData %>%
- dplyr::anti_join(data, by = primaryKeys)
- }
- return(dplyr::bind_rows(data, newData))
- }
# Private function for testing migrations in isolation
.createDataModel <- function(connection, databaseSchema, tablePrefix) {
@@ -287,16 +92,6 @@ createResultsDataModel <- function(connectionDetails = NULL,
)
}
-naToEmpty <- function(x) {
- x[is.na(x)] <- ""
- return(x)
-}
-
-naToZero <- function(x) {
- x[is.na(x)] <- 0
- return(x)
-}
-
#' Upload results to the database server.
#'
#' @description
@@ -320,7 +115,7 @@ naToZero <- function(x) {
#' up when the function is finished. Can be used to specify a temp folder on a drive that
#' has sufficient space if the default system temp space is too limited.
#' @param tablePrefix (Optional) string to insert before table names (e.g. "cd_") for database table names
-#'
+#' @param ... See ResultModelManager::uploadResults
#' @export
uploadResults <- function(connectionDetails,
schema,
@@ -328,15 +123,8 @@ uploadResults <- function(connectionDetails,
forceOverWriteOfSpecifications = FALSE,
purgeSiteDataBeforeUploading = TRUE,
tempFolder = tempdir(),
- tablePrefix = "") {
- if (connectionDetails$dbms == "sqlite" & schema != "main") {
- stop("Invalid schema for sqlite, use schema = 'main'")
- }
-
- start <- Sys.time()
- connection <- DatabaseConnector::connect(connectionDetails)
- on.exit(DatabaseConnector::disconnect(connection))
-
+ tablePrefix = "",
+ ...) {
unzipFolder <- tempfile("unzipTempFolder", tmpdir = tempFolder)
dir.create(path = unzipFolder, recursive = TRUE)
on.exit(unlink(unzipFolder, recursive = TRUE), add = TRUE)
@@ -344,263 +132,19 @@ uploadResults <- function(connectionDetails,
ParallelLogger::logInfo("Unzipping ", zipFileName)
zip::unzip(zipFileName, exdir = unzipFolder)
- specifications <- getResultsDataModelSpecifications()
- databaseFile <- file.path(unzipFolder, "database.csv")
- # check required tables are found in folder
- if (!file.exists(databaseFile)) {
- stop("database metadata file not found - cannot upload results")
- }
-
- database <-
- readr::read_csv(
- file = databaseFile,
- col_types = readr::cols()
- )
- colnames(database) <-
- SqlRender::snakeCaseToCamelCase(colnames(database))
- databaseId <- database$databaseId
-
-
- uploadTable <- function(tableName) {
- ParallelLogger::logInfo("Uploading table ", tableName)
-
- primaryKey <- specifications %>%
- filter(tableName == !!tableName &
- primaryKey == "Yes") %>%
- select(columnName) %>%
- pull()
-
- if (purgeSiteDataBeforeUploading &&
- "database_id" %in% primaryKey) {
- deleteAllRecordsForDatabaseId(
- connection = connection,
- schema = schema,
- tableName = tableName,
- databaseId = databaseId,
- tablePrefix = tablePrefix
- )
- }
-
- csvFileName <- paste0(tableName, ".csv")
- if (csvFileName %in% list.files(unzipFolder)) {
- env <- new.env()
- env$schema <- schema
- env$tableName <- tableName
- env$primaryKey <- primaryKey
- env$tablePrefix <- tablePrefix
- if (purgeSiteDataBeforeUploading &&
- "database_id" %in% primaryKey) {
- env$primaryKeyValuesInDb <- NULL
- } else if (length(primaryKey) > 0) {
- sql <- "SELECT DISTINCT @primary_key FROM @schema.@table_prefix@table_name;"
- sql <- SqlRender::render(
- sql = sql,
- primary_key = primaryKey,
- schema = schema,
- table_name = tableName,
- table_prefix = tablePrefix
- )
- primaryKeyValuesInDb <-
- DatabaseConnector::querySql(connection, sql)
- colnames(primaryKeyValuesInDb) <-
- tolower(colnames(primaryKeyValuesInDb))
- env$primaryKeyValuesInDb <- primaryKeyValuesInDb
- }
-
- uploadChunk <- function(chunk, pos) {
- ParallelLogger::logInfo(
- "- Preparing to upload rows ",
- pos,
- " through ",
- pos + nrow(chunk) - 1
- )
-
- chunk <- checkFixColumnNames(
- table = chunk,
- tableName = env$tableName,
- zipFileName = zipFileName,
- specifications = specifications
- )
- chunk <- checkAndFixDataTypes(
- table = chunk,
- tableName = env$tableName,
- zipFileName = zipFileName,
- specifications = specifications
- )
- chunk <- checkAndFixDuplicateRows(
- table = chunk,
- tableName = env$tableName,
- zipFileName = zipFileName,
- specifications = specifications
- )
-
- # Primary key fields cannot be NULL, so for some tables convert NAs to empty or zero:
- toEmpty <- specifications %>%
- filter(
- tableName == env$tableName &
- emptyIsNa == "No" &
- grepl("varchar", dataType)
- ) %>%
- select(columnName) %>%
- pull()
- if (length(toEmpty) > 0) {
- chunk <- chunk %>%
- dplyr::mutate_at(toEmpty, naToEmpty)
- }
-
- tozero <- specifications %>%
- filter(
- tableName == env$tableName &
- emptyIsNa == "No" &
- dataType %in% c("int", "bigint", "float")
- ) %>%
- select(columnName) %>%
- pull()
- if (length(tozero) > 0) {
- chunk <- chunk %>%
- dplyr::mutate_at(tozero, naToZero)
- }
-
- # Check if inserting data would violate primary key constraints:
- if (!is.null(env$primaryKeyValuesInDb)) {
- primaryKeyValuesInChunk <- unique(chunk[env$primaryKey])
- duplicates <- inner_join(env$primaryKeyValuesInDb,
- primaryKeyValuesInChunk,
- by = env$primaryKey
- )
- if (nrow(duplicates) != 0) {
- if ("database_id" %in% env$primaryKey ||
- forceOverWriteOfSpecifications) {
- ParallelLogger::logInfo(
- "- Found ",
- nrow(duplicates),
- " rows in database with the same primary key ",
- "as the data to insert. Deleting from database before inserting."
- )
- deleteFromServer(
- connection = connection,
- schema = env$schema,
- tableName = env$tableName,
- keyValues = duplicates,
- tablePrefix = tablePrefix
- )
- } else {
- ParallelLogger::logInfo(
- "- Found ",
- nrow(duplicates),
- " rows in database with the same primary key ",
- "as the data to insert. Removing from data to insert."
- )
- chunk <- chunk %>%
- anti_join(duplicates, by = env$primaryKey)
- }
- # Remove duplicates we already dealt with:
- env$primaryKeyValuesInDb <- env$primaryKeyValuesInDb %>%
- anti_join(duplicates, by = env$primaryKey)
- }
- }
- if (nrow(chunk) == 0) {
- ParallelLogger::logInfo("- No data left to insert")
- } else {
- DatabaseConnector::insertTable(
- connection = connection,
- tableName = paste0(tablePrefix, env$tableName),
- databaseSchema = env$schema,
- data = chunk,
- dropTableIfExists = FALSE,
- createTable = FALSE,
- tempTable = FALSE,
- progressBar = TRUE
- )
- }
- }
-
- readr::read_csv_chunked(
- file = file.path(unzipFolder, csvFileName),
- callback = uploadChunk,
- chunk_size = 1e7,
- col_types = readr::cols(),
- guess_max = 1e6,
- progress = FALSE
- )
- }
- }
-
- invisible(lapply(unique(specifications$tableName), uploadTable))
- delta <- Sys.time() - start
- writeLines(paste("Uploading data took", signif(delta, 3), attr(delta, "units")))
-}
-
-deleteFromServer <-
- function(connection, schema, tableName, keyValues, tablePrefix) {
- createSqlStatement <- function(i) {
- sql <- paste0(
- "DELETE FROM ",
- schema,
- ".",
- tablePrefix,
- tableName,
- "\nWHERE ",
- paste(paste0(
- colnames(keyValues), " = '", keyValues[i, ], "'"
- ), collapse = " AND "),
- ";"
- )
- return(sql)
- }
-
- batchSize <- 1000
- for (start in seq(1, nrow(keyValues), by = batchSize)) {
- end <- min(start + batchSize - 1, nrow(keyValues))
- sql <- sapply(start:end, createSqlStatement)
- sql <- paste(sql, collapse = "\n")
- DatabaseConnector::executeSql(
- connection,
- sql,
- progressBar = FALSE,
- reportOverallTime = FALSE,
- runAsBatch = TRUE
- )
- }
- }
-
-deleteAllRecordsForDatabaseId <- function(connection,
- schema,
- tableName,
- databaseId,
- tablePrefix = "") {
- sql <-
- "SELECT COUNT(*) FROM @schema.@table_name WHERE database_id = '@database_id';"
- sql <- SqlRender::render(
- sql = sql,
+ ResultModelManager::uploadResults(
+ connectionDetails = connectionDetails,
schema = schema,
- table_name = paste0(tablePrefix, tableName),
- database_id = databaseId
+ resultsFolder = unzipFolder,
+ tablePrefix = tablePrefix,
+ forceOverWriteOfSpecifications = forceOverWriteOfSpecifications,
+ purgeSiteDataBeforeUploading = purgeSiteDataBeforeUploading,
+ runCheckAndFixCommands = TRUE,
+ databaseIdentifierFile = "database.csv",
+ specifications = getResultsDataModelSpecifications(),
+ warnOnMissingTable = FALSE,
+ ...
)
- databaseIdCount <-
- DatabaseConnector::renderTranslateQuerySql(connection, sql)[, 1]
- if (databaseIdCount != 0) {
- ParallelLogger::logInfo(
- sprintf(
- "- Found %s rows in database with database ID '%s'. Deleting all before inserting.",
- databaseIdCount,
- databaseId
- )
- )
- sql <-
- "DELETE FROM @schema.@table_name WHERE database_id = '@database_id';"
- sql <- SqlRender::render(
- sql = sql,
- schema = schema,
- table_name = paste0(tablePrefix, tableName),
- database_id = databaseId,
- )
- DatabaseConnector::renderTranslateExecuteSql(connection,
- sql,
- progressBar = FALSE,
- reportOverallTime = FALSE
- )
- }
}
#' Migrate Data model
diff --git a/R/RunDiagnostics.R b/R/RunDiagnostics.R
index 0746b4175..0a1ec2d78 100644
--- a/R/RunDiagnostics.R
+++ b/R/RunDiagnostics.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -132,6 +132,7 @@ getDefaultCovariateSettings <- function() {
#' @param minCharacterizationMean The minimum mean value for characterization output. Values below this will be cut off from output. This
#' will help reduce the file size of the characterization output, but will remove information
#' on covariates that have very low values. The default is 0.001 (i.e. 0.1 percent)
+#' @param irWashoutPeriod Number of days washout to include in calculation of incidence rates - default is 0
#' @param incremental Create only cohort diagnostics that haven't been created before?
#' @param incrementalFolder If \code{incremental = TRUE}, specify a folder where records are kept
#' of which cohort diagnostics has been executed.
@@ -208,6 +209,7 @@ executeDiagnostics <- function(cohortDefinitionSet,
temporalCovariateSettings = getDefaultCovariateSettings(),
minCellCount = 5,
minCharacterizationMean = 0.01,
+ irWashoutPeriod = 0,
incremental = FALSE,
incrementalFolder = file.path(exportFolder, "incremental")) {
# collect arguments that were passed to cohort diagnostics at initiation
@@ -351,7 +353,7 @@ executeDiagnostics <- function(cohortDefinitionSet,
)
}
if (runTemporalCohortCharacterization) {
- if (class(temporalCovariateSettings) == "covariateSettings") {
+ if (is(temporalCovariateSettings, "covariateSettings")) {
temporalCovariateSettings <- list(temporalCovariateSettings)
}
# All temporal covariate settings objects must be covariateSettings
@@ -451,15 +453,15 @@ executeDiagnostics <- function(cohortDefinitionSet,
sort()
cohortTableColumnNamesExpected <-
getResultsDataModelSpecifications() %>%
- dplyr::filter(tableName == "cohort") %>%
- dplyr::pull(columnName) %>%
+ dplyr::filter(.data$tableName == "cohort") %>%
+ dplyr::pull(.data$columnName) %>%
SqlRender::snakeCaseToCamelCase() %>%
sort()
cohortTableColumnNamesRequired <-
getResultsDataModelSpecifications() %>%
- dplyr::filter(tableName == "cohort") %>%
- dplyr::filter(isRequired == "Yes") %>%
- dplyr::pull(columnName) %>%
+ dplyr::filter(.data$tableName == "cohort") %>%
+ dplyr::filter(.data$isRequired == "Yes") %>%
+ dplyr::pull(.data$columnName) %>%
SqlRender::snakeCaseToCamelCase() %>%
sort()
@@ -500,6 +502,22 @@ executeDiagnostics <- function(cohortDefinitionSet,
fileName = file.path(exportFolder, "cohort.csv")
)
+ subsets <- CohortGenerator::getSubsetDefinitions(cohortDefinitionSet)
+ if (length(subsets)) {
+ dfs <- lapply(subsets, function(x) {
+ data.frame(subsetDefinitionId = x$definitionId, json = as.character(x$toJSON()))
+ })
+ subsetDefinitions <- data.frame()
+ for (subsetDef in dfs) {
+ subsetDefinitions <- rbind(subsetDefinitions, dfs)
+ }
+
+ writeToCsv(
+ data = subsetDefinitions,
+ fileName = file.path(exportFolder, "subset_definition.csv")
+ )
+ }
+
# Set up connection to server ----------------------------------------------------
if (is.null(connection)) {
if (!is.null(connectionDetails)) {
@@ -761,6 +779,7 @@ executeDiagnostics <- function(cohortDefinitionSet,
exportFolder = exportFolder,
minCellCount = minCellCount,
cohorts = cohortDefinitionSet,
+ washoutPeriod = irWashoutPeriod,
instantiatedCohorts = instantiatedCohorts,
recordKeepingFile = recordKeepingFile,
incremental = incremental
diff --git a/R/Shared.R b/R/Shared.R
index 2e1069a33..96d2b6343 100644
--- a/R/Shared.R
+++ b/R/Shared.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
diff --git a/R/Shiny.R b/R/Shiny.R
index d00937df1..0e357c875 100644
--- a/R/Shiny.R
+++ b/R/Shiny.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -40,6 +40,10 @@
#' @param cohortTableName (Optional) if cohort table name differs from the standard - cohort (ignores prefix if set)
#' @param databaseTableName (Optional) if database table name differs from the standard - database (ignores prefix if set)
#'
+#' @param makePublishable (Optional) copy data files to make app publishable to posit connect/shinyapp.io
+#' @param publishDir If make publishable is true - the directory that the shiny app is copied to
+#' @param overwritePublishDir (Optional) If make publishable is true - overwrite the directory for publishing
+#'
#' @details
#' Launches a Shiny app that allows the user to explore the diagnostics
#'
@@ -56,8 +60,12 @@ launchDiagnosticsExplorer <- function(sqliteDbPath = "MergedCohortDiagnosticsDat
aboutText = NULL,
runOverNetwork = FALSE,
port = 80,
+ makePublishable = FALSE,
+ publishDir = file.path(getwd(), "DiagnosticsExplorer"),
+ overwritePublishDir = FALSE,
launch.browser = FALSE,
enableAnnotation = TRUE) {
+ useShinyPublishFile <- FALSE
if (is.null(shinyConfigPath)) {
if (is.null(connectionDetails)) {
sqliteDbPath <- normalizePath(sqliteDbPath)
@@ -68,6 +76,7 @@ launchDiagnosticsExplorer <- function(sqliteDbPath = "MergedCohortDiagnosticsDat
resultsDatabaseSchema <- "main"
vocabularyDatabaseSchemas <- "main"
connectionDetails <- DatabaseConnector::createConnectionDetails(dbms = "sqlite", server = sqliteDbPath)
+ useShinyPublishFile <- TRUE
}
if (is.null(resultsDatabaseSchema)) {
@@ -109,50 +118,42 @@ launchDiagnosticsExplorer <- function(sqliteDbPath = "MergedCohortDiagnosticsDat
on.exit(options("CD-shiny-config" = NULL))
}
- ensure_installed(c(
- "checkmate",
- "DatabaseConnector",
- "dplyr",
- "plyr",
- "ggplot2",
- "ggiraph",
- "gtable",
- "htmltools",
- "lubridate",
- "pool",
- "purrr",
- "scales",
- "shiny",
- "shinydashboard",
- "shinyWidgets",
- "shinyjs",
- "shinycssloaders",
- "stringr",
- "SqlRender",
- "tidyr",
- "CirceR",
- "rmarkdown",
- "reactable",
- "markdownInput",
- "markdown",
- "jsonlite",
- "ggh4x",
- "yaml"
- ))
+ if (!"OhdsiShinyModules" %in% as.data.frame(installed.packages())$Package) {
+ remotes::install_github("OHDSI/OhdsiShinyModules")
+ }
appDir <-
system.file("shiny", "DiagnosticsExplorer", package = utils::packageName())
+ if (makePublishable) {
+ if (dir.exists(publishDir) && !overwritePublishDir) {
+ warning("Directory for publishing exists, use overwritePublishDir to overwrite")
+ } else {
+ if (getwd() == publishDir) {
+ stop("Publishable dir should not be current working directory")
+ }
+
+ dir.create(publishDir, showWarnings = FALSE)
+ filesToCopy <- file.path(appDir, list.files(appDir))
+ file.copy(filesToCopy, publishDir, recursive = TRUE, overwrite = TRUE)
+ if (useShinyPublishFile) {
+ file.copy(sqliteDbPath, file.path(publishDir, "data", "MergedCohortDiagnosticsData.sqlite"), overwrite = TRUE)
+ } else if (is.null(shinyConfigPath)) {
+ stop("Cannot make publishable shiny app when using connectionDetails object. Please create a config file")
+ } else {
+ file.copy(shinyConfigPath, file.path(publishDir, "config.yml"))
+ }
+ }
+ appDir <- publishDir
+ }
+
if (launch.browser) {
options(shiny.launch.browser = TRUE)
}
if (runOverNetwork) {
- myIpAddress <- system("ipconfig", intern = TRUE)
- myIpAddress <- myIpAddress[grep("IPv4", myIpAddress)]
- myIpAddress <- gsub(".*? ([[:digit:]])", "\\1", myIpAddress)
options(shiny.port = port)
- options(shiny.host = myIpAddress)
+ options(shiny.host = "0.0.0.0")
}
shiny::runApp(appDir = appDir)
@@ -255,23 +256,3 @@ createDiagnosticsExplorerZip <- function(outputZipfile = file.path(getwd(), "Dia
DatabaseConnector::createZipFile(outputZipfile, file.path(tmpDir, "DiagnosticsExplorer"), rootFolder = tmpDir)
}
-
-ensure_installed <- function(pkgs) {
- notInstalled <- pkgs[!(pkgs %in% rownames(installed.packages()))]
-
- if (interactive() & length(notInstalled) > 0) {
- message(paste("Package(s): ", paste(paste(notInstalled, collapse = ", "), "not installed")))
- if (!isTRUE(utils::askYesNo("Would you like to install them?"))) {
- return(invisible(NULL))
- }
- }
- for (pkg in notInstalled) {
- if (pkg == "CirceR") {
- ensure_installed("remotes")
- message("\nInstalling from Github using remotes")
- remotes::install_github("OHDSI/CirceR")
- } else {
- install.packages(pkg)
- }
- }
-}
diff --git a/R/TimeSeries.R b/R/TimeSeries.R
index 682442dd2..d4f84c5d0 100644
--- a/R/TimeSeries.R
+++ b/R/TimeSeries.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -103,7 +103,6 @@ runCohortTimeSeriesDiagnostics <- function(connectionDetails = NULL,
return(NULL)
}
}
-
## Calendar period----
ParallelLogger::logTrace(" - Preparing calendar table for time series computation.")
# note calendar span is created based on all dates in observation period table,
@@ -461,11 +460,11 @@ runCohortTimeSeriesDiagnostics <- function(connectionDetails = NULL,
seriesType,
periodBegin
) %>%
- dplyr::select(-timeId) %>%
+ dplyr::select(-"timeId") %>%
dplyr::mutate(ageGroup = dplyr::if_else(
- condition = is.na(ageGroup),
- true = as.character(ageGroup),
- false = paste(10 * ageGroup, 10 * ageGroup + 9, sep = "-")
+ condition = is.na(.data$ageGroup),
+ true = as.character(.data$ageGroup),
+ false = paste(10 * .data$ageGroup, 10 * .data$ageGroup + 9, sep = "-")
))
resultsInAndromeda$calendarPeriods <- NULL
@@ -529,7 +528,7 @@ executeTimeSeriesDiagnostics <- function(connection,
if (runCohortTimeSeries & nrow(cohortDefinitionSet) > 0) {
subset <- subsetToRequiredCohorts(
cohorts = cohortDefinitionSet %>%
- dplyr::filter(cohortId %in% instantiatedCohorts),
+ dplyr::filter(.data$cohortId %in% instantiatedCohorts),
task = "runCohortTimeSeries",
incremental = incremental,
recordKeepingFile = recordKeepingFile
@@ -587,6 +586,7 @@ executeTimeSeriesDiagnostics <- function(connection,
)
}
)
+
data <- makeDataExportable(
x = data,
tableName = "time_series",
@@ -648,6 +648,7 @@ executeTimeSeriesDiagnostics <- function(connection,
)
}
)
+
data <- makeDataExportable(
x = data,
tableName = "time_series",
diff --git a/R/VisitContext.R b/R/VisitContext.R
index dcd90c0a2..668b728ac 100644
--- a/R/VisitContext.R
+++ b/R/VisitContext.R
@@ -1,4 +1,4 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
diff --git a/extras/CohortDiagnostics.pdf b/extras/CohortDiagnostics.pdf
index 3a6f10116..a1a9c38cd 100644
Binary files a/extras/CohortDiagnostics.pdf and b/extras/CohortDiagnostics.pdf differ
diff --git a/extras/PackageMaintenance.R b/extras/PackageMaintenance.R
index f35342e12..b2f16696e 100644
--- a/extras/PackageMaintenance.R
+++ b/extras/PackageMaintenance.R
@@ -1,6 +1,6 @@
# @file PackageMaintenance
#
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of CohortDiagnostics
#
@@ -21,8 +21,6 @@ OhdsiRTools::checkUsagePackage("CohortDiagnostics")
OhdsiRTools::updateCopyrightYearFolder()
styler::style_pkg()
devtools::spell_check()
-spelling::spell_check_files(list.files(path = "inst/shiny", pattern = "*.html", recursive = TRUE, full.names = TRUE))
-
# Create manual and vignettes:
unlink("extras/CohortDiagnostics.pdf")
diff --git a/inst/doc/RunningCohortDiagnostics.pdf b/inst/doc/RunningCohortDiagnostics.pdf
index 072e180de..d846571b6 100644
Binary files a/inst/doc/RunningCohortDiagnostics.pdf and b/inst/doc/RunningCohortDiagnostics.pdf differ
diff --git a/inst/doc/ViewingResultsUsingDiagnosticsExplorer.pdf b/inst/doc/ViewingResultsUsingDiagnosticsExplorer.pdf
index ba9aa38a2..615f4831b 100644
Binary files a/inst/doc/ViewingResultsUsingDiagnosticsExplorer.pdf and b/inst/doc/ViewingResultsUsingDiagnosticsExplorer.pdf differ
diff --git a/inst/doc/WhatIsCohortDiagnostics.pdf b/inst/doc/WhatIsCohortDiagnostics.pdf
index 5802d638c..a8d6576ea 100644
Binary files a/inst/doc/WhatIsCohortDiagnostics.pdf and b/inst/doc/WhatIsCohortDiagnostics.pdf differ
diff --git a/inst/settings/resultsDataModelSpecification.csv b/inst/settings/resultsDataModelSpecification.csv
index 1af142cec..1d9bb6a69 100644
--- a/inst/settings/resultsDataModelSpecification.csv
+++ b/inst/settings/resultsDataModelSpecification.csv
@@ -1,23 +1,14 @@
-tableName,columnName,dataType,isRequired,primaryKey,optional,emptyIsNa,minCellCount,isVocabularyTable,neverIncremental
-annotation,annotation_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation,created_by,varchar,Yes,No,No,Yes,No,No,No
-annotation,created_on,bigint,Yes,No,No,Yes,No,No,No
-annotation,modified_last_on,bigint,No,No,Yes,Yes,No,No,No
-annotation,deleted_on,bigint,No,No,Yes,Yes,No,No,No
-annotation,annotation,varchar,Yes,No,No,Yes,No,No,No
-annotation_link,annotation_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation_link,diagnostics_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation_link,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation_link,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-annotation_attributes,annotation_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation_attributes,created_by,varchar,Yes,Yes,No,Yes,No,No,No
-annotation_attributes,annotation_attributes,int,Yes,No,No,Yes,No,No,No
-annotation_attributes,created_on,bigint,Yes,No,No,Yes,No,No,No
+table_name,column_name,data_type,is_required,primary_key,optional,empty_is_Na,min_cell_count,is_vocabulary_table,never_incremental
cohort,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
cohort,cohort_name,varchar,Yes,No,No,Yes,No,No,No
cohort,metadata,varchar,No,No,Yes,Yes,No,No,No
+cohort,json,varchar,No,No,Yes,Yes,No,No,No
cohort,sql,varchar,Yes,No,No,Yes,No,No,No
-cohort,json,varchar,Yes,No,No,Yes,No,No,No
+cohort,subset_parent,bigint,No,No,Yes,Yes,No,No,No
+cohort,subset_definition_id,bigint,No,No,Yes,Yes,No,No,No
+cohort,is_subset,int,No,No,Yes,Yes,No,No,No
+subset_definition,subset_definition_id,bigint,Yes,Yes,No,Yes,No,No,No
+subset_definition,json,varchar,Yes,Yes,No,Yes,No,No,No
cohort_count,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
cohort_count,cohort_entries,float,Yes,No,No,Yes,Yes,No,No
cohort_count,cohort_subjects,float,Yes,No,No,Yes,Yes,No,No
diff --git a/inst/shiny/DiagnosticsExplorer/R/Annotation.R b/inst/shiny/DiagnosticsExplorer/R/Annotation.R
deleted file mode 100644
index 850b8fa9b..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/Annotation.R
+++ /dev/null
@@ -1,459 +0,0 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
-#
-# This file is part of CohortDiagnostics
-#
-# 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.
-
-#' @param id unqiue identifier for module. Must match call to annotationModule
-annotationUi <- function(id) {
- ns <- shiny::NS(id)
-
- postAnnotationArea <- shiny::conditionalPanel(
- condition = "output.postAnnotationEnabled == true",
- ns = ns,
- shinydashboard::box(
- title = "Add comment",
- width = NULL,
- collapsible = TRUE,
- collapsed = TRUE,
- column(
- 5,
- shiny::uiOutput(ns("databasePicker"))
- ),
- column(
- 5,
- shinyWidgets::pickerInput(
- inputId = ns("targetCohort"),
- label = "Related Cohorts",
- width = 300,
- choices = c(""),
- selected = c(""),
- multiple = TRUE,
- inline = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- liveSearchStyle = "contains",
- size = 10,
- dropupAuto = TRUE,
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- column(
- 11,
- markdownInput::markdownInput(
- inputId = ns("markdownInputArea"),
- label = "Comment : ",
- theme = "github",
- value = "Write some _markdown_ **here:**"
- )
- ),
- column(
- 1,
- tags$br(),
- shiny::actionButton(
- inputId = ns("postAnnotation"),
- label = "POST",
- width = NULL,
- style = "margin-top: 15px; margin-bottom: 15px;"
- )
- )
- )
- )
-
- return(
- shinydashboard::box(
- title = "Comments",
- width = NULL,
- collapsible = TRUE,
- collapsed = FALSE,
- reactable::reactableOutput(
- outputId = ns("comments"),
- width = NULL
- ),
- tags$style(
- paste0(
- "#output",
- id,
- " {max-height:300px;overflow:auto;padding-left:30px;margin:0 0 30px 10px;border-left:1px solid #eee;}"
- )
- ),
- postAnnotationArea
- )
- )
-}
-
-#' Annoation module
-#' Adds annoation section that allows display and addition of markdown comments for cohorts
-#'
-#' @param id The namespace id of the module instance - must align with `annotationUi`
-#' @param dataSource Database intance used to store comments and retrieve them
-#' @param activeLoggedInUser shiny::reactive that returns the active logged in user that stores the comment
-#' @param selectedDatabaseIds shiny::reactive the current selected by the user
-#' @param postAnnotaionEnabled shiny::reactive - is posting enabled for the user?
-#' @param multiCohortSelection Boolean is the input set of cohorts many or one?
-annotationModule <- function(id,
- dataSource,
- activeLoggedInUser,
- selectedDatabaseIds,
- selectedCohortIds,
- cohortTable,
- databaseTable,
- postAnnotaionEnabled) {
- ns <- shiny::NS(id)
-
- annotationServer <- function(input, output, session) {
- # Annotation Section ------------------------------------
- ## posting annotation enabled ------
- output$postAnnotationEnabled <- shiny::reactive({
- postAnnotaionEnabled() & !is.null(activeLoggedInUser())
- })
- outputOptions(output, "postAnnotationEnabled", suspendWhenHidden = FALSE)
-
- ## Retrieve Annotation ----------------
- reloadAnnotationSection <- reactiveVal(0)
-
- inputCohortIds <- shiny::reactive({
- cohortTable %>%
- dplyr::filter(compoundName %in% selectedCohortIds()) %>%
- dplyr::pull(cohortId)
- })
-
- getAnnotationReactive <- shiny::reactive({
- reloadAnnotationSection()
- results <- getAnnotationResult(
- dataSource = dataSource,
- diagnosticsId = id,
- cohortIds = inputCohortIds(),
- databaseIds = selectedDatabaseIds()
- )
-
- if (!hasData(results)) {
- return(NULL)
- }
- return(results)
- })
-
- markdownModule <- shiny::callModule(markdownInput::moduleMarkdownInput, "markdownInputArea")
-
- dbChoices <- shiny::reactive({
- databaseChoices <- list()
- dbMapping <- databaseTable %>% dplyr::filter(databaseId %in% selectedDatabaseIds())
- for (i in 1:nrow(dbMapping)) {
- row <- dbMapping[i,]
- databaseChoices[row$databaseName] <- row$databaseId
- }
- return(databaseChoices)
- })
-
- output$databasePicker <- shiny::renderUI({
- shinyWidgets::pickerInput(
- inputId = ns("database"),
- label = "Related Database:",
- width = 300,
- choices = dbChoices(),
- selected = dbChoices(),
- multiple = TRUE,
- inline = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- })
-
- shiny::observe({
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "targetCohort",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = selectedCohortIds(),
- selected = selectedCohortIds()
- )
- })
-
- ## renderedAnnotation ----
- output$comments <-
- reactable::renderReactable({
- results <- getAnnotationReactive()
-
- if (is.null(results)) {
- return(NULL)
- }
- data <- results$annotation
- for (i in 1:nrow(data)) {
- data[i,]$annotation <-
- markdown::renderMarkdown(text = data[i,]$annotation)
- }
- data <- data %>%
- dplyr::mutate(
- Annotation = paste0(
- "",
- createdBy,
- "@",
- getTimeFromInteger(createdOn),
- ":",
- annotation
- )
- ) %>%
- dplyr::select(annotationId, Annotation)
-
- reactable::reactable(
- data,
- columns = list(
- annotationId = reactable::colDef(show = FALSE),
- Annotation = reactable::colDef(html = TRUE)
- ),
- details = function(index) {
- subTable <- results$annotationLink %>%
- dplyr::filter(annotationId == data[index,]$annotationId) %>%
- dplyr::inner_join(cohortTable %>%
- dplyr::select(
- cohortId,
- cohortName
- ),
- by = "cohortId"
- )
- distinctCohortName <- subTable %>%
- dplyr::distinct(cohortName)
- distinctDatabaseId <- subTable %>%
- dplyr::distinct(databaseId)
-
- htmltools::div(
- style = "margin:0;padding:0;padding-left:50px;",
- tags$p(
- style = "margin:0;padding:0;",
- "Related Cohorts: ",
- tags$p(
- style = "padding-left:30px;",
- tags$pre(
- paste(distinctCohortName$cohortName, collapse = "\n")
- )
- )
- ),
- tags$br(),
- tags$p(
- "Related Databses: ",
- tags$p(
- style = "padding-left:30px;",
- tags$pre(
- paste(distinctDatabaseId$databaseId, collapse = "\n")
- )
- )
- )
- )
- }
- )
- })
-
-
- ## Post Annotation ----------------
- getParametersToPostAnnotation <- shiny::reactive({
- tempList <- list()
- # Annotation - cohort Ids
- tempList$cohortIds <- inputCohortIds()
-
- # Annotation - database Ids
- if (!is.null(input$database)) {
- selectedDatabaseIds <- input$database
- } else {
- selectedDatabaseIds <- selectedDatabaseIds()
- }
- tempList$databaseIds <- selectedDatabaseIds
- return(tempList)
- })
-
-
- shiny::observeEvent(
- eventExpr = input$postAnnotation,
- handlerExpr = {
- parametersToPostAnnotation <- getParametersToPostAnnotation()
- comment <- markdownModule()
-
- if (comment == "Write some _markdown_ **here:**" |
- is.null(comment) |
- is.null(activeLoggedInUser())) {
- return(NULL)
- }
- createdBy <- activeLoggedInUser()
- result <- postAnnotationResult(
- dataSource = dataSource,
- diagnosticsId = id,
- cohortIds = parametersToPostAnnotation$cohortIds,
- databaseIds = parametersToPostAnnotation$databaseIds,
- annotation = comment,
- createdBy = createdBy,
- createdOn = getTimeAsInteger()
- )
-
- if (result) {
- # trigger reload
- reloadAnnotationSection(reloadAnnotationSection() + 1)
- }
- }
- )
- }
-
- return(shiny::moduleServer(id, annotationServer))
-}
-
-
-postAnnotationResult <- function(dataSource,
- diagnosticsId,
- cohortIds,
- databaseIds,
- annotation,
- createdBy,
- createdOn = getTimeAsInteger(),
- modifiedOn = NULL,
- deletedOn = NULL) {
- # Prevent potential sql injection
- annotation <- gsub("'", "`", annotation)
- sqlInsert <- "INSERT INTO @results_database_schema.annotation (
- annotation_id,
- created_by,
- created_on,
- modified_last_on,
- deleted_on,
- annotation
- )
- SELECT annotation_id,
- '@created_by' created_by,
- @created_on created_on,
- {@modified_last_on == ''} ? {NULL} : {@modified_last_on} modified_last_on,
- {@deleted_on == ''} ? {NULL} : {@deleted_on} deleted_on,
- '@annotation' annotation
- FROM (
- SELECT CASE
- WHEN max(annotation_id) IS NULL
- THEN 1
- ELSE max(annotation_id) + 1
- END AS annotation_id
- FROM @results_database_schema.annotation
- ) F;"
- tryCatch(
- {
- renderTranslateExecuteSql(
- dataSource = dataSource,
- sql = sqlInsert,
- results_database_schema = dataSource$resultsDatabaseSchema,
- annotation = annotation,
- created_by = createdBy,
- created_on = createdOn,
- modified_last_on = modifiedOn,
- deleted_on = deletedOn
- )
- },
- error = function(err) {
- stop(paste("Error while posting the comment, \nDescription:", err))
- }
- )
-
- # get annotation id
- sqlRetrieve <- "SELECT max(annotation_id) annotation_id
- FROM @results_database_schema.annotation
- WHERE created_by = '@created_by'
- AND created_on = @created_on;"
- maxAnnotationId <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sqlRetrieve,
- results_database_schema = dataSource$resultsDatabaseSchema,
- created_by = createdBy,
- created_on = createdOn
- )
-
- maxAnnotationId <- maxAnnotationId$annotation_id
-
- # insert annotation link
- annotationLink <-
- tidyr::crossing(
- annotationId = !!maxAnnotationId,
- diagnosticsId = !!diagnosticsId,
- cohortId = !!cohortIds,
- databaseId = !!databaseIds
- )
- realConnection <- pool::poolCheckout(dataSource$connection)
- DatabaseConnector::insertTable(
- connection = realConnection,
- databaseSchema = dataSource$resultsDatabaseSchema,
- tableName = "annotation_link",
- createTable = FALSE,
- dropTableIfExists = FALSE,
- tempTable = FALSE,
- progressBar = FALSE,
- camelCaseToSnakeCase = TRUE,
- data = annotationLink
- )
- pool::poolReturn(realConnection)
- return(TRUE)
-}
-
-
-getAnnotationResult <- function(dataSource,
- diagnosticsId,
- cohortIds,
- databaseIds) {
- data <- NULL
- annotationLink <- NULL
- if (hasData(cohortIds) & hasData(databaseIds)) {
- # get annotation id's
- sqlRetrieveAnnotationLink <- "SELECT *
- FROM @results_database_schema.annotation_link
- WHERE diagnostics_id = '@diagnosticsId'
- AND cohort_id IN (@cohortIds)
- AND database_id IN (@databaseIds);"
- annotationLink <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sqlRetrieveAnnotationLink,
- results_database_schema = dataSource$resultsDatabaseSchema,
- diagnosticsId = diagnosticsId,
- cohortIds = cohortIds,
- databaseIds = quoteLiterals(databaseIds),
- snakeCaseToCamelCase = TRUE
- )
- }
- if (hasData(annotationLink)) {
- sqlRetrieveAnnotation <- "SELECT *
- FROM @results_database_schema.annotation
- WHERE annotation_id IN (@annotationIds);"
-
- annotation <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sqlRetrieveAnnotation,
- results_database_schema = dataSource$resultsDatabaseSchema,
- annotationIds = annotationLink$annotationId,
- snakeCaseToCamelCase = TRUE
- )
-
- if (hasData(annotation)) {
- data <- list(annotation = annotation,
- annotationLink = annotationLink)
- }
- }
-
- return(data)
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/CharacterizationModule.R b/inst/shiny/DiagnosticsExplorer/R/CharacterizationModule.R
deleted file mode 100644
index 3dbda5787..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/CharacterizationModule.R
+++ /dev/null
@@ -1,778 +0,0 @@
-characterizationView <- function(id) {
- ns <- shiny::NS(id)
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Cohort Characterization",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "cohortCharacterization.html"))
- ),
- shinydashboard::box(
- width = NULL,
- shiny::radioButtons(
- inputId = ns("charType"),
- label = "Table type",
- choices = c("Pretty", "Raw"),
- selected = "Pretty",
- inline = TRUE
- ),
- shiny::fluidRow(
- shiny::column(
- width = 5,
- shinyWidgets::pickerInput(
- inputId = ns("targetCohort"),
- label = "Select Cohort",
- choices = NULL,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- maxOptions = 5, # Selecting even this many will be slow
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::column(
- width = 5,
- shinyWidgets::pickerInput(
- inputId = ns("targetDatabase"),
- label = "Select Database (s)",
- choices = NULL,
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- )
- ),
- shiny::conditionalPanel(
- condition = "input.charType == 'Raw'",
- ns = ns,
- shiny::fluidRow(
- shiny::column(
- width = 4,
- shinyWidgets::pickerInput(
- inputId = ns("timeIdChoices"),
- label = "Temporal Window (s)",
- choices = NULL,
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- selected = NULL,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- maxOptions = 5, # Selecting even this many will be slow
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::column(
- width = 4,
- shinyWidgets::pickerInput(
- inputId = ns("characterizationAnalysisNameFilter"),
- label = "Analysis name",
- choices = c(""),
- selected = c(""),
- inline = TRUE,
- multiple = TRUE,
- width = "100%",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::column(
- width = 4,
- shinyWidgets::pickerInput(
- inputId = ns("characterizationDomainIdFilter"),
- label = "Domain name",
- choices = c(""),
- selected = c(""),
- inline = TRUE,
- multiple = TRUE,
- width = "100%",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- )
- )
- ),
- shiny::conditionalPanel(
- ns = ns,
- condition = "input.charType == 'Pretty'",
- shiny::actionButton(label = "Generate Table", inputId = ns("generateReport"))
- ),
- shiny::conditionalPanel(
- ns = ns,
- condition = "input.charType == 'Raw'",
- shiny::actionButton(label = "Generate Table", inputId = ns("generateRaw"))
- ),
- ),
- shiny::conditionalPanel(
- condition = "input.generateReport > 0 && input.charType == 'Pretty'",
- ns = ns,
- shiny::uiOutput(outputId = ns("selections")),
- shinydashboard::box(
- width = NULL,
- shinycssloaders::withSpinner(
- reactable::reactableOutput(outputId = ns("characterizationTable"))
- ),
- csvDownloadButton(ns, "characterizationTable")
- )
- ),
- shiny::conditionalPanel(
- condition = "input.generateRaw > 0 && input.charType == 'Raw'",
- ns = ns,
- shiny::uiOutput(outputId = ns("selectionsRaw")),
- shinydashboard::box(
- width = NULL,
- shiny::fluidRow(
- shiny::column(
- width = 4,
- shiny::radioButtons(
- inputId = ns("proportionOrContinuous"),
- label = "Covariate type(s)",
- choices = c("All", "Proportion", "Continuous"),
- selected = "All",
- inline = TRUE
- ),
- p("Percentage displayed where only proportional data is selected")
- ),
- shiny::column(
- width = 4,
- shiny::radioButtons(
- inputId = ns("characterizationColumnFilters"),
- label = "Display",
- choices = c("Mean and Standard Deviation", "Mean only"),
- selected = "Mean only",
- inline = TRUE
- )
- ),
- shiny::column(
- width = 4,
- shinyWidgets::pickerInput(
- inputId = ns("selectedConceptSet"),
- label = "Subset to Concept Set",
- choices = NULL,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- )
- ),
- shiny::tabsetPanel(
- type = "pills",
- shiny::tabPanel(
- title = "Group by Database",
- shinycssloaders::withSpinner(
- reactable::reactableOutput(outputId = ns("characterizationTableRaw"))
- ),
- csvDownloadButton(ns, "characterizationTableRaw")
- ),
- shiny::tabPanel(
- title = "Group by Time ID",
- shinycssloaders::withSpinner(
- reactable::reactableOutput(outputId = ns("characterizationTableRawGroupedByTime"))
- ),
- csvDownloadButton(ns, "characterizationTableRawGroupedByTime")
- )
- )
- )
- )
- )
-}
-
-
-characterizationModule <- function(id,
- dataSource,
- cohortTable,
- databaseTable,
- temporalAnalysisRef,
- analysisNameOptions,
- domainIdOptions,
- characterizationTimeIdChoices,
- table1SpecPath = getOption("CD-spec-1-path", "data/Table1SpecsLong.csv")) {
- prettyTable1Specifications <- readr::read_csv(
- file = table1SpecPath,
- col_types = readr::cols(),
- guess_max = min(1e7),
- lazy = FALSE
- )
-
- # Analysis IDs for pretty table
- analysisIdInCohortCharacterization <- c(
- 1, 3, 4, 5, 6, 7,
- 203, 403, 501, 703,
- 801, 901, 903, 904,
- -301, -201
- )
-
- shiny::moduleServer(id, function(input, output, session) {
-
- timeIdOptions <- getResultsTemporalTimeRef(dataSource = dataSource) %>%
- dplyr::arrange(sequence)
-
- selectedTimeIds <- shiny::reactive({
- timeIdOptions %>%
- dplyr::filter(temporalChoices %in% input$timeIdChoices) %>%
- dplyr::select(timeId) %>%
- dplyr::pull()
- })
-
- selectedDatabaseIds <- shiny::reactive(input$targetDatabase)
- targetCohortId <- shiny::reactive(input$targetCohort)
-
- getCohortConceptSets <- shiny::reactive({
- if (!hasData(input$targetCohort) || !hasData(selectedDatabaseIds())) {
- return(NULL)
- }
-
- jsonExpression <- cohortTable %>%
- dplyr::filter(cohortId == input$targetCohort) %>%
- dplyr::select(json)
- jsonExpression <-
- RJSONIO::fromJSON(jsonExpression$json, digits = 23)
- expression <-
- getConceptSetDetailsFromCohortDefinition(cohortDefinitionExpression = jsonExpression)
- if (is.null(expression)) {
- return(NULL)
- }
-
- expression <- expression$conceptSetExpression
- return(expression)
- })
-
- shiny::observe({
- # Default time windows
- selectedTimeWindows <- timeIdOptions %>%
- dplyr::filter(primaryTimeId == 1) %>%
- dplyr::filter(isTemporal == 1) %>%
- dplyr::arrange(sequence) %>%
- dplyr::pull("temporalChoices")
-
- shinyWidgets::updatePickerInput(session,
- inputId = "timeIdChoices",
- choices = timeIdOptions$temporalChoices,
- selected = selectedTimeWindows)
-
- cohortChoices <- cohortTable$cohortId
- names(cohortChoices) <- cohortTable$cohortName
- shinyWidgets::updatePickerInput(session,
- inputId = "targetCohort",
- choices = cohortChoices)
-
-
- databaseChoices <- databaseTable$databaseId
- names(databaseChoices) <- databaseTable$databaseName
- shinyWidgets::updatePickerInput(session,
- inputId = "targetDatabase",
- selected = databaseChoices[1],
- choices = databaseChoices)
- })
-
- conceptSetIds <- shiny::reactive({
- if (input$selectedConceptSet == "") {
- return(NULL)
- }
- input$selectedConceptSet
- })
-
- getResolvedConcepts <- shiny::reactive({
- output <- resolvedConceptSet(
- dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortId = targetCohortId()
- )
- if (!hasData(output)) {
- return(NULL)
- }
- return(output)
- })
-
- ### getMappedConceptsReactive ----
- getMappedConcepts <- shiny::reactive({
- progress <- shiny::Progress$new()
- on.exit(progress$close())
- progress$set(message = "Getting concepts mapped to concept ids resolved by concept set expression (may take time)", value = 0)
- output <- mappedConceptSet(dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortId = targetCohortId())
- if (!hasData(output)) {
- return(NULL)
- }
- return(output)
- })
-
- getFilteredConceptIds <- shiny::reactive({
- validate(need(hasData(selectedDatabaseIds()), "No data sources chosen"))
- validate(need(hasData(targetCohortId()), "No cohort chosen"))
- validate(need(hasData(conceptSetIds()), "No concept set id chosen"))
- resolved <- getResolvedConcepts()
- mapped <- getMappedConcepts()
- output <- c()
- if (hasData(resolved)) {
- resolved <- resolved %>%
- dplyr::filter(databaseId %in% selectedDatabaseIds()) %>%
- dplyr::filter(cohortId %in% targetCohortId()) %>%
- dplyr::filter(conceptSetId %in% conceptSetIds())
- output <- c(output, resolved$conceptId) %>% unique()
- }
- if (hasData(mapped)) {
- mapped <- mapped %>%
- dplyr::filter(databaseId %in% selectedDatabaseIds()) %>%
- dplyr::filter(cohortId %in% targetCohortId()) %>%
- dplyr::filter(conceptSetId %in% conceptSetIds())
- output <- c(output, mapped$conceptId) %>% unique()
- }
-
- if (hasData(output)) {
- return(output)
- } else {
- return(NULL)
- }
- })
-
- selectedConceptSets <- shiny::reactive(input$selectedConceptSet)
-
- selectionsPanel <- shiny::reactive({
- shinydashboard::box(
- status = "warning",
- width = "100%",
- shiny::fluidRow(
- shiny::column(
- width = 4,
- tags$b("Cohort :"),
- paste(cohortTable %>%
- dplyr::filter(cohortId %in% targetCohortId()) %>%
- dplyr::select(cohortName) %>%
- dplyr::pull(),
- collapse = ", ")
- ),
- shiny::column(
- width = 8,
- tags$b("Database(s) :"),
- paste(databaseTable %>%
- dplyr::filter(databaseId %in% selectedDatabaseIds()) %>%
- dplyr::select(databaseName) %>%
- dplyr::pull(),
- collapse = ", ")
- )
- )
- )
- })
-
- selectionsOutput <- shiny::eventReactive(input$generateReport, {
- selectionsPanel()
- })
-
- selectionsOutputRaw <- shiny::eventReactive(input$generateRaw, {
- selectionsPanel()
- })
-
- output$selections <- shiny::renderUI(selectionsOutput())
- output$selectionsRaw <- shiny::renderUI(selectionsOutputRaw())
- # Cohort Characterization -------------------------------------------------
-
- # Temporal characterization ------------
- characterizationOutput <- shiny::reactive({
- validate(need(length(selectedDatabaseIds()) > 0, "At least one data source must be selected"))
- validate(need(length(targetCohortId()) == 1, "One target cohort must be selected"))
-
- progress <- shiny::Progress$new()
- on.exit(progress$close())
- progress$set(
- message = paste0(
- "Retrieving characterization output for cohort id ",
- targetCohortId(),
- " cohorts and ",
- length(selectedDatabaseIds()),
- " data sources."
- ),
- value = 20
- )
- data <- getCharacterizationOutput(
- dataSource = dataSource,
- cohortIds = targetCohortId(),
- databaseIds = selectedDatabaseIds(),
- temporalCovariateValueDist = FALSE
- )
- return(data)
- })
- #### characterizationAnalysisNameFilter ----
- shiny::observe({
- characterizationAnalysisOptionsUniverse <- NULL
- charcterizationAnalysisOptionsSelected <- NULL
-
- if (hasData(temporalAnalysisRef)) {
- characterizationAnalysisOptionsUniverse <- analysisNameOptions
- charcterizationAnalysisOptionsSelected <- temporalAnalysisRef %>%
- dplyr::pull(analysisName) %>%
- unique()
- }
-
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "characterizationAnalysisNameFilter",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = characterizationAnalysisOptionsUniverse,
- selected = charcterizationAnalysisOptionsSelected
- )
- })
-
- ### characterizationDomainNameFilter ----
- shiny::observe({
- characterizationDomainOptionsUniverse <- NULL
- charcterizationDomainOptionsSelected <- NULL
-
- if (hasData(temporalAnalysisRef)) {
- characterizationDomainOptionsUniverse <- domainIdOptions
- charcterizationDomainOptionsSelected <- temporalAnalysisRef %>%
- dplyr::pull(domainId) %>%
- unique()
- }
-
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "characterizationDomainIdFilter",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = characterizationDomainOptionsUniverse,
- selected = charcterizationDomainOptionsSelected
- )
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "characterizationDomainIdFilter",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = characterizationDomainOptionsUniverse,
- selected = charcterizationDomainOptionsSelected
- )
- })
-
- ## cohortCharacterizationPrettyTable ----
- cohortCharacterizationPrettyTable <- shiny::eventReactive(input$generateReport, {
- data <-
- characterizationOutput()
- if (!hasData(data)) {
- return(NULL)
- }
- data <- data$covariateValue
- if (!hasData(data)) {
- return(NULL)
- }
-
- data <- data %>%
- dplyr::filter(analysisId %in% analysisIdInCohortCharacterization) %>%
- dplyr::filter(timeId %in% c(characterizationTimeIdChoices$timeId %>% unique(), NA))
- if (!hasData(data)) {
- return(NULL)
- }
-
- data <- data %>%
- dplyr::select(
- cohortId,
- databaseId,
- analysisId,
- covariateId,
- covariateName,
- mean
- ) %>%
- dplyr::rename(sumValue = mean)
-
-
- table <- data %>%
- prepareTable1(
- prettyTable1Specifications = prettyTable1Specifications,
- cohort = cohortTable
- )
- if (!hasData(table)) {
- return(NULL)
- }
- keyColumnFields <- c("characteristic")
- dataColumnFields <- intersect(
- x = colnames(table),
- y = cohortTable$shortName
- )
-
- countLocation <- 1
- countsForHeader <-
- getDisplayTableHeaderCount(
- dataSource = dataSource,
- databaseIds = data$databaseId %>% unique(),
- cohortIds = data$cohortId %>% unique(),
- source = "cohort",
- fields = "Persons"
- )
- maxCountValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(
- data = table,
- string = dataColumnFields
- )
- displayTable <- getDisplayTableGroupedByDatabaseId(
- data = table,
- cohort = cohortTable,
- databaseTable = databaseTable,
- headerCount = countsForHeader,
- keyColumns = keyColumnFields,
- countLocation = countLocation,
- dataColumns = dataColumnFields,
- maxCount = maxCountValue,
- showDataAsPercent = TRUE,
- sort = FALSE,
- pageSize = 100
- )
- return(displayTable)
- })
-
- ## Output: characterizationTable ----
- output$characterizationTable <- reactable::renderReactable(expr = {
- data <- cohortCharacterizationPrettyTable()
- validate(need(hasData(data), "No data for selected combination"))
- return(data)
- })
-
-
- ## cohortCharacterizationDataFiltered ----
- cohortCharacterizationDataFiltered <- shiny::eventReactive(input$generateRaw, {
- cohortConcepSets <- getCohortConceptSets()
- cohortConcepSetOptions <- c("", cohortConcepSets$id)
- names(cohortConcepSetOptions) <- c("None selected", cohortConcepSets$name)
- shinyWidgets::updatePickerInput(session,
- inputId = "selectedConceptSet",
- selected = NULL,
- choices = cohortConcepSetOptions)
-
- data <- characterizationOutput()
- if (!hasData(data)) {
- return(NULL)
- }
-
- data <- data$covariateValue
- if (!hasData(data)) {
- return(NULL)
- }
-
- data <- data %>%
- dplyr::filter(timeId %in% selectedTimeIds()) %>%
- dplyr::filter(analysisName %in% input$characterizationAnalysisNameFilter) %>%
- dplyr::filter(domainId %in% input$characterizationDomainIdFilter)
-
- if (!hasData(data)) {
- return(NULL)
- }
- return(data)
- })
-
- rawTableReactable <- shiny::reactive({
- data <- cohortCharacterizationDataFiltered()
- if (is.null(data)) {
- return(NULL)
- }
-
- progress <- shiny::Progress$new()
- on.exit(progress$close())
- progress$set(
- message = "Post processing: Rendering table",
- value = 0
- )
-
- keyColumnFields <-
- c("covariateName", "analysisName", "temporalChoices", "conceptId")
-
- if (input$characterizationColumnFilters == "Mean and Standard Deviation") {
- dataColumnFields <- c("mean", "sd")
- } else {
- dataColumnFields <- c("mean")
- }
- countLocation <- 1
-
-
- if (!hasData(data)) {
- return(NULL)
- }
-
- countsForHeader <-
- getDisplayTableHeaderCount(
- dataSource = dataSource,
- databaseIds = data$databaseId %>% unique(),
- cohortIds = data$cohortId %>% unique(),
- source = "cohort",
- fields = "Persons"
- )
-
- maxCountValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(
- data = data,
- string = dataColumnFields
- )
-
- data <- data %>%
- dplyr::select(
- covariateName,
- analysisName,
- startDay,
- endDay,
- conceptId,
- isBinary,
- mean,
- sd,
- cohortId,
- databaseId,
- temporalChoices
- )
- showAsPercentage <- any(input$proportionOrContinuous == "Proportion", all(data$isBinary == "Y"))
- if (input$proportionOrContinuous == "Proportion") {
- data <- data %>%
- dplyr::filter(isBinary == "Y") %>%
- dplyr::select(-isBinary)
- } else if (input$proportionOrContinuous == "Continuous") {
- data <- data %>%
- dplyr::filter(isBinary == "N") %>%
- dplyr::select(-isBinary)
- }
-
- if (hasData(selectedConceptSets())) {
- if (hasData(conceptSetIds())) {
- data <- data %>%
- dplyr::filter(conceptId %in% getFilteredConceptIds())
- }
- }
- validate(need(hasData(data), "No data for selected combination"))
-
- getDisplayTableGroupedByDatabaseId(
- data = data,
- cohort = cohortTable,
- databaseTable = databaseTable,
- headerCount = countsForHeader,
- keyColumns = keyColumnFields,
- countLocation = countLocation,
- dataColumns = dataColumnFields,
- maxCount = maxCountValue,
- showDataAsPercent = showAsPercentage,
- sort = TRUE,
- pageSize = 100
- )
- })
-
- output$characterizationTableRaw <- reactable::renderReactable(expr = {
- data <- rawTableReactable()
- validate(need(hasData(data), "No data for selected combination"))
- return(data)
- })
-
-
- rawTableTimeIdReactable <- shiny::reactive({
- data <- cohortCharacterizationDataFiltered()
- if (is.null(data)) {
- return(NULL)
- }
-
- progress <- shiny::Progress$new()
- on.exit(progress$close())
- progress$set(
- message = "Post processing: Rendering table",
- value = 0
- )
-
- showAsPercentage <- any(input$proportionOrContinuous == "Proportion", all(data$isBinary == "Y"))
- if (input$proportionOrContinuous == "Proportion") {
- data <- data %>%
- dplyr::filter(isBinary == "Y") %>%
- dplyr::select(-isBinary)
- } else if (input$proportionOrContinuous == "Continuous") {
- data <- data %>%
- dplyr::filter(isBinary == "N") %>%
- dplyr::select(-isBinary)
- }
-
- temporalChoicesVar <- data$temporalChoices %>% unique()
-
- data <-
- data %>% dplyr::inner_join(databaseTable %>%
- dplyr::select(databaseId, databaseName),
- by = "databaseId")
-
- if (hasData(selectedConceptSets())) {
- if (hasData(conceptSetIds())) {
- data <- data %>%
- dplyr::filter(conceptId %in% getFilteredConceptIds())
- }
- }
-
- keyColumns <- c("covariateName", "analysisName", "conceptId", "databaseName")
- data <- data %>%
- dplyr::select(
- covariateName,
- analysisName,
- databaseName,
- temporalChoices,
- conceptId,
- mean,
- sd
- ) %>%
- tidyr::pivot_wider(
- id_cols = dplyr::all_of(keyColumns),
- names_from = "temporalChoices",
- values_from = "mean",
- names_sep = "_"
- ) %>%
- dplyr::relocate(dplyr::all_of(c(keyColumns, temporalChoicesVar))) %>%
- dplyr::arrange(dplyr::desc(dplyr::across(dplyr::starts_with("T ("))))
-
- if (any(stringr::str_detect(
- string = colnames(data),
- pattern = stringr::fixed("T (0")
- ))) {
- data <- data %>%
- dplyr::arrange(dplyr::desc(dplyr::across(dplyr::starts_with("T (0"))))
- }
- dataColumns <- temporalChoicesVar
- progress$set(
- message = "Rendering table",
- value = 80
- )
-
- getDisplayTableSimple(
- data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns,
- showDataAsPercent = showAsPercentage,
- pageSize = 100
- )
- })
-
- output$characterizationTableRawGroupedByTime <- reactable::renderReactable(expr = {
- data <- rawTableTimeIdReactable()
- validate(need(hasData(data), "No data for selected combination"))
- return(data)
- })
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/CohortCountsModule.R b/inst/shiny/DiagnosticsExplorer/R/CohortCountsModule.R
deleted file mode 100644
index 1ae6e7180..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/CohortCountsModule.R
+++ /dev/null
@@ -1,349 +0,0 @@
-#' getColumnMax
-#'
-#' @description
-#' Get Max Value For String Matched Columns
-#'
-getColumnMax <- function(data, string) {
- if (!hasData(data)) {
- return(0)
- }
- string <- intersect(
- string,
- colnames(data)
- )
- data <- data %>%
- dplyr::select(dplyr::all_of(string)) %>%
- tidyr::pivot_longer(values_to = "value", cols = dplyr::everything()) %>%
- dplyr::filter(!is.na(value)) %>%
- dplyr::pull(value)
-
- if (!hasData(data)) {
- return(0)
- } else {
- return(max(data, na.rm = TRUE))
- }
-}
-
-
-#' Cohort Counts View
-#' @description
-#' Shiny view for cohort counts module
-#' @inputId cohortCountsTableColumnFilter Column filters
-#' @outputId cohortCountsTable Reactable output of cohort counts for specified databases
-#' @outputId inclusionRuleStats Reactable output of inclusion rules
-cohortCountsView <- function(id) {
- ns <- shiny::NS(id)
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Cohort Counts",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "cohortCounts.html"))
- ),
- shinydashboard::box(
- status = "warning",
- width = "100%",
- shiny::tags$div(
- style = "max-height: 100px; overflow-y: auto",
- shiny::uiOutput(outputId = ns("selectedCohorts"))
- )
- ),
- shinydashboard::box(
- width = "100%",
- shiny::tagList(
- tags$table(
- tags$tr(
- tags$td(
- shiny::radioButtons(
- inputId = ns("cohortCountsTableColumnFilter"),
- label = "Display",
- choices = c("Both", "Persons", "Records"),
- selected = "Both",
- inline = TRUE
- )
- )
- )
- ),
- shinycssloaders::withSpinner(
- reactable::reactableOutput(outputId = ns("cohortCountsTable")
- )
- ),
- csvDownloadButton(ns, "cohortCountsTable"),
- shiny::conditionalPanel(
- condition = "output.cohortCountRowIsSelected == true",
- ns = ns,
- tags$h4("Inclusion Rule Statistics"),
-
- shiny::fluidRow(
- shiny::column(
- width = 4,
- shiny::radioButtons(
- inputId = ns("cohortCountInclusionRuleTableFilters"),
- label = "Inclusion Rule Events",
- choices = c("All", "Meet", "Gain", "Remain"),
- selected = "All",
- inline = TRUE
- )
- ),
- shiny::column(
- width = 4,
- shiny::radioButtons(
- inputId = ns("showPersonOrEvents"),
- label = "Report",
- choices = c("Persons", "Events"),
- selected = "Persons",
- inline = TRUE
- )
- ),
- shiny::column(
- width = 4,
- shiny::checkboxInput(
- inputId = ns("showAsPercent"),
- label = "Show as percent",
- value = TRUE
- )
- )
- ),
- shinycssloaders::withSpinner(
- reactable::reactableOutput(ns("inclusionRuleStats"))
- ),
- csvDownloadButton(ns, "inclusionRuleStats")
- )
- )
- )
- )
-}
-
-#' Shiny module for cohort counts
-#' @description
-#' Shiny module for cohort counts. Displays reactable table of cohort counts
-#'
-#' @requiredPackage reactable
-#' @requiredPacakge shiny
-#' @requiredPacakge shinycssloaders
-#' @requiredPacakge shinydashboard
-#' @requiredPacakge dplyr
-#'
-#' @param dataSource Backend Data source (DatabaseConnection)
-#' @param cohortTable data.frame of all cohorts
-#' @param databaseTable data.frame of all databases
-#' @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
-cohortCountsModule <- function(id,
- dataSource,
- cohortTable,
- databaseTable,
- selectedCohorts,
- selectedDatabaseIds,
- cohortIds) {
- ns <- shiny::NS(id)
-
- serverFunction <- function(input, output, session) {
- output$selectedCohorts <- shiny::renderUI(selectedCohorts())
-
-
- # Cohort Counts ----------------------
- getResults <- shiny::reactive(x = {
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- validate(need(length(cohortIds()) > 0, "No cohorts chosen"))
- data <- getResultsCohortCounts(
- dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortIds = cohortIds()
- )
- if (!hasData(data)) {
- return(NULL)
- }
-
- data <- data %>%
- dplyr::inner_join(cohortTable %>% dplyr::select(cohortName, cohortId), by = "cohortId") %>%
- dplyr::arrange(cohortId, databaseId)
-
- return(data)
- })
-
- output$cohortCountsTable <- reactable::renderReactable(expr = {
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- validate(need(length(cohortIds()) > 0, "No cohorts chosen"))
-
- data <- getResults()
- validate(need(hasData(data), "There is no data on any cohort"))
-
- data <- getResults() %>%
- dplyr::rename(
- persons = cohortSubjects,
- records = cohortEntries
- )
-
- dataColumnFields <- c("persons", "records")
-
- if (input$cohortCountsTableColumnFilter == "Persons") {
- dataColumnFields <- "persons"
- } else if (input$cohortCountsTableColumnFilter == "Records") {
- dataColumnFields <- "records"
- }
-
- keyColumnFields <- c("cohortId", "cohortName")
-
- countsForHeader <- NULL
-
- maxCountValue <-
- getColumnMax(
- data = data,
- string = dataColumnFields
- )
-
- displayTable <- getDisplayTableGroupedByDatabaseId(
- data = data,
- cohort = cohortTable,
- databaseTable = databaseTable,
- headerCount = countsForHeader,
- keyColumns = keyColumnFields,
- countLocation = 1,
- dataColumns = dataColumnFields,
- maxCount = maxCountValue,
- sort = FALSE,
- selection = "single"
- )
- return(displayTable)
- })
-
- getCohortIdOnCohortCountRowSelect <- shiny::reactive({
- idx <- reactable::getReactableState(outputId = "cohortCountsTable", "selected")
-
- if (!hasData(idx)) {
- return(NULL)
- } else {
- if (hasData(getResults())) {
- subset <- getResults() %>%
- dplyr::select(
- cohortId
- ) %>%
- dplyr::distinct()
- subset <- subset[idx,]
- return(subset)
- } else {
- return(NULL)
- }
- }
- })
-
- output$cohortCountRowIsSelected <- reactive({
- return(!is.null(getCohortIdOnCohortCountRowSelect()))
- })
-
- outputOptions(output,
- "cohortCountRowIsSelected",
- suspendWhenHidden = FALSE)
-
- output$inclusionRuleStats <- reactable::renderReactable(expr = {
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- validate(need(
- nrow(getCohortIdOnCohortCountRowSelect()) > 0,
- "No cohorts chosen"
- ))
-
- if (!hasData(getCohortIdOnCohortCountRowSelect())) {
- return(NULL)
- }
- if (any(
- !hasData(input$showPersonOrEvents),
- input$showPersonOrEvents == "Persons"
- )) {
- mode <- 1
- } else {
- mode <- 0
- }
-
- data <- getInclusionRuleStats(
- dataSource = dataSource,
- cohortIds = getCohortIdOnCohortCountRowSelect()$cohortId,
- databaseIds = selectedDatabaseIds(),
- mode = mode # modeId = 1 - best event, i.e. person
- )
-
- showDataAsPercent <- input$showAsPercent
-
- validate(need(
- (nrow(data) > 0),
- "There is no data for the selected combination."
- ))
-
- if (all(hasData(showDataAsPercent), showDataAsPercent)) {
- data <- data %>%
- dplyr::mutate(
- Meet = meetSubjects / totalSubjects,
- Gain = gainSubjects / totalSubjects,
- Remain = remainSubjects / totalSubjects,
- id = ruleSequenceId
- )
- } else {
- data <- data %>%
- dplyr::mutate(
- Meet = meetSubjects,
- Gain = gainSubjects,
- Remain = remainSubjects,
- Total = totalSubjects,
- id = ruleSequenceId
- )
- }
-
- data <- data %>%
- dplyr::arrange(cohortId,
- databaseId,
- id)
-
- validate(need(
- (nrow(data) > 0),
- "There is no data for the selected combination."
- ))
-
- keyColumnFields <-
- c("id", "ruleName")
- countLocation <- 1
-
- if (any(!hasData(input$cohortCountInclusionRuleTableFilters),
- input$cohortCountInclusionRuleTableFilters == "All")) {
- dataColumnFields <- c("Meet", "Gain", "Remain")
- } else {
- dataColumnFields <- c(input$cohortCountInclusionRuleTableFilters)
- }
-
- if (all(hasData(showDataAsPercent), !showDataAsPercent)) {
- dataColumnFields <- c(dataColumnFields, "Total")
- }
-
- countsForHeader <-
- getDisplayTableHeaderCount(
- dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortIds = getCohortIdOnCohortCountRowSelect()$cohortId,
- source = "cohort",
- fields = "Persons"
- )
-
- maxCountValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(
- data = data,
- string = dataColumnFields
- )
-
- getDisplayTableGroupedByDatabaseId(
- data = data,
- cohort = cohortTable,
- databaseTable = databaseTable,
- headerCount = countsForHeader,
- keyColumns = keyColumnFields,
- countLocation = countLocation,
- dataColumns = dataColumnFields,
- maxCount = maxCountValue,
- showDataAsPercent = showDataAsPercent,
- sort = TRUE
- )
- })
- }
-
- return(shiny::moduleServer(id, serverFunction))
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/CohortDefinitionModule.R b/inst/shiny/DiagnosticsExplorer/R/CohortDefinitionModule.R
deleted file mode 100644
index b3abf4497..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/CohortDefinitionModule.R
+++ /dev/null
@@ -1,967 +0,0 @@
-#' Returns list with circe generated documentation
-#'
-#' @description
-#' Returns list with circe generated documentation
-#'
-#' @param cohortDefinition An R object (list) with a list representation of the cohort definition expression,
-#' that may be converted to a cohort expression JSON using
-#' RJSONIO::toJSON(x = cohortDefinition, digits = 23, pretty = TRUE)
-#'
-#' @param cohortName Name for the cohort definition
-#'
-#' @param includeConceptSets Do you want to inclued concept set in the documentation
-#'
-#' @return list object
-#'
-#' @export
-getCirceRenderedExpression <- function(cohortDefinition,
- cohortName = "Cohort Definition",
- includeConceptSets = FALSE) {
- cohortJson <-
- RJSONIO::toJSON(
- x = cohortDefinition,
- digits = 23,
- pretty = TRUE
- )
- circeExpression <-
- CirceR::cohortExpressionFromJson(expressionJson = cohortJson)
- circeExpressionMarkdown <-
- CirceR::cohortPrintFriendly(circeExpression)
- circeConceptSetListmarkdown <-
- CirceR::conceptSetListPrintFriendly(circeExpression$conceptSets)
-
- circeExpressionMarkdown <-
- paste0(
- "## Human Readable Cohort Definition",
- "\r\n\r\n",
- circeExpressionMarkdown
- )
-
- circeExpressionMarkdown <-
- paste0(
- "# ",
- cohortName,
- "\r\n\r\n",
- circeExpressionMarkdown
- )
-
- if (includeConceptSets) {
- circeExpressionMarkdown <-
- paste0(
- circeExpressionMarkdown,
- "\r\n\r\n",
- "\r\n\r\n",
- "## Concept Sets:",
- "\r\n\r\n",
- circeConceptSetListmarkdown
- )
- }
-
- htmlExpressionCohort <-
- markdown::renderMarkdown(text = circeExpressionMarkdown)
- htmlExpressionConceptSetExpression <-
- markdown::renderMarkdown(text = circeConceptSetListmarkdown)
- return(
- list(
- cohortJson = cohortJson,
- cohortMarkdown = circeExpressionMarkdown,
- conceptSetMarkdown = circeConceptSetListmarkdown,
- cohortHtmlExpression = htmlExpressionCohort,
- conceptSetHtmlExpression = htmlExpressionConceptSetExpression
- )
- )
-}
-
-
-getConceptSetDataFrameFromConceptSetExpression <-
- function(conceptSetExpression) {
- if ("items" %in% names(conceptSetExpression)) {
- items <- conceptSetExpression$items
- } else {
- items <- conceptSetExpression
- }
- conceptSetExpressionDetails <- items %>%
- purrr::map_df(.f = purrr::flatten)
- if ("CONCEPT_ID" %in% colnames(conceptSetExpressionDetails)) {
- if ("isExcluded" %in% colnames(conceptSetExpressionDetails)) {
- conceptSetExpressionDetails <- conceptSetExpressionDetails %>%
- dplyr::rename(IS_EXCLUDED = isExcluded)
- } else {
- conceptSetExpressionDetails <- conceptSetExpressionDetails %>%
- dplyr::mutate(IS_EXCLUDED = FALSE)
- }
- if ("includeDescendants" %in% colnames(conceptSetExpressionDetails)) {
- conceptSetExpressionDetails <- conceptSetExpressionDetails %>%
- dplyr::rename(INCLUDE_DESCENDANTS = includeDescendants)
- } else {
- conceptSetExpressionDetails <- conceptSetExpressionDetails %>%
- dplyr::mutate(INCLUDE_DESCENDANTS = FALSE)
- }
- if ("includeMapped" %in% colnames(conceptSetExpressionDetails)) {
- conceptSetExpressionDetails <- conceptSetExpressionDetails %>%
- dplyr::rename(INCLUDE_MAPPED = includeMapped)
- } else {
- conceptSetExpressionDetails <- conceptSetExpressionDetails %>%
- dplyr::mutate(INCLUDE_MAPPED = FALSE)
- }
- conceptSetExpressionDetails <-
- conceptSetExpressionDetails %>%
- tidyr::replace_na(list(
- IS_EXCLUDED = FALSE,
- INCLUDE_DESCENDANTS = FALSE,
- INCLUDE_MAPPED = FALSE
- ))
- colnames(conceptSetExpressionDetails) <-
- SqlRender::snakeCaseToCamelCase(colnames(conceptSetExpressionDetails))
- }
- return(conceptSetExpressionDetails)
- }
-
-
-getConceptSetDetailsFromCohortDefinition <-
- function(cohortDefinitionExpression) {
- if ("expression" %in% names(cohortDefinitionExpression)) {
- expression <- cohortDefinitionExpression$expression
- } else {
- expression <- cohortDefinitionExpression
- }
-
- if (is.null(expression$ConceptSets)) {
- return(NULL)
- }
-
- conceptSetExpression <- expression$ConceptSets %>%
- dplyr::bind_rows() %>%
- dplyr::mutate(json = RJSONIO::toJSON(
- x = expression,
- pretty = TRUE
- ))
-
- conceptSetExpressionDetails <- list()
- i <- 0
- for (id in conceptSetExpression$id) {
- i <- i + 1
- conceptSetExpressionDetails[[i]] <-
- getConceptSetDataFrameFromConceptSetExpression(
- conceptSetExpression =
- conceptSetExpression[i,]$expression$items
- ) %>%
- dplyr::mutate(id = conceptSetExpression[i,]$id) %>%
- dplyr::relocate(id) %>%
- dplyr::arrange(id)
- }
- conceptSetExpressionDetails <-
- dplyr::bind_rows(conceptSetExpressionDetails)
- output <- list(
- conceptSetExpression = conceptSetExpression,
- conceptSetExpressionDetails = conceptSetExpressionDetails
- )
- return(output)
- }
-
-
-exportCohortDefinitionsZip <- function(cohortDefinitions,
- zipFile = NULL) {
- rootFolder <-
- stringr::str_replace_all(
- string = Sys.time(),
- pattern = "-",
- replacement = ""
- )
- rootFolder <-
- stringr::str_replace_all(
- string = rootFolder,
- pattern = ":",
- replacement = ""
- )
- tempdir <- file.path(tempdir(), rootFolder)
-
- for (i in (1:nrow(cohortDefinitions))) {
- cohortId <- cohort[i,]$cohortId
- dir.create(
- path = file.path(tempdir, cohortId),
- recursive = TRUE,
- showWarnings = FALSE
- )
- cohortExpression <- cohortDefinitions[i,]$json %>%
- RJSONIO::fromJSON(digits = 23)
-
- details <-
- getCirceRenderedExpression(cohortDefinition = cohortExpression)
-
- SqlRender::writeSql(
- sql = details$cohortJson,
- targetFile = file.path(
- tempdir,
- cohortId,
- paste0("cohortDefinitionJson_", cohortId, ".json")
- )
- )
- SqlRender::writeSql(
- sql = details$cohortMarkdown,
- targetFile = file.path(
- tempdir,
- cohortId,
- paste0("cohortDefinitionMarkdown_", cohortId, ".md")
- )
- )
-
- SqlRender::writeSql(
- sql = details$conceptSetMarkdown,
- targetFile = file.path(
- tempdir,
- cohortId,
- paste0("conceptSetMarkdown_", cohortId, ".md")
- )
- )
-
- SqlRender::writeSql(
- sql = details$cohortHtmlExpression,
- targetFile = file.path(
- tempdir,
- cohortId,
- paste0("cohortDefinitionHtml_", cohortId, ".html")
- )
- )
-
- SqlRender::writeSql(
- sql = details$conceptSetHtmlExpression,
- targetFile = file.path(
- tempdir,
- cohortId,
- paste0("conceptSetsHtml_", cohortId, ".html")
- )
- )
- }
-
- return(DatabaseConnector::createZipFile(zipFile = zipFile,
- files = tempdir,
- rootFolder = tempdir))
-}
-
-#' Cohort Definitions View
-#' @description
-#' Outputs cohort definitions
-#'
-#'
-cohortDefinitionsView <- function(id) {
- ns <- shiny::NS(id)
- ui <- shiny::tagList(
- shinydashboard::box(
- width = NULL,
- status = "primary",
- htmltools::withTags(
- table(width = "100%",
- tr(
- td(align = "left",
- h4("Cohort Definition")
- ),
- td(
- align = "right",
- shiny::downloadButton(
- outputId = ns("exportAllCohortDetails"),
- label = "Export Cohorts Zip",
- icon = shiny::icon("file-export"),
- style = "margin-top: 5px; margin-bottom: 5px;"
- )
- )
- )
- )
- ),
- shiny::column(12,
- reactable::reactableOutput(outputId = ns("cohortDefinitionTable"))),
- shiny::column(
- 12,
- shiny::conditionalPanel(
- "output.cohortDefinitionRowIsSelected == true",
- ns = ns,
- shiny::tabsetPanel(
- type = "tab",
- shiny::tabPanel(title = "Details",
- shiny::htmlOutput(ns("cohortDetailsText"))),
- shiny::tabPanel(title = "Cohort Count",
- tags$br(),
- reactable::reactableOutput(outputId = ns("cohortCountsTableInCohortDefinition"))),
- shiny::tabPanel(title = "Cohort definition",
- copyToClipboardButton(toCopyId = ns("cohortDefinitionText"),
- style = "margin-top: 5px; margin-bottom: 5px;"),
- shiny::htmlOutput(ns("cohortDefinitionText"))),
- shiny::tabPanel(
- title = "Concept Sets",
- reactable::reactableOutput(outputId = ns("conceptsetExpressionsInCohort")),
- shiny::conditionalPanel(
- condition = "output.cohortDefinitionConceptSetExpressionRowIsSelected == true",
- ns = ns,
- tags$table(
- tags$tr(
- tags$td(
- shiny::radioButtons(
- inputId = ns("conceptSetsType"),
- label = "",
- choices = c("Concept Set Expression",
- "Resolved",
- "Mapped",
- "Json"),
- selected = "Concept Set Expression",
- inline = TRUE
- )
- ),
- tags$td(
- shiny::conditionalPanel(
- condition = "input.conceptSetsType == 'Resolved' | input.conceptSetsType == 'Mapped'",
- ns = ns,
- shiny::selectInput(ns("vocabularySelection"),
- label = "Database:",
- width = 400,
- choices = c())
- )
- ),
- tags$td(
- shiny::htmlOutput(ns("subjectCountInCohortConceptSet"))
- ),
- tags$td(
- shiny::htmlOutput(ns("recordCountInCohortConceptSet"))
- )
- )
- )
- ),
- shiny::conditionalPanel(
- ns = ns,
- condition = "output.cohortDefinitionConceptSetExpressionRowIsSelected == true &
- input.conceptSetsType != 'Resolved' &
- input.conceptSetsType != 'Mapped' &
- input.conceptSetsType != 'Json'",
- tags$p("Filter logical values with \"T\" and \"F\""),
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("cohortDefinitionConceptSetDetailsTable")))
- ),
- shiny::conditionalPanel(
- ns = ns,
- condition = "input.conceptSetsType == 'Resolved'",
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("cohortDefinitionResolvedConceptsTable")))
- ),
- shiny::conditionalPanel(
- ns = ns,
- condition = "input.conceptSetsType == 'Mapped'",
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("cohortDefinitionMappedConceptsTable")))
- ),
- shiny::conditionalPanel(
- condition = "input.conceptSetsType == 'Json'",
- copyToClipboardButton(toCopyId = ns("cohortConceptsetExpressionJson"),
- style = "margin-top: 5px; margin-bottom: 5px;"),
- shiny::verbatimTextOutput(outputId = ns("cohortConceptsetExpressionJson")),
- tags$head(
- tags$style("#cohortConceptsetExpressionJson { max-height:400px};")
- ),
- ns = ns
- )
- ),
- shiny::tabPanel(
- title = "JSON",
- copyToClipboardButton(ns("cohortDefinitionJson"), style = "margin-top: 5px; margin-bottom: 5px;"),
- shiny::verbatimTextOutput(ns("cohortDefinitionJson")),
- tags$head(
- tags$style("#cohortDefinitionJson { max-height:400px};")
- )
- ),
- shiny::tabPanel(
- title = "SQL",
- copyToClipboardButton(ns("cohortDefinitionSql"), style = "margin-top: 5px; margin-bottom: 5px;"),
- shiny::verbatimTextOutput(ns("cohortDefinitionSql")),
- tags$head(
- tags$style("#cohortDefinitionSql { max-height:400px};")
- )
- )
- )
- )
- )
- )
- )
- ui
-}
-
-#' Cohort Definition module
-#' @description
-#'
-#'
-#' @param id Namespace id
-#' @param dataSource DatabaseConnection
-#' @param cohortDefinitions reactive of cohort definitions to display
-#' @param databaseTable data.frame of databasese
-cohortDefinitionsModule <- function(id,
- dataSource,
- cohortDefinitions,
- cohortTable,
- cohortCount,
- databaseTable) {
- ns <- shiny::NS(id)
-
- cohortDefinitionServer <- function(input, output, session) {
-
- cohortDefinitionTableData <- shiny::reactive(x = {
- data <- cohortDefinitions() %>%
- dplyr::select(cohortId, cohortName)
- return(data)
- })
-
- # Cohort Definition ---------------------------------------------------------
- output$cohortDefinitionTable <-
- reactable::renderReactable(expr = {
- data <- cohortDefinitionTableData() %>%
- dplyr::mutate(cohortId = as.character(cohortId))
-
- validate(need(hasData(data), "There is no data for this cohort."))
- keyColumns <- c("cohortId", "cohortName")
- dataColumns <- c()
-
- displayTable <- getDisplayTableSimple(
- data = data,
- databaseTable = databaseTable,
- keyColumns = keyColumns,
- dataColumns = dataColumns,
- selection = "single"
- )
- return(displayTable)
- })
-
- selectedCohortDefinitionRow <- reactive({
- idx <- reactable::getReactableState("cohortDefinitionTable", "selected")
- if (is.null(idx)) {
- return(NULL)
- } else {
- subset <- cohortDefinitions()
- if (nrow(subset) == 0) {
- return(NULL)
- }
- row <- subset[idx[1],]
- return(row)
- }
- })
-
- output$cohortDefinitionRowIsSelected <- reactive({
- return(!is.null(selectedCohortDefinitionRow()))
- })
-
- outputOptions(output,
- "cohortDefinitionRowIsSelected",
- suspendWhenHidden = FALSE)
-
- ## cohortDetailsText ---------------------------------------------------------
- output$cohortDetailsText <- shiny::renderUI({
- row <- selectedCohortDefinitionRow()
- if (is.null(row)) {
- return(NULL)
- } else {
- tags$table(
- style = "margin-top: 5px;",
- tags$tr(
- tags$td(tags$strong("Cohort ID: ")),
- tags$td(HTML(" ")),
- tags$td(row$cohortId)
- ),
- tags$tr(
- tags$td(tags$strong("Cohort Name: ")),
- tags$td(HTML(" ")),
- tags$td(row$cohortName)
- )
- )
- }
- })
-
-
- ## cohortCountsTableInCohortDefinition ---------------------------------------------------------
- output$cohortCountsTableInCohortDefinition <-
- reactable::renderReactable(expr = {
- if (is.null(selectedCohortDefinitionRow())) {
- return(NULL)
- }
- data <- cohortCount
- if (!hasData(data)) {
- return(NULL)
- }
- data <- data %>%
- dplyr::filter(cohortId == selectedCohortDefinitionRow()$cohortId) %>%
- dplyr::filter(databaseId %in% databaseTable$databaseId) %>%
- dplyr::select(databaseId,
- cohortSubjects,
- cohortEntries) %>%
- dplyr::rename("persons" = cohortSubjects,
- "events" = cohortEntries)
-
- validate(need(hasData(data), "There is no data for this cohort."))
-
- keyColumns <- c("databaseId")
- dataColumns <- c("persons", "events")
-
- displayTable <- getDisplayTableSimple(data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns)
- return(displayTable)
- })
-
- ## cohortDefinitionCirceRDetails ---------------------------------------------------------
- cohortDefinitionCirceRDetails <- shiny::reactive(x = {
- progress <- shiny::Progress$new()
- on.exit(progress$close())
- progress$set(message = "Rendering human readable cohort description using CirceR (may take time)", value = 0)
- data <- selectedCohortDefinitionRow()
- if (!hasData(data)) {
- return(NULL)
- }
- details <-
- getCirceRenderedExpression(
- cohortDefinition = data$json[1] %>% RJSONIO::fromJSON(digits = 23),
- cohortName = data$cohortName[1],
- includeConceptSets = TRUE
- )
- return(details)
- })
-
- output$cohortDefinitionText <- shiny::renderUI(expr = {
- cohortDefinitionCirceRDetails()$cohortHtmlExpression %>%
- shiny::HTML()
- })
- ## cohortDefinitionJson ---------------------------------------------------------
- output$cohortDefinitionJson <- shiny::renderText({
- row <- selectedCohortDefinitionRow()
- if (is.null(row)) {
- return(NULL)
- } else {
- row$json
- }
- })
-
- ## cohortDefinitionSql ---------------------------------------------------------
- output$cohortDefinitionSql <- shiny::renderText({
- row <- selectedCohortDefinitionRow()
- if (is.null(row)) {
- return(NULL)
- } else {
- row$sql
- }
- })
-
- ## cohortDefinitionConceptSetExpression ---------------------------------------------------------
- cohortDefinitionConceptSetExpression <- shiny::reactive({
- row <- selectedCohortDefinitionRow()
- if (is.null(row)) {
- return(NULL)
- }
-
- expression <- RJSONIO::fromJSON(row$json, digits = 23)
- if (is.null(expression)) {
- return(NULL)
- }
- expression <-
- getConceptSetDetailsFromCohortDefinition(cohortDefinitionExpression = expression)
-
- return(expression)
- })
-
- output$conceptsetExpressionsInCohort <- reactable::renderReactable(expr = {
- data <- cohortDefinitionConceptSetExpression()
- if (is.null(data)) {
- return(NULL)
- }
- if (!is.null(data$conceptSetExpression) &&
- nrow(data$conceptSetExpression) > 0) {
- data <- data$conceptSetExpression %>%
- dplyr::select(id, name)
- } else {
- return(NULL)
- }
-
- validate(need(
- all(!is.null(data),
- nrow(data) > 0),
- "There is no data for this cohort."
- ))
-
- data <- data %>% dplyr::mutate()
-
- keyColumns <- c("id", "name")
- dataColumns <- c()
- getDisplayTableSimple(
- data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns,
- selection = "single"
- )
- })
-
- ### cohortDefinitionConceptSetExpressionSelected ---------------------------------------------------------
- cohortDefinitionConceptSetExpressionSelected <- shiny::reactive(x = {
- idx <- reactable::getReactableState("conceptsetExpressionsInCohort", "selected")
- if (length(idx) == 0 || is.null(idx)) {
- return(NULL)
- }
- if (hasData(cohortDefinitionConceptSetExpression()$conceptSetExpression)) {
- data <-
- cohortDefinitionConceptSetExpression()$conceptSetExpression[idx,]
- if (!is.null(data)) {
- return(data)
- } else {
- return(NULL)
- }
- }
- })
-
- output$cohortDefinitionConceptSetExpressionRowIsSelected <- shiny::reactive(x = {
- return(!is.null(cohortDefinitionConceptSetExpressionSelected()))
- })
-
- shiny::outputOptions(x = output,
- name = "cohortDefinitionConceptSetExpressionRowIsSelected",
- suspendWhenHidden = FALSE)
-
- output$isDataSourceEnvironment <- shiny::reactive(x = {
- return(is(dataSource, "environment"))
- })
- shiny::outputOptions(x = output,
- name = "isDataSourceEnvironment",
- suspendWhenHidden = FALSE)
-
- ### cohortDefinitionConceptSetDetails ---------------------------------------------------------
- cohortDefinitionConceptSetDetails <- shiny::reactive(x = {
- if (is.null(cohortDefinitionConceptSetExpressionSelected())) {
- return(NULL)
- }
- data <-
- cohortDefinitionConceptSetExpression()$conceptSetExpressionDetails
- if (!hasData(data)) {
- return(NULL)
- }
- data <- data %>%
- dplyr::filter(id == cohortDefinitionConceptSetExpressionSelected()$id)
- if (!hasData(data)) {
- return(NULL)
- }
- data <- data %>%
- dplyr::select(
- conceptId,
- conceptName,
- isExcluded,
- includeDescendants,
- includeMapped,
- standardConcept,
- invalidReason,
- conceptCode,
- domainId,
- vocabularyId,
- conceptClassId
- )
- return(data)
- })
-
- output$cohortDefinitionConceptSetDetailsTable <-
- reactable::renderReactable(expr = {
- data <- cohortDefinitionConceptSetDetails()
- validate(need(
- all(!is.null(data),
- nrow(data) > 0),
- "There is no data for this cohort."
- ))
- if (is.null(cohortDefinitionConceptSetDetails())) {
- return(NULL)
- }
-
- data <- data %>%
- dplyr::rename(exclude = isExcluded,
- descendants = includeDescendants,
- mapped = includeMapped,
- invalid = invalidReason)
- validate(need(
- all(!is.null(data),
- nrow(data) > 0),
- "There is no data for this cohort."
- ))
-
- keyColumns <- c(
- "conceptId",
- "conceptName",
- "exclude",
- "descendants",
- "mapped",
- "standardConcept",
- "invalid",
- "conceptCode",
- "domainId",
- "vocabularyId",
- "conceptClassId"
- )
-
- dataColumns <- c()
- getDisplayTableSimple(data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns)
-
- })
-
- getDatabaseIdInCohortConceptSet <- shiny::reactive({
- return(databaseTable$databaseId[databaseTable$databaseIdWithVocabularyVersion == input$vocabularySchema])
- })
-
- ## Cohort Concept Set
- ### getSubjectAndRecordCountForCohortConceptSet ---------------------------------------------------------
- getSubjectAndRecordCountForCohortConceptSet <- shiny::reactive(x = {
- row <- selectedCohortDefinitionRow()
-
- if (is.null(row) || length(getDatabaseIdInCohortConceptSet()) == 0) {
- return(NULL)
- } else {
- data <- cohortCount %>%
- dplyr::filter(cohortId == row$cohortId) %>%
- dplyr::filter(databaseId == getDatabaseIdInCohortConceptSet()) %>%
- dplyr::select(cohortSubjects, cohortEntries)
-
- if (nrow(data) == 0) {
- return(NULL)
- } else {
- return(data)
- }
- }
- })
-
- ### subjectCountInCohortConceptSet ---------------------------------------------------------
- output$subjectCountInCohortConceptSet <- shiny::renderUI({
- row <- getSubjectAndRecordCountForCohortConceptSet()
- if (is.null(row)) {
- return(NULL)
- } else {
- tags$table(
- tags$tr(
- tags$td("Persons: "),
- tags$td(scales::comma(row$cohortSubjects, accuracy = 1))
- )
- )
- }
- })
-
- ### recordCountInCohortConceptSet ---------------------------------------------------------
- output$recordCountInCohortConceptSet <- shiny::renderUI({
- row <- getSubjectAndRecordCountForCohortConceptSet()
- if (is.null(row)) {
- return(NULL)
- } else {
- tags$table(
- tags$tr(
- tags$td("Records: "),
- tags$td(scales::comma(row$cohortEntries, accuracy = 1))
- )
- )
- }
- })
-
- ### getCohortDefinitionResolvedConceptsReactive ---------------------------------------------------------
- getCohortDefinitionResolvedConceptsReactive <-
- shiny::reactive(x = {
- row <- selectedCohortDefinitionRow()
- if (is.null(row)) {
- return(NULL)
- }
- output <-
- resolvedConceptSet(
- dataSource = dataSource,
- databaseIds = databaseTable$databaseId,
- cohortId = row$cohortId
- )
- if (!hasData(output)) {
- return(NULL)
- }
- conceptCount <- getCountForConceptIdInCohortReactive()
- output <- output %>%
- dplyr::left_join(conceptCount,
- by = c("databaseId", "conceptId"))
- return(output)
- })
-
- output$cohortDefinitionResolvedConceptsTable <-
- reactable::renderReactable(expr = {
- if (input$conceptSetsType != 'Resolved') {
- return(NULL)
- }
- databaseIdToFilter <- databaseTable %>%
- dplyr::filter(databaseIdWithVocabularyVersion == vocabSchema()) %>%
- dplyr::pull(databaseId)
- if (!hasData(databaseIdToFilter)) {
- return(NULL)
- }
-
- validate(need(
- length(cohortDefinitionConceptSetExpressionSelected()$id) > 0,
- "Please select concept set"
- ))
-
- data <- getCohortDefinitionResolvedConceptsReactive()
- validate(need(
- hasData(data),
- paste0("No data for database id ", input$vocabularySchema)
- ))
- data <- data %>%
- dplyr::filter(conceptSetId == cohortDefinitionConceptSetExpressionSelected()$id) %>%
- dplyr::filter(databaseId == databaseIdToFilter) %>%
- dplyr::rename("persons" = conceptSubjects,
- "records" = conceptCount)
- validate(need(
- hasData(data),
- paste0("No data for database id ", input$vocabularySchema)
- ))
- keyColumns <- c(
- "conceptId",
- "conceptName",
- "domainId",
- "vocabularyId",
- "conceptClassId",
- "standardConcept",
- "conceptCode"
- )
- dataColumns <- c("persons",
- "records")
- displayTable <- getDisplayTableSimple(data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns)
- return(displayTable)
- })
-
-
- ### getCountForConceptIdInCohortReactive ---------------------------------------------------------
- getCountForConceptIdInCohortReactive <-
- shiny::reactive(x = {
- row <- selectedCohortDefinitionRow()
- if (is.null(row)) {
- return(NULL)
- }
- data <- getCountForConceptIdInCohort(
- dataSource = dataSource,
- databaseIds = databaseTable$databaseId,
- cohortId = row$cohortId
- )
- return(data)
- })
-
- ## cohortConceptsetExpressionJson ---------------------------------------------------------
- output$cohortConceptsetExpressionJson <- shiny::renderText({
- if (is.null(cohortDefinitionConceptSetExpressionSelected())) {
- return(NULL)
- }
- json <- cohortDefinitionConceptSetExpressionSelected()$json
- return(json)
- })
-
- vocabSchema <- shiny::reactive({
- if (is.null(input$vocabularySelection)) {
- return("")
- }
- input$vocabularySelection
- })
-
- ### getCohortDefinitionMappedConceptsReactive ---------------------------------------------------------
- getCohortDefinitionMappedConceptsReactive <-
- shiny::reactive(x = {
- row <- selectedCohortDefinitionRow()
- if (is.null(row)) {
- return(NULL)
- }
- progress <- shiny::Progress$new()
- on.exit(progress$close())
- progress$set(message = "Getting concepts mapped to concept ids resolved by concept set expression (may take time)", value = 0)
- output <-
- mappedConceptSet(
- dataSource = dataSource,
- databaseIds = databaseTable$databaseId,
- cohortId = row$cohortId
- )
-
- if (!hasData(output)) {
- return(NULL)
- }
- conceptCount <- getCountForConceptIdInCohortReactive()
- output <- output %>%
- dplyr::left_join(conceptCount,
- by = c("databaseId", "conceptId"))
- return(output)
- })
-
- output$cohortDefinitionMappedConceptsTable <-
- reactable::renderReactable(expr = {
- if (input$conceptSetsType != 'Mapped') {
- return(NULL)
- }
-
- databaseIdToFilter <- databaseTable %>%
- dplyr::filter(databaseIdWithVocabularyVersion == vocabSchema()) %>%
- dplyr::pull(databaseId)
- if (!hasData(databaseIdToFilter)) {
- return(NULL)
- }
-
- validate(need(
- length(cohortDefinitionConceptSetExpressionSelected()$id) > 0,
- "Please select concept set"
- ))
-
- data <- getCohortDefinitionMappedConceptsReactive()
- validate(need(
- hasData(data),
- paste0("No data for database id ", input$vocabularySchema)
- ))
-
- data <- data %>%
- dplyr::filter(conceptSetId == cohortDefinitionConceptSetExpressionSelected()$id) %>%
- dplyr::filter(databaseId == databaseIdToFilter) %>%
- dplyr::rename("persons" = conceptSubjects,
- "records" = conceptCount)
- validate(need(
- hasData(data),
- paste0("No data for database id ", input$vocabularySchema)
- ))
-
- keyColumns <- c(
- "resolvedConceptId",
- "conceptId",
- "conceptName",
- "domainId",
- "vocabularyId",
- "conceptClassId",
- "standardConcept",
- "conceptCode"
- )
- dataColumns <- c("persons",
- "records")
-
- getDisplayTableSimple(data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns)
-
- })
-
- vocabularyChoices <- databaseTable$databaseIdWithVocabularyVersion
- names(vocabularyChoices) <- databaseTable$databaseName
-
- shiny::observe({
- shiny::updateSelectInput(session,
- inputId = "vocabularySelection",
- choices = vocabularyChoices)
- })
-
- ## Export all cohort details ----
- output$exportAllCohortDetails <- shiny::downloadHandler(
- filename = function() {
- paste("ExportDetails", "zip", sep = ".")
- },
- content = function(file) {
- shiny::withProgress(
- message = "Export is in progress",
- {
-
- exportCohortDefinitionsZip(cohortTable, zipFile = file)
- },
- detail = "Please Wait"
- )
- },
- contentType = "application/zip"
- )
-
- }
-
- shiny::moduleServer(id, cohortDefinitionServer)
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/CohortOverlapModule.R b/inst/shiny/DiagnosticsExplorer/R/CohortOverlapModule.R
deleted file mode 100644
index 12e96d3c0..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/CohortOverlapModule.R
+++ /dev/null
@@ -1,435 +0,0 @@
-### cohort overlap plot ##############
-plotCohortOverlap <- function(data,
- shortNameRef = NULL,
- yAxis = "Percentages") {
- data <- data %>%
- addShortName(
- shortNameRef = shortNameRef,
- cohortIdColumn = "targetCohortId",
- shortNameColumn = "targetShortName"
- ) %>%
- addShortName(
- shortNameRef = shortNameRef,
- cohortIdColumn = "comparatorCohortId",
- shortNameColumn = "comparatorShortName"
- )
-
- plotData <- data %>%
- dplyr::mutate(
- absTOnlySubjects = abs(tOnlySubjects),
- absCOnlySubjects = abs(cOnlySubjects),
- absBothSubjects = abs(bothSubjects),
- absEitherSubjects = abs(eitherSubjects),
- signTOnlySubjects = dplyr::case_when(tOnlySubjects < 0 ~ "<", TRUE ~ ""),
- signCOnlySubjects = dplyr::case_when(cOnlySubjects < 0 ~ "<", TRUE ~ ""),
- signBothSubjects = dplyr::case_when(bothSubjects < 0 ~ "<", TRUE ~ "")
- ) %>%
- dplyr::mutate(
- tOnlyString = paste0(
- signTOnlySubjects,
- scales::comma(absTOnlySubjects, accuracy = 1),
- " (",
- signTOnlySubjects,
- scales::percent(absTOnlySubjects /
- absEitherSubjects,
- accuracy = 1
- ),
- ")"
- ),
- cOnlyString = paste0(
- signCOnlySubjects,
- scales::comma(absCOnlySubjects, accuracy = 1),
- " (",
- signCOnlySubjects,
- scales::percent(absCOnlySubjects /
- absEitherSubjects,
- accuracy = 1
- ),
- ")"
- ),
- bothString = paste0(
- signBothSubjects,
- scales::comma(absBothSubjects, accuracy = 1),
- " (",
- signBothSubjects,
- scales::percent(absBothSubjects /
- absEitherSubjects,
- accuracy = 1
- ),
- ")"
- )
- ) %>%
- dplyr::mutate(
- tooltip = paste0(
- "Database: ",
- databaseName,
- "\n",
- "\n",
- targetShortName,
- " only: ",
- tOnlyString,
- "\nBoth: ",
- bothString,
- "\n",
- comparatorShortName,
- " only: ",
- cOnlyString
- )
- ) %>%
- dplyr::select(
- targetShortName,
- comparatorShortName,
- databaseId,
- databaseName,
- absTOnlySubjects,
- absCOnlySubjects,
- absBothSubjects,
- tooltip
- ) %>%
- tidyr::pivot_longer(
- cols = c(
- "absTOnlySubjects",
- "absCOnlySubjects",
- "absBothSubjects"
- ),
- names_to = "subjectsIn",
- values_to = "value"
- ) %>%
- dplyr::mutate(
- subjectsIn = dplyr::recode(
- subjectsIn,
- absTOnlySubjects = "Left cohort only",
- absBothSubjects = "Both cohorts",
- absCOnlySubjects = "Right cohort only"
- )
- )
-
- plotData$subjectsIn <-
- factor(
- plotData$subjectsIn,
- levels = c("Right cohort only", "Both cohorts", "Left cohort only")
- )
-
- if (yAxis == "Percentages") {
- position <- "fill"
- } else {
- position <- "stack"
- }
-
- sortTargetShortName <- plotData %>%
- dplyr::select(targetShortName) %>%
- dplyr::distinct() %>%
- dplyr::arrange(-as.integer(sub(
- pattern = "^C", "", x = targetShortName
- )))
-
- sortComparatorShortName <- plotData %>%
- dplyr::select(comparatorShortName) %>%
- dplyr::distinct() %>%
- dplyr::arrange(as.integer(sub(
- pattern = "^C", "", x = comparatorShortName
- )))
-
- plotData <- plotData %>%
- dplyr::arrange(
- targetShortName = factor(targetShortName, levels = sortTargetShortName$targetShortName),
- targetShortName
- ) %>%
- dplyr::arrange(
- comparatorShortName = factor(comparatorShortName, levels = sortComparatorShortName$comparatorShortName),
- comparatorShortName
- )
-
- plotData$targetShortName <- factor(plotData$targetShortName,
- levels = sortTargetShortName$targetShortName
- )
-
- plotData$comparatorShortName <-
- factor(plotData$comparatorShortName,
- levels = sortComparatorShortName$comparatorShortName
- )
-
- plot <- ggplot2::ggplot(data = plotData) +
- ggplot2::aes(
- fill = subjectsIn,
- y = targetShortName,
- x = value,
- tooltip = tooltip,
- group = subjectsIn
- ) +
- ggplot2::ylab(label = "") +
- ggplot2::xlab(label = "") +
- ggplot2::scale_fill_manual("Subjects in", values = c(rgb(0.8, 0.2, 0.2), rgb(0.3, 0.2, 0.4), rgb(0.4, 0.4, 0.9))) +
- ggplot2::facet_grid(comparatorShortName ~ databaseName) +
- ggplot2::theme(
- panel.background = ggplot2::element_blank(),
- strip.background = ggplot2::element_blank(),
- panel.grid.major.x = ggplot2::element_line(color = "gray"),
- axis.ticks.y = ggplot2::element_blank(),
- panel.spacing = ggplot2::unit(2, "lines")
- ) +
- ggiraph::geom_bar_interactive(
- position = position,
- alpha = 0.6,
- stat = "identity"
- )
- if (yAxis == "Percentages") {
- plot <- plot + ggplot2::scale_x_continuous(labels = scales::percent)
- } else {
- plot <-
- plot + ggplot2::scale_x_continuous(labels = scales::comma, n.breaks = 3)
- }
- width <- length(unique(plotData$databaseId))
- height <-
- nrow(
- plotData %>%
- dplyr::select(targetShortName, comparatorShortName) %>%
- dplyr::distinct()
- )
- plot <- ggiraph::girafe(
- ggobj = plot,
- options = list(ggiraph::opts_sizing(rescale = TRUE)),
- width_svg = max(12, 2 * width),
- height_svg = max(2, 0.5 * height)
- )
- return(plot)
-}
-
-
-#' Cohort Overlap View
-#'
-cohortOverlapView <- function(id) {
- ns <- shiny::NS(id)
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Cohort Overlap (subjects)",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "cohortOverlap.html"))
- ),
- shinydashboard::box(
- status = "warning",
- width = "100%",
- tags$div(
- style = "max-height: 100px; overflow-y: auto",
- shiny::uiOutput(outputId = ns("selectedCohorts"))
- )
- ),
- shinydashboard::box(
- width = NULL,
- status = "primary",
-
- shiny::tabsetPanel(
- type = "pills",
- shiny::tabPanel(
- title = "Plot",
- shiny::radioButtons(
- inputId = ns("overlapPlotType"),
- label = "",
- choices = c("Percentages", "Counts"),
- selected = "Percentages",
- inline = TRUE
- ),
- shinycssloaders::withSpinner(ggiraph::ggiraphOutput(ns("overlapPlot"), width = "100%", height = "100%"))
- ),
-
- shiny::tabPanel(
- title = "Table",
- shiny::fluidRow(
- shiny::column(
- width = 3,
- shiny::checkboxInput(
- inputId = ns("showAsPercentage"),
- label = "Show As Percentage",
- value = TRUE
- )
- ),
- shiny::column(
- width = 3,
- shiny::checkboxInput(
- inputId = ns("showCohortIds"),
- label = "Show Cohort Ids",
- value = TRUE
- )
- )
- ),
- shinycssloaders::withSpinner(
- reactable::reactableOutput(ns("overlapTable"))
- )
- )
- )
- )
- )
-}
-
-#' Cohort Overlap Module
-#'
-#' @requiredPackage shiny
-#' @requiredPackage shinydashboard
-#' @requiredPackage shinycssloaders
-#' @requiredPackage ggiraph
-#'
-cohortOverlapModule <- function(id,
- dataSource,
- selectedCohorts,
- selectedDatabaseIds,
- targetCohortId,
- cohortIds,
- cohortTable) {
- ns <- shiny::NS(id)
- shiny::moduleServer(id, function(input, output, session) {
- output$selectedCohorts <- shiny::renderUI({ selectedCohorts() })
-
- # Cohort Overlap ------------------------
- cohortOverlapData <- reactive({
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- validate(need(length(cohortIds()) > 1, "Please select at least two cohorts."))
- combisOfTargetComparator <- t(utils::combn(cohortIds(), 2)) %>%
- as.data.frame() %>%
- dplyr::tibble()
- colnames(combisOfTargetComparator) <- c("targetCohortId", "comparatorCohortId")
-
-
- data <- getResultsCohortOverlap(
- dataSource = dataSource,
- targetCohortIds = combisOfTargetComparator$targetCohortId,
- comparatorCohortIds = combisOfTargetComparator$comparatorCohortId,
- databaseIds = selectedDatabaseIds()
- )
- validate(need(
- !is.null(data),
- paste0("No cohort overlap data for this combination")
- ))
- validate(need(
- nrow(data) > 0,
- paste0("No cohort overlap data for this combination.")
- ))
- return(data)
- })
-
- output$overlapPlot <- ggiraph::renderggiraph(expr = {
- validate(need(
- length(cohortIds()) > 0,
- paste0("Please select Target Cohort(s)")
- ))
-
- data <- cohortOverlapData()
- validate(need(
- !is.null(data),
- paste0("No cohort overlap data for this combination")
- ))
- validate(need(
- nrow(data) > 0,
- paste0("No cohort overlap data for this combination.")
- ))
-
- validate(need(
- !all(is.na(data$eitherSubjects)),
- paste0("No cohort overlap data for this combination.")
- ))
-
- plot <- plotCohortOverlap(
- data = data,
- shortNameRef = cohortTable,
- yAxis = input$overlapPlotType
- )
- return(plot)
- })
-
-
- output$overlapTable <- reactable::renderReactable({
- data <- cohortOverlapData()
- validate(need(
- !is.null(data),
- paste0("No cohort overlap data for this combination")
- ))
-
- data <- data %>%
- dplyr::inner_join(cohortTable %>% dplyr::select(cohortId,
- targetCohortName = cohortName),
- by = c("targetCohortId" = "cohortId")) %>%
- dplyr::inner_join(cohortTable %>% dplyr::select(cohortId,
- comparatorCohortName = cohortName),
- by = c("comparatorCohortId" = "cohortId")) %>%
- dplyr::select(
- databaseName,
- targetCohortId,
- targetCohortName,
- comparatorCohortId,
- comparatorCohortName,
- tOnly = tOnlySubjects,
- cOnly = cOnlySubjects,
- both = bothSubjects,
- totalSubjects = eitherSubjects
- )
-
- if (input$showCohortIds) {
- data <- data %>% dplyr::mutate(
- targetCohortName = paste0("C", targetCohortId, " - ", targetCohortName),
- comparatorCohortName = paste0("C", comparatorCohortId, " - ", comparatorCohortName)
- )
- }
-
- data <- data %>% dplyr::select(-targetCohortId, -comparatorCohortId)
-
- if (input$showAsPercentage) {
- data$tOnly <- data$tOnly / data$totalSubjects
- data$cOnly <- data$cOnly / data$totalSubjects
- data$both <- data$both / data$totalSubjects
- }
-
- styleFunc <- function(value) {
- color <- '#fff'
- if (input$showAsPercentage) {
- if (is.numeric(value)) {
- value <- ifelse(is.na(value), 0, value)
- color <- pallete(value)
- }
- }
- list(background = color)
- }
-
- valueColDef <- reactable::colDef(
- cell = formatDataCellValueInDisplayTable(input$showAsPercentage),
- style = styleFunc,
- width = 80
- )
- colnames(data) <- SqlRender::camelCaseToTitleCase(colnames(data))
- reactable::reactable(
- data = data,
- columns = list(
- "T Only" = valueColDef,
- "C Only" = valueColDef,
- "Both" = valueColDef,
- "Target Cohort Name" = reactable::colDef(minWidth = 300),
- "Comparator Cohort Name" = reactable::colDef(minWidth = 300),
- "Total Subjects" = reactable::colDef(cell = formatDataCellValueInDisplayTable(FALSE))
- ),
- sortable = TRUE,
- groupBy = c("Target Cohort Name", "Comparator Cohort Name"),
- resizable = TRUE,
- filterable = TRUE,
- searchable = TRUE,
- pagination = TRUE,
- showPagination = TRUE,
- showPageInfo = TRUE,
- highlight = TRUE,
- striped = TRUE,
- compact = TRUE,
- wrap = TRUE,
- showSortIcon = TRUE,
- showSortable = TRUE,
- fullWidth = TRUE,
- bordered = TRUE,
- onClick = "select",
- showPageSizeOptions = TRUE,
- pageSizeOptions = c(10, 20, 50, 100, 1000),
- defaultPageSize = 20,
- theme = reactable::reactableTheme(
- rowSelectedStyle = list(backgroundColor = "#eee", boxShadow = "inset 2px 0 0 0 #ffa62d")
- )
- )
- })
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/CompareCharacterizationModule.R b/inst/shiny/DiagnosticsExplorer/R/CompareCharacterizationModule.R
deleted file mode 100644
index ba219ebb0..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/CompareCharacterizationModule.R
+++ /dev/null
@@ -1,841 +0,0 @@
-plotTemporalCompareStandardizedDifference <- function(balance,
- shortNameRef = NULL,
- xLimitMin = 0,
- xLimitMax = 1,
- yLimitMin = 0,
- yLimitMax = 1,
- domain = "all") {
- domains <-
- c(
- "Condition",
- "Device",
- "Drug",
- "Measurement",
- "Observation",
- "Procedure",
- "Demographics"
- )
-
- balance$domainId[!balance$domainId %in% domains] <- "Other"
- if (domain != "all") {
- balance <- balance %>%
- dplyr::filter(domainId == !!domain)
- }
- validate(need((nrow(balance) > 0), paste0("No data for selected combination.")))
-
- # Can't make sense of plot with > 1000 dots anyway, so remove
- # anything with small mean in both target and comparator:
- if (nrow(balance) > 1000) {
- balance <- balance %>%
- dplyr::filter(mean1 > 0.01 | mean2 > 0.01)
- }
- if (nrow(balance) > 1000) {
- balance <- balance %>%
- dplyr::filter(sumValue1 > 0 & sumValue2 > 0)
- }
-
- balance <- balance %>%
- addShortName(
- shortNameRef = shortNameRef,
- cohortIdColumn = "cohortId1",
- shortNameColumn = "targetCohort"
- ) %>%
- addShortName(
- shortNameRef = shortNameRef,
- cohortIdColumn = "cohortId2",
- shortNameColumn = "comparatorCohort"
- )
-
- # ggiraph::geom_point_interactive(ggplot2::aes(tooltip = tooltip), size = 3, alpha = 0.6)
- balance$tooltip <-
- c(
- paste0(
- "Covariate Name: ",
- balance$covariateName,
- "\nDomain: ",
- balance$domainId,
- "\nAnalysis: ",
- balance$analysisName,
- "\nY ",
- balance$comparatorCohort,
- ": ",
- scales::comma(balance$mean2, accuracy = 0.01),
- "\nX ",
- balance$targetCohort,
- ": ",
- scales::comma(balance$mean1, accuracy = 0.01),
- "\nStd diff.:",
- scales::comma(balance$stdDiff, accuracy = 0.01)
- )
- )
-
- # Code used to generate palette:
- # writeLines(paste(RColorBrewer::brewer.pal(n = length(domains), name = "Dark2"), collapse = "\", \""))
-
- # Make sure colors are consistent, no matter which domains are included:
- colors <-
- c(
- "#1B9E77",
- "#D95F02",
- "#7570B3",
- "#E7298A",
- "#66A61E",
- "#E6AB02",
- "#444444"
- )
- colors <-
- colors[c(domains, "Other") %in% unique(balance$domainId)]
-
- balance$domainId <-
- factor(balance$domainId, levels = c(domains, "Other"))
-
- # targetLabel <- paste(strwrap(targetLabel, width = 50), collapse = "\n")
- # comparatorLabel <- paste(strwrap(comparatorLabel, width = 50), collapse = "\n")
-
- xCohort <- balance %>%
- dplyr::distinct(balance$targetCohort) %>%
- dplyr::pull()
- yCohort <- balance %>%
- dplyr::distinct(balance$comparatorCohort) %>%
- dplyr::pull()
-
- if (nrow(balance) == 0) {
- return(NULL)
- }
-
- plot <-
- ggplot2::ggplot(
- balance,
- ggplot2::aes(
- x = mean1,
- y = mean2,
- color = domainId
- )
- ) +
- ggiraph::geom_point_interactive(
- ggplot2::aes(tooltip = tooltip),
- size = 3,
- shape = 16,
- alpha = 0.5
- ) +
- ggplot2::geom_abline(
- slope = 1,
- intercept = 0,
- linetype = "dashed"
- ) +
- ggplot2::geom_hline(yintercept = 0) +
- ggplot2::geom_vline(xintercept = 0) +
- # ggplot2::scale_x_continuous("Mean") +
- # ggplot2::scale_y_continuous("Mean") +
- ggplot2::xlab(paste("Covariate Mean in Target Cohort")) +
- ggplot2::ylab(paste("Covariate Mean in Comparator Cohort")) +
- ggplot2::scale_color_manual("Domain", values = colors) +
- ggplot2::facet_grid(cols = ggplot2::vars(temporalChoices)) + # need to facet by 'startDay' that way it is arranged in numeric order.
- # but labels should be based on choices
- # ggplot2::facet_wrap(~temporalChoices) +
- ggplot2::theme(
- strip.background = ggplot2::element_blank(),
- panel.spacing = ggplot2::unit(2, "lines")
- ) +
- ggplot2::xlim(xLimitMin, xLimitMax) +
- ggplot2::ylim(yLimitMin, yLimitMax)
-
- numberOfTimeIds <- balance$timeId %>%
- unique() %>%
- length()
-
- plot <- ggiraph::girafe(
- ggobj = plot,
- options = list(ggiraph::opts_sizing(rescale = TRUE)),
- width_svg = max(8, 3 * numberOfTimeIds),
- height_svg = 3
- )
- return(plot)
-}
-
-compareCohortCharacterizationView <- function(id, title = "Compare cohort characterization") {
- ns <- shiny::NS(id)
-
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Compare Cohort Characterization",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "compareCohortCharacterization.html"))
- ),
- shinydashboard::box(
- width = NULL,
- title = title,
- shiny::fluidRow(
- shiny::column(
- width = 3,
- shinyWidgets::pickerInput(
- inputId = ns("targetCohort"),
- label = "Target Cohort",
- choices = NULL,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::column(
- width = 3,
- shinyWidgets::pickerInput(
- inputId = ns("targetDatabase"),
- label = "Target Database",
- choices = NULL,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::column(
- width = 3,
- shinyWidgets::pickerInput(
- inputId = ns("comparatorCohort"),
- label = "Comparator Cohort",
- choices = NULL,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::column(
- width = 3,
- shinyWidgets::pickerInput(
- inputId = ns("comparatorDatabase"),
- label = "Comparator Database",
- choices = NULL,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- )
- ),
- shiny::fluidRow(
- shiny::column(
- width = 4,
- shinyWidgets::pickerInput(
- inputId = ns("timeIdChoices"),
- label = "Temporal Window (s)",
- choices = NULL,
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- selected = NULL,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- maxOptions = 5, # Selecting even this many will be slow
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::column(
- width = 4,
- shinyWidgets::pickerInput(
- inputId = ns("analysisNameFilter"),
- label = "Analysis name",
- choices = c(""),
- selected = c(""),
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::column(
- width = 4,
- shinyWidgets::pickerInput(
- inputId = ns("domainIdFilter"),
- label = "Domain name",
- choices = c(""),
- selected = c(""),
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- ),
- shiny::fluidRow(
- shiny::column(
- width = 3,
- shiny::numericInput(
- inputId = ns("minMeanFilterVal"),
- label = "Min Covariate Mean",
- value = 0.005,
- min = 0.0,
- max = 0.9,
- step = 0.005
- )
- )
- ),
- shiny::actionButton(label = "Generate Report", inputId = ns("generatePlot"))
- ),
- shiny::conditionalPanel(
- condition = "input.generatePlot != 0",
- ns = ns,
- shiny::uiOutput(ns("selectionsPlot")),
- shinydashboard::box(
- width = NULL,
- status = "primary",
- shiny::tabsetPanel(
- type = "pills",
- shiny::tabPanel(
- title = "Plot",
- shinycssloaders::withSpinner(
- ggiraph::ggiraphOutput(
- outputId = ns("compareCohortCharacterizationBalancePlot"),
- width = "100%",
- height = "100%"
- )
- )
- ),
- shiny::tabPanel(
- title = "Raw Table",
- shiny::fluidRow(
- shiny::column(
- width = 3,
- shiny::radioButtons(
- inputId = ns("proportionOrContinuous"),
- label = "Covariate Type",
- choices = c("All", "Proportion", "Continuous"),
- selected = "Proportion",
- inline = TRUE
- )
- ),
- shiny::column(
- width = 3,
- shiny::radioButtons(
- inputId = ns("compareCharacterizationColumnFilters"),
- label = "Display values",
- choices = c("Mean", "Mean and Standard Deviation"),
- selected = "Mean",
- inline = TRUE
- ),
- shiny::checkboxInput(
- inputId = ns("showOnlyMutualCovariates"),
- label = "Show only covariates found in target and comparator",
- value = FALSE
- )
- ),
- shiny::column(
- width = 4,
- shinyWidgets::pickerInput(
- inputId = ns("timeIdChoicesSingle"),
- label = "Temporal Window",
- choices = NULL,
- multiple = FALSE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- selected = NULL,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- )
- ),
- shinycssloaders::withSpinner(
- reactable::reactableOutput(ns("compareCohortCharacterizationTable")),
- ),
- csvDownloadButton(ns, "compareCohortCharacterizationTable")
- )
- )
- )
- )
- )
-}
-
-
-compareCohortCharacterizationModule <- function(id,
- dataSource,
- cohortTable,
- databaseTable,
- conceptSets,
- temporalAnalysisRef,
- analysisNameOptions,
- domainIdOptions,
- temporalChoices) {
-
-
- shiny::moduleServer(id, function(input, output, session) {
- # Temporal choices (e.g. -30d - 0d ) are dynamic to execution
- timeIdOptions <- getResultsTemporalTimeRef(dataSource = dataSource) %>%
- dplyr::arrange(sequence)
- shiny::observe({
- # Default time windows
- selectedTimeWindows <- timeIdOptions %>%
- dplyr::filter(primaryTimeId == 1) %>%
- dplyr::filter(isTemporal == 1) %>%
- dplyr::arrange(sequence) %>%
- dplyr::pull("temporalChoices")
-
- shinyWidgets::updatePickerInput(session,
- inputId = "timeIdChoices",
- choices = timeIdOptions$temporalChoices,
- selected = selectedTimeWindows)
-
- shinyWidgets::updatePickerInput(session,
- inputId = "timeIdChoicesSingle",
- choices = timeIdOptions$temporalChoices)
-
- cohortChoices <- cohortTable$cohortId
- names(cohortChoices) <- cohortTable$cohortName
- shinyWidgets::updatePickerInput(session,
- inputId = "targetCohort",
- choices = cohortChoices)
-
- shinyWidgets::updatePickerInput(session,
- inputId = "comparatorCohort",
- choices = cohortChoices)
-
-
- databaseChoices <- databaseTable$databaseId
- names(databaseChoices) <- databaseTable$databaseName
- shinyWidgets::updatePickerInput(session,
- inputId = "targetDatabase",
- choices = databaseChoices)
-
- shinyWidgets::updatePickerInput(session,
- inputId = "comparatorDatabase",
- choices = databaseChoices)
-
- })
-
- selectedTimeIds <- shiny::reactive({
- timeIdOptions %>%
- dplyr::filter(temporalChoices %in% input$timeIdChoices) %>%
- dplyr::select(timeId) %>%
- dplyr::pull()
- })
-
- selectedTimeIdsSingle <- shiny::reactive({
- timeIdOptions %>%
- dplyr::filter(temporalChoices %in% input$timeIdChoicesSingle) %>%
- dplyr::select(timeId) %>%
- dplyr::pull()
- })
-
- targetCohortId <- shiny::reactive({
- as.integer(input$targetCohort)
- })
-
- comparatorCohortId <- shiny::reactive({
- as.integer(input$comparatorCohort)
- })
-
- selectedDatabaseIds <- shiny::reactive({
- c(input$targetDatabase, input$comparatorDatabase)
- })
- temporalCharacterizationOutput <-
- shiny::reactive(x = {
-
- data <- getCharacterizationOutput(
- dataSource = dataSource,
- cohortIds = c(targetCohortId(), comparatorCohortId()),
- databaseIds = selectedDatabaseIds(),
- temporalCovariateValueDist = FALSE,
- meanThreshold = input$minMeanFilterVal
- )
-
- return(data)
- })
-
- compareCharacterizationOutput <-
- shiny::reactive(x = {
- data <- temporalCharacterizationOutput()
- if (!hasData(data)) {
- return(NULL)
- }
- return(data)
- })
-
-
- # Compare cohort characterization --------------------------------------------
- ### analysisNameFilter -----
- shiny::observe({
- characterizationAnalysisOptionsUniverse <- NULL
- charcterizationAnalysisOptionsSelected <- NULL
-
- if (hasData(temporalAnalysisRef)) {
- characterizationAnalysisOptionsUniverse <- analysisNameOptions
- charcterizationAnalysisOptionsSelected <-
- temporalAnalysisRef %>%
- dplyr::pull(analysisName) %>%
- unique()
- }
-
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "analysisNameFilter",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = characterizationAnalysisOptionsUniverse,
- selected = charcterizationAnalysisOptionsSelected
- )
- })
-
-
- ### domainIdFilter -----
- shiny::observe({
- characterizationDomainOptionsUniverse <- NULL
- charcterizationDomainOptionsSelected <- NULL
-
- if (hasData(temporalAnalysisRef)) {
- characterizationDomainOptionsUniverse <- domainIdOptions
- charcterizationDomainOptionsSelected <-
- temporalAnalysisRef %>%
- dplyr::pull(domainId) %>%
- unique()
- }
-
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "domainIdFilter",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = characterizationDomainOptionsUniverse,
- selected = charcterizationDomainOptionsSelected
- )
- })
-
- ## compareCohortCharacterizationDataFiltered ------------
- compareCohortCharacterizationDataFiltered <- shiny::reactive({
- validate(need(length(targetCohortId()) == 1, "One target cohort must be selected"))
- validate(need(
- length(comparatorCohortId()) == 1,
- "One comparator cohort must be selected"
- ))
- validate(
- need(
- (targetCohortId() != comparatorCohortId()) | (input$comparatorDatabase != input$targetDatabase),
- "Target and comparator cohorts/database cannot be the same"
- )
- )
-
- data <- compareCharacterizationOutput()
- if (!hasData(data)) {
- return(NULL)
- }
-
- data <- data$covariateValue
- if (!hasData(data)) {
- return(NULL)
- }
- data <- data %>%
- dplyr::filter(cohortId %in% c(targetCohortId(), comparatorCohortId())) %>%
- dplyr::filter(databaseId %in% selectedDatabaseIds())
-
- data <- data %>%
- dplyr::filter(analysisName %in% input$analysisNameFilter) %>%
- dplyr::filter(domainId %in% input$domainIdFilter)
-
- if (!hasData(data)) {
- return(NULL)
- }
- return(data)
- })
-
- ## compareCohortCharacterizationBalanceData ----------------------------------------
- compareCohortCharacterizationBalanceData <- shiny::reactive({
- data <- compareCohortCharacterizationDataFiltered()
- if (!hasData(data)) {
- return(NULL)
- }
- covs1 <- data %>%
- dplyr::filter(cohortId == targetCohortId(),
- databaseId == input$targetDatabase)
- if (!hasData(covs1)) {
- return(NULL)
- }
- covs2 <- data %>%
- dplyr::filter(cohortId == comparatorCohortId(),
- databaseId == input$comparatorDatabase)
- if (!hasData(covs2)) {
- return(NULL)
- }
-
- return(compareCohortCharacteristics(covs1, covs2))
- })
-
- rawTableBaseData <- shiny::eventReactive(input$generatePlot, {
- data <- compareCohortCharacterizationBalanceData()
- if (!hasData(data)) {
- return(NULL)
- }
- return(data)
- })
-
-
- ## compareCohortCharacterizationRawTable ----------------------------------------
- compareCohortCharacterizationRawTable <- shiny::reactive({
- data <- rawTableBaseData()
- validate(need(hasData(data), "No data available for selected combination."))
- distinctTemporalChoices <- unique(temporalChoices$temporalChoices)
- sortedTemporalChoices <- data %>%
- dplyr::arrange(factor(temporalChoices, levels = distinctTemporalChoices)) %>%
- dplyr::distinct(temporalChoices) %>%
- dplyr::pull(temporalChoices)
-
- data <- data %>%
- dplyr::arrange(factor(temporalChoices, levels = sortedTemporalChoices))
-
- data <- data %>%
- dplyr::filter(timeId == selectedTimeIdsSingle())
-
- showAsPercent <- FALSE
- if (input$proportionOrContinuous == "Proportion") {
- showAsPercent <- TRUE
- data <- data %>%
- dplyr::filter(isBinary == "Y")
- } else if (input$proportionOrContinuous == "Continuous") {
- data <- data %>%
- dplyr::filter(isBinary == "N")
- }
-
- data <- data %>%
- dplyr::rename(
- "target" = mean1,
- "sdT" = sd1,
- "comparator" = mean2,
- "sdC" = sd2,
- "StdDiff" = absStdDiff
- )
-
- if (input$compareCharacterizationColumnFilters == "Mean and Standard Deviation") {
- data <- data %>%
- dplyr::select(covariateName,
- analysisName,
- conceptId,
- target,
- sdT,
- comparator,
- sdC,
- StdDiff)
- } else {
- data <- data %>%
- dplyr::select(covariateName,
- analysisName,
- conceptId,
- target,
- comparator,
- StdDiff)
- }
-
- # Covariates where stdDiff is NA or NULL
- if (input$showOnlyMutualCovariates) {
- data <- data %>% dplyr::filter(!is.na(StdDiff),
- !is.null(StdDiff))
- }
-
- reactable::reactable(
- data = data,
- columns = list(
- target = reactable::colDef(
- cell = formatDataCellValueInDisplayTable(showDataAsPercent = showAsPercent),
- na = ""
- ),
- comparator = reactable::colDef(
- cell = formatDataCellValueInDisplayTable(showDataAsPercent = showAsPercent),
- na = ""
- ),
- StdDiff = reactable::colDef(
- cell = function(value) {
- return(round(value,2))
- },
- style = function(value) {
- color <- '#fff'
- if (is.numeric(value) & hasData(data$StdDiff)) {
- value <- ifelse(is.na(value), min(data$StdDiff, na.rm = TRUE), value)
- normalized <- (value - min(data$StdDiff, na.rm = TRUE)) / (max(data$StdDiff, na.rm = TRUE) - min(data$StdDiff, na.rm = TRUE))
- color <- pallete(normalized)
- }
- list(background = color)
- },
- na = ""
- ),
- covariateName = reactable::colDef(name = "Covariate Name", minWidth = 500),
- analysisName = reactable::colDef(name = "Analysis Name"),
- conceptId = reactable::colDef(name = "Concept Id")
- ),
- sortable = TRUE,
- resizable = TRUE,
- filterable = TRUE,
- searchable = TRUE,
- pagination = TRUE,
- showPagination = TRUE,
- showPageInfo = TRUE,
- highlight = TRUE,
- striped = TRUE,
- compact = TRUE,
- wrap = FALSE,
- showSortIcon = TRUE,
- showSortable = TRUE,
- fullWidth = TRUE,
- bordered = TRUE,
- showPageSizeOptions = TRUE,
- pageSizeOptions = c(10, 20, 50, 100, 1000),
- defaultPageSize = 100,
- selection = NULL,
- theme = reactable::reactableTheme(
- rowSelectedStyle = list(backgroundColor = "#eee", boxShadow = "inset 2px 0 0 0 #ffa62d")
- )
- )
-
- })
-
- selectionsOutput <- shiny::reactive({
-
- target <- paste(cohortTable %>%
- dplyr::filter(cohortId == targetCohortId()) %>%
- dplyr::select(cohortName) %>%
- dplyr::pull(),
- collapse = ", ")
- comparator <- paste(cohortTable %>%
- dplyr::filter(cohortId == comparatorCohortId()) %>%
- dplyr::select(cohortName) %>%
- dplyr::pull(),
- collapse = ", ")
-
-
- shinydashboard::box(
- status = "warning",
- width = "100%",
- shiny::fluidRow(
- shiny::column(
- width = 7,
- tags$b("Target Cohort :"), paste0(target, " C", targetCohortId()),
- tags$br(),
- tags$b("Comparator Cohort :"), paste0(comparator, " C", comparatorCohortId())
- ),
- shiny::column(
- width = 5,
- tags$b("Target Database :"),
- paste(databaseTable %>%
- dplyr::filter(databaseId == input$targetDatabase) %>%
- dplyr::select(databaseName) %>%
- dplyr::pull(),
- collapse = ", "),
- tags$br(),
- tags$b("Comparator Database :"),
- paste(databaseTable %>%
- dplyr::filter(databaseId == input$comparatorDatabase) %>%
- dplyr::select(databaseName) %>%
- dplyr::pull(),
- collapse = ", ")
- )
- )
- )
- })
-
- generateTable <- shiny::reactive({
- data <- compareCohortCharacterizationRawTable()
- validate(need(hasData(data), "No data for selected combination"))
- return(data)
- })
-
- ## output: compareCohortCharacterizationTable ----------------------------------------
- output$compareCohortCharacterizationTable <- reactable::renderReactable(expr = {
- generateTable()
- })
-
- generatePlot <- shiny::eventReactive(input$generatePlot, {
- progress <- shiny::Progress$new()
- on.exit(progress$close())
- progress$set(
- message = "Getting plot data",
- value = 0
- )
-
- data <- compareCohortCharacterizationBalanceData()
- validate(need(
- hasData(data),
- "No data available for selected combination."
- ))
-
- progress$set(
- message = "Plotting results",
- value = 50
- )
- distinctTemporalChoices <- unique(temporalChoices$temporalChoices)
-
- data <- data %>%
- dplyr::filter(timeId %in% selectedTimeIds(),
- !is.na(stdDiff)) %>%
- dplyr::arrange(factor(temporalChoices, levels = distinctTemporalChoices)) %>%
- dplyr::mutate(temporalChoices = factor(temporalChoices, levels = unique(temporalChoices)))
-
- plot <-
- plotTemporalCompareStandardizedDifference(
- balance = data,
- shortNameRef = cohortTable,
- xLimitMin = 0,
- xLimitMax = 1,
- yLimitMin = 0,
- yLimitMax = 1
- )
-
- progress$set(
- message = "Returning data",
- value = 90
- )
- validate(need(
- !is.null(plot),
- "No plot available for selected combination."
- ))
- return(plot)
- })
-
- selectionsOutputPlot <- shiny::eventReactive(input$generatePlot, {
- selectionsOutput()
- })
-
- output$selectionsPlot <- shiny::renderUI({
- selectionsOutputPlot()
- })
-
- ## output: compareCohortCharacterizationBalancePlot ----------------------------------------
- output$compareCohortCharacterizationBalancePlot <-
- ggiraph::renderggiraph(expr = {
- generatePlot()
- })
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/ConceptsInDataSourceModule.R b/inst/shiny/DiagnosticsExplorer/R/ConceptsInDataSourceModule.R
deleted file mode 100644
index 7632e15c8..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/ConceptsInDataSourceModule.R
+++ /dev/null
@@ -1,230 +0,0 @@
-conceptsInDataSourceView <- function(id) {
- ns <- shiny::NS(id)
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Concepts in Data Source",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "conceptsInDataSource.html"))
- ),
- shinydashboard::box(
- status = "warning",
- width = "100%",
- tags$div(
- style = "max-height: 100px; overflow-y: auto",
- shiny::uiOutput(outputId = ns("selectedCohorts"))
- )
- ),
- shinydashboard::box(
- title = NULL,
- width = NULL,
- tags$table(
- width = "100%",
- tags$tr(
- tags$td(
- shiny::radioButtons(
- inputId = ns("includedType"),
- label = "",
- choices = c("Source fields", "Standard fields"),
- selected = "Standard fields",
- inline = TRUE
- )
- ),
- tags$td(
- shiny::radioButtons(
- inputId = ns("conceptsInDataSourceTableColumnFilter"),
- label = "",
- choices = c("Both", "Persons", "Records"),
- #
- selected = "Persons",
- inline = TRUE
- )
- )
- ),
- ),
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("conceptsInDataSourceTable"))),
- csvDownloadButton(ns, "conceptsInDataSourceTable")
- )
- )
-}
-
-
-conceptsInDataSourceModule <- function(id,
- dataSource,
- selectedCohort,
- selectedDatabaseIds,
- targetCohortId,
- selectedConceptSets,
- cohortTable,
- databaseTable) {
- ns <- shiny::NS(id)
- shiny::moduleServer(id, function(input, output, session) {
- output$selectedCohorts <- shiny::renderUI({ selectedCohort() })
- # Concepts in data source------
- conceptsInDataSourceReactive <- shiny::reactive(x = {
- validate(need(
- all(!is.null(selectedDatabaseIds()), length(selectedDatabaseIds()) > 0),
- "No data sources chosen"
- ))
- validate(need(
- all(!is.null(targetCohortId()), length(targetCohortId()) > 0),
- "No cohort chosen"
- ))
- data <- getConceptsInCohort(
- dataSource = dataSource,
- cohortId = targetCohortId(),
- databaseIds = selectedDatabaseIds()
- )
- return(data)
- })
-
- conceptSetIds <- shiny::reactive({
- selectedConceptSets()
- })
-
- getResolvedConcepts <- shiny::reactive({
- output <- resolvedConceptSet(
- dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortId = targetCohortId()
- )
- if (!hasData(output)) {
- return(NULL)
- }
- return(output)
- })
-
- ### getMappedConceptsReactive ----
- getMappedConcepts <- shiny::reactive({
- progress <- shiny::Progress$new()
- on.exit(progress$close())
- progress$set(message = "Getting concepts mapped to concept ids resolved by concept set expression (may take time)", value = 0)
- output <- mappedConceptSet(dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortId = targetCohortId())
- if (!hasData(output)) {
- return(NULL)
- }
- return(output)
- })
-
- getFilteredConceptIds <- shiny::reactive({
- validate(need(hasData(selectedDatabaseIds()), "No data sources chosen"))
- validate(need(hasData(targetCohortId()), "No cohort chosen"))
- validate(need(hasData(conceptSetIds()), "No concept set id chosen"))
- resolved <- getResolvedConcepts()
- mapped <- getMappedConcepts()
- output <- c()
- if (hasData(resolved)) {
- resolved <- resolved %>%
- dplyr::filter(databaseId %in% selectedDatabaseIds()) %>%
- dplyr::filter(cohortId %in% targetCohortId()) %>%
- dplyr::filter(conceptSetId %in% conceptSetIds())
- output <- c(output, resolved$conceptId) %>% unique()
- }
- if (hasData(mapped)) {
- mapped <- mapped %>%
- dplyr::filter(databaseId %in% selectedDatabaseIds()) %>%
- dplyr::filter(cohortId %in% targetCohortId()) %>%
- dplyr::filter(conceptSetId %in% conceptSetIds())
- output <- c(output, mapped$conceptId) %>% unique()
- }
-
- if (hasData(output)) {
- return(output)
- } else {
- return(NULL)
- }
- })
-
- output$conceptsInDataSourceTable <- reactable::renderReactable(expr = {
- validate(need(hasData(selectedDatabaseIds()), "No cohort chosen"))
- validate(need(hasData(targetCohortId()), "No cohort chosen"))
-
- data <- conceptsInDataSourceReactive()
- validate(need(
- hasData(data),
- "No data available for selected combination"
- ))
- if (hasData(selectedConceptSets())) {
- if (length(getFilteredConceptIds()) > 0) {
- data <- data %>%
- dplyr::filter(conceptId %in% getFilteredConceptIds())
- }
- }
- validate(need(
- hasData(data),
- "No data available for selected combination"
- ))
-
- if (input$includedType == "Source fields") {
- data <- data %>%
- dplyr::filter(conceptId > 0) %>%
- dplyr::filter(sourceConceptId == 1) %>%
- dplyr::rename(standard = standardConcept)
- keyColumnFields <-
- c("conceptId", "conceptName", "vocabularyId", "conceptCode")
- }
- if (input$includedType == "Standard fields") {
- data <- data %>%
- dplyr::filter(conceptId > 0) %>%
- dplyr::filter(sourceConceptId == 0) %>%
- dplyr::rename(standard = standardConcept)
- keyColumnFields <-
- c("conceptId", "conceptName", "vocabularyId")
- }
-
- validate(need(hasData(data), "No data available for selected combination"))
- data <- data %>%
- dplyr::rename(
- persons = conceptSubjects,
- records = conceptCount
- ) %>%
- dplyr::arrange(dplyr::desc(abs(dplyr::across(c("records", "persons")))))
-
- if (input$conceptsInDataSourceTableColumnFilter == "Persons") {
- dataColumnFields <- c("persons")
- countLocation <- 1
- } else if (input$conceptsInDataSourceTableColumnFilter == "Records") {
- dataColumnFields <- c("records")
- countLocation <- 1
- } else {
- dataColumnFields <- c("persons", "records")
- countLocation <- 2
- }
-
- countsForHeader <-
- getDisplayTableHeaderCount(
- dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortIds = targetCohortId(),
- source = "cohort",
- fields = input$conceptsInDataSourceTableColumnFilter
- )
-
- maxCountValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(
- data = data,
- string = dataColumnFields
- )
-
- showDataAsPercent <- FALSE
- ## showDataAsPercent set based on UI selection - proportion
-
- displayTable <- getDisplayTableGroupedByDatabaseId(
- data = data,
- cohort = cohortTable,
- databaseTable = databaseTable,
- headerCount = countsForHeader,
- keyColumns = keyColumnFields,
- countLocation = countLocation,
- dataColumns = dataColumnFields,
- maxCount = maxCountValue,
- showDataAsPercent = showDataAsPercent,
- sort = TRUE
- )
- return(displayTable)
- })
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/DatabaseInformationModule.R b/inst/shiny/DiagnosticsExplorer/R/DatabaseInformationModule.R
deleted file mode 100644
index 0f2586283..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/DatabaseInformationModule.R
+++ /dev/null
@@ -1,213 +0,0 @@
-databaseInformationView <- function(id) {
- ns <- shiny::NS(id)
-
- shiny::tagList(
- shinydashboard::box(
- width = NULL,
- title = "Execution meta-data",
- tags$p("Each entry relates to execution on a given cdm. Results are merged between executions incrementally"),
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("databaseInformationTable"))),
- shiny::conditionalPanel(
- "output.databaseInformationTableIsSelected == true",
- ns = ns,
- shinydashboard::box(
- title = shiny::htmlOutput(outputId = ns("metadataInfoTitle")),
- collapsible = TRUE,
- width = NULL,
- collapsed = FALSE,
- shiny::htmlOutput(outputId = ns("metadataInfoDetailsText")),
- shinydashboard::box(
- title = NULL,
- collapsible = TRUE,
- width = NULL,
- collapsed = FALSE,
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("packageDependencySnapShotTable")))
- ),
- shinydashboard::box(
- title = NULL,
- collapsible = TRUE,
- width = NULL,
- collapsed = FALSE,
- shiny::verbatimTextOutput(outputId = ns("argumentsAtDiagnosticsInitiationJson")),
- tags$head(
- tags$style("#argumentsAtDiagnosticsInitiationJson { max-height:400px};")
- )
- )
- )
- )
- )
- )
-}
-
-databaseInformationModule <- function(id,
- dataSource,
- selectedDatabaseIds,
- databaseMetadata) {
- ns <- shiny::NS(id)
- shiny::moduleServer(id, function(input, output, session) {
-
- getDatabaseInformation <- shiny::reactive(x = {
- return(databaseMetadata %>% dplyr::filter(databaseId %in% selectedDatabaseIds()))
- })
-
- # Output: databaseInformationTable ------------------------
- output$databaseInformationTable <- reactable::renderReactable(expr = {
- data <- getDatabaseInformation()
- validate(need(
- all(!is.null(data), nrow(data) > 0),
- "No data available for selected combination."
- ))
-
- if (!"vocabularyVersionCdm" %in% colnames(data)) {
- data$vocabularyVersionCdm <- "Not in data"
- }
- if (!"vocabularyVersion" %in% colnames(data)) {
- data$vocabularyVersion <- "Not in data"
- }
-
- keyColumns <- intersect(
- colnames(data),
- c(
- "databaseId",
- "databaseName",
- "vocabularyVersionCdm",
- "vocabularyVersion",
- "description",
- "startTime",
- "runTime",
- "runTimeUnits",
- "sourceReleaseDate",
- "cdmVersion",
- "cdmReleaseDate",
- "observationPeriodMinDate",
- "observationPeriodMaxDate"
- )
- )
-
- dataColumns <- c(
- "personsInDatasource",
- "recordsInDatasource",
- "personDaysInDatasource"
- )
-
- getDisplayTableSimple(
- data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns,
- selection = "single"
- )
- })
-
- selectedDbRow <- shiny::reactive({
- reactable::getReactableState("databaseInformationTable", "selected")
- })
-
- output$databaseInformationTableIsSelected <- shiny::reactive({
- return(!is.null(selectedDbRow()))
- })
-
- shiny::outputOptions(output,
- "databaseInformationTableIsSelected",
- suspendWhenHidden = FALSE)
-
- getFilteredMetadataInformation <- shiny::reactive(x = {
- idx <- selectedDbRow()
- dbInfo <- getDatabaseInformation()[idx,]
- if (is.null(dbInfo)) {
- return(NULL)
- }
- data <- getExecutionMetadata(dataSource = dataSource,
- databaseId = dbInfo$databaseId)
-
- if (is.null(data)) {
- return(NULL)
- }
-
- # The meta-data data structure needs to be taken out!
- data <- data %>%
- dplyr::mutate(startTime = paste0(startTime)) %>%
- dplyr::mutate(startTime = as.POSIXct(startTime))
-
- data <- data %>% dplyr::filter(startTime == dbInfo$startTime)
- return(data)
- })
-
- output$metadataInfoTitle <- shiny::renderUI(expr = {
- data <- getFilteredMetadataInformation()
-
- if (!hasData(data)) {
- return(NULL)
- }
- tags$p(paste(
- "Run on ",
- data$databaseId,
- "on ",
- data$startTime,
- " for ",
- data$runTime,
- " ",
- data$runTimeUnits
- ))
- })
-
- output$metadataInfoDetailsText <- shiny::renderUI(expr = {
- data <- getFilteredMetadataInformation()
- if (!hasData(data)) {
- return(NULL)
- }
- tags$table(tags$tr(tags$td(
- paste(
- "Ran for ",
- data$runTime,
- data$runTimeUnits,
- "on ",
- data$currentPackage,
- "(",
- data$currentPackageVersion,
- ")"
- )
- )))
- })
-
- ## output: packageDependencySnapShotTable----
- output$packageDependencySnapShotTable <-
- reactable::renderReactable(expr = {
- data <- getFilteredMetadataInformation()
- if (!hasData(data)) {
- return(NULL)
- }
-
- data <- data %>%
- dplyr::pull(packageDependencySnapShotJson)
-
- data <- dplyr::as_tibble(RJSONIO::fromJSON(
- content = data,
- digits = 23
- ))
- keyColumns <- colnames(data)
- getDisplayTableSimple(
- data = data,
- keyColumns = keyColumns,
- dataColumns = c(),
- pageSize = 10
- )
- })
-
- ## output: argumentsAtDiagnosticsInitiationJson----
- output$argumentsAtDiagnosticsInitiationJson <-
- shiny::renderText(expr = {
- data <- getFilteredMetadataInformation()
- if (!hasData(data)) {
- return(NULL)
- }
- data <- data %>%
- dplyr::pull(argumentsAtDiagnosticsInitiationJson) %>%
- RJSONIO::fromJSON(digits = 23) %>%
- RJSONIO::toJSON(
- digits = 23,
- pretty = TRUE
- )
- return(data)
- })
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/DiagExUi.R b/inst/shiny/DiagnosticsExplorer/R/DiagExUi.R
deleted file mode 100644
index b5433d53e..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/DiagExUi.R
+++ /dev/null
@@ -1,432 +0,0 @@
-getAppInfo <- function(appVersionNum) {
- appInformationText <- paste0(
- "Powered by OHDSI Cohort Diagnostics application", paste0(appVersionNum, "."),
- "Application was last initated on ",
- lubridate::now(tzone = "EST"),
- " EST. Cohort Diagnostics website is at https://ohdsi.github.io/CohortDiagnostics/"
- )
-}
-
-uiControls <- function(ns,
- enabledTabs) {
- panels <- shiny::tagList(
- shiny::conditionalPanel(
- condition = "input.tabs!='incidenceRate' &
- input.tabs != 'timeDistribution' &
- input.tabs != 'cohortCharacterization' &
- input.tabs != 'cohortCounts' &
- input.tabs != 'indexEventBreakdown' &
- input.tabs != 'cohortDefinition' &
- input.tabs != 'conceptsInDataSource' &
- input.tabs != 'orphanConcepts' &
- input.tabs != 'inclusionRuleStats' &
- input.tabs != 'visitContext' &
- input.tabs != 'compareCohortCharacterization' &
- input.tabs != 'cohortCharacterization' &
- input.tabs != 'cohortOverlap'",
- ns = ns,
- shinyWidgets::pickerInput(
- inputId = ns("database"),
- label = "Database",
- choices = NULL,
- multiple = FALSE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::conditionalPanel(
- condition = "input.tabs=='incidenceRate' |
- input.tabs == 'timeDistribution' |
- input.tabs == 'cohortCounts' |
- input.tabs == 'indexEventBreakdown' |
- input.tabs == 'conceptsInDataSource' |
- input.tabs == 'orphanConcepts' |
- input.tabs == 'inclusionRuleStats' |
- input.tabs == 'visitContext' |
- input.tabs == 'cohortOverlap'",
- ns = ns,
- shinyWidgets::pickerInput(
- inputId = ns("databases"),
- label = "Database(s)",
- choices = NULL,
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::conditionalPanel(
- condition = "input.tabs != 'databaseInformation' &
- input.tabs != 'cohortDefinition' &
- input.tabs != 'cohortCounts' &
- input.tabs != 'cohortOverlap'&
- input.tabs != 'incidenceRate' &
- input.tabs != 'compareCohortCharacterization' &
- input.tabs != 'cohortCharacterization' &
- input.tabs != 'timeDistribution'",
- ns = ns,
- shinyWidgets::pickerInput(
- inputId = ns("targetCohort"),
- label = "Cohort",
- choices = c(""),
- multiple = FALSE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- liveSearchStyle = "contains",
- size = 10,
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::conditionalPanel(
- condition = "input.tabs == 'cohortCounts' |
- input.tabs == 'cohortOverlap' |
- input.tabs == 'incidenceRate' |
- input.tabs == 'timeDistribution'",
- ns = ns,
- shinyWidgets::pickerInput(
- inputId = ns("cohorts"),
- label = "Cohorts",
- choices = c(""),
- selected = c(""),
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- liveSearchStyle = "contains",
- size = 10,
- dropupAuto = TRUE,
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::conditionalPanel(
- condition = "input.tabs == 'temporalCharacterization' |
- input.tabs == 'conceptsInDataSource' |
- input.tabs == 'orphanConcepts'",
- ns = ns,
- shinyWidgets::pickerInput(
- inputId = ns("conceptSetsSelected"),
- label = "Concept sets",
- choices = c(""),
- selected = c(""),
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- )
- )
-
- return(panels)
-}
-
-dashboardUi <- function(enabledTabs,
- enableAnnotation,
- showAnnotation,
- enableAuthorization,
- appVersionNum,
- id = "DiagnosticsExplorer") {
-
- ns <- shiny::NS(id)
- appInformationText <- getAppInfo(appVersionNum)
-
- if (enableAnnotation & showAnnotation) {
- headerContent <- tags$li(
- if (enableAuthorization) {
- shiny::uiOutput(outputId = ns("signInButton"))
- },
- shiny::conditionalPanel(
- "output.postAnnoataionEnabled == true",
- ns = ns,
- shiny::uiOutput(outputId = ns("userNameLabel"),
- style = "color:white;font-weight:bold;padding-right:30px")
- ),
- class = "dropdown",
- style = "margin-top: 8px !important; margin-right : 5px !important"
- )
- } else {
- headerContent <- tags$li(
- class = "dropdown",
- style = "margin-top: 8px !important; margin-right : 5px !important"
- )
- }
-
- header <-
- shinydashboard::dashboardHeader(title = "Cohort Diagnostics", headerContent)
-
- sidebarMenu <-
- shinydashboard::sidebarMenu(
- id = ns("tabs"),
- if ("cohort" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Cohort Definition", tabName = "cohortDefinition", icon = shiny::icon("code"))
- },
- if ("includedSourceConcept" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Concepts in Data Source", tabName = "conceptsInDataSource", icon = shiny::icon("table"))
- },
- if ("orphanConcept" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Orphan Concepts", tabName = "orphanConcepts", icon = shiny::icon("notes-medical"))
- },
- if ("cohortCount" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Cohort Counts", tabName = "cohortCounts", icon = shiny::icon("bars"))
- },
- if ("incidenceRate" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Incidence Rate", tabName = "incidenceRate", icon = shiny::icon("plus"))
- },
- if ("temporalCovariateValue" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Time Distributions", tabName = "timeDistribution", icon = shiny::icon("clock"))
- },
- if ("indexEventBreakdown" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Index Event Breakdown", tabName = "indexEventBreakdown", icon = shiny::icon("hospital"))
- },
- if ("visitContext" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Visit Context", tabName = "visitContext", icon = shiny::icon("building"))
- },
- if ("relationship" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Cohort Overlap", tabName = "cohortOverlap", icon = shiny::icon("circle"))
- },
- if ("temporalCovariateValue" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Cohort Characterization", tabName = "cohortCharacterization", icon = shiny::icon("user"))
- },
- if ("temporalCovariateValue" %in% enabledTabs) {
- shinydashboard::menuItem(text = "Compare Characterization", tabName = "compareCohortCharacterization", icon = shiny::icon("users"))
- },
- shinydashboard::menuItem(text = "Meta data", tabName = "databaseInformation", icon = shiny::icon("gear", verify_fa = FALSE)),
- # Conditional dropdown boxes in the side bar ------------------------------------------------------
- uiControls(ns, enabledTabs)
- )
-
- # Side bar code
- sidebar <-
- shinydashboard::dashboardSidebar(sidebarMenu,
- width = NULL,
- collapsed = FALSE
- )
-
- # Body - items in tabs --------------------------------------------------
- bodyTabItems <- shinydashboard::tabItems(
- shinydashboard::tabItem(
- tabName = "about",
- if ("aboutText" %in% enabledTabs) {
- HTML(aboutText)
- }
- ),
- shinydashboard::tabItem(
- tabName = "cohortDefinition",
- cohortDefinitionsView(ns("cohortDefinitions"))
- ),
- shinydashboard::tabItem(
- tabName = "cohortCounts",
- cohortCountsView(ns("cohortCounts")),
- if (showAnnotation) {
- column(
- 12,
- tags$br(),
- annotationUi(ns("cohortCountsAnnotation"))
- )
- }
- ),
- shinydashboard::tabItem(
- tabName = "incidenceRate",
- incidenceRatesView(ns("incidenceRates"))
- ),
- shinydashboard::tabItem(
- tabName = "timeDistribution",
- timeDistributionsView(ns("timeDistributions")),
- if (showAnnotation) {
- column(
- 12,
- tags$br(),
- annotationUi(ns("timeDistributionAnnotation"))
- )
- }
-
- ),
- shinydashboard::tabItem(
- tabName = "conceptsInDataSource",
- conceptsInDataSourceView(ns("conceptsInDataSource")),
- if (showAnnotation) {
- column(
- 12,
- tags$br(),
- annotationUi(ns("conceptsInDataSourceAnnotation"))
- )
- }
- ),
- shinydashboard::tabItem(
- tabName = "orphanConcepts",
- orpahanConceptsView(ns("orphanConcepts")),
- if (showAnnotation) {
- column(
- 12,
- tags$br(),
- annotationUi(ns("orphanConceptsAnnotation"))
- )
- }
- ),
- shinydashboard::tabItem(
- tabName = "indexEventBreakdown",
- indexEventBreakdownView(ns("indexEvents")),
- if (showAnnotation) {
- column(
- 12,
- tags$br(),
- annotationUi(ns("indexEventBreakdownAnnotation"))
- )
- }
- ),
- shinydashboard::tabItem(
- tabName = "visitContext",
- visitContextView(ns("visitContext")),
- if (showAnnotation) {
- column(
- 12,
- tags$br(),
- annotationUi(ns("visitContextAnnotation"))
- )
- }
- ),
- shinydashboard::tabItem(
- tabName = "cohortOverlap",
- cohortOverlapView(ns("cohortOverlap")),
- if (showAnnotation) {
- column(
- 12,
- tags$br(),
- annotationUi(ns("cohortOverlapAnnotation"))
- )
- }
- ),
- shinydashboard::tabItem(
- tabName = "cohortCharacterization",
- characterizationView(ns("characterization")),
- if (showAnnotation) {
- column(
- 12,
- tags$br(),
- annotationUi(ns("cohortCharacterization"))
- )
- }
- ),
- shinydashboard::tabItem(
- tabName = "compareCohortCharacterization",
- compareCohortCharacterizationView(ns("compareCohortCharacterization")),
- if (showAnnotation) {
- column(
- 12,
- tags$br(),
- annotationUi(ns("compareTemporalCharacterizationAnnotation"))
- )
- }
- ),
- shinydashboard::tabItem(
- tabName = "databaseInformation",
- databaseInformationView(ns("databaseInformation")),
- )
- )
-
-
- # body
- body <- shinydashboard::dashboardBody(
- bodyTabItems,
- htmltools::withTags(
- div(
- style = "margin-left : 0px",
- h6(appInformationText)
- )
- )
- )
-
- # main
- ui <- shinydashboard::dashboardPage(
- tags$head(tags$style(HTML(
- "
- th, td {
- padding-right: 10px;
- }
-
- "
- ))),
- header = header,
- sidebar = sidebar,
- body = body
- )
-
- return(ui)
-}
-
-tabularUi <- function(enabledTabs,
- id = "DiagnosticsExplorer") {
- ns <- shiny::NS(id)
- ui <-
- shiny::fluidPage(
- shinydashboard::box(uiControls(ns, enabledTabs), width = 12),
- shiny::tabsetPanel(
- # shiny::tabPanel("About", shiny::HTML(aboutText)),
- if ("cohort" %in% enabledTabs) {
- shiny::tabPanel("Cohort Definitions", cohortDefinitionsView(ns("cohortDefinitions")), value = "cohortDefinition")
- },
- if ("includedSourceConcept" %in% enabledTabs) {
- shiny::tabPanel("Concepts in Data Source", conceptsInDataSourceView(ns("conceptsInDataSource")), value = "conceptsInDataSource")
- },
- if ("orphanConcept" %in% enabledTabs) {
- shiny::tabPanel("Orphan Concepts", orpahanConceptsView(ns("orphanConcepts")), value = "orphanConcept")
- },
- if ("cohortCount" %in% enabledTabs) {
- shiny::tabPanel("Cohort counts", cohortCountsView(ns("cohortCounts")), value = "cohortCounts")
- },
- if ("incidenceRate" %in% enabledTabs) {
- shiny::tabPanel("Incidence Rates", incidenceRatesView(ns("incidenceRates")), value = "incidenceRate")
- },
- if ("indexEventBreakdown" %in% enabledTabs) {
- shiny::tabPanel("Index Events", indexEventBreakdownView(ns("indexEvents")), value = "indexEventBreakdown")
- },
- if ("visitContext" %in% enabledTabs) {
- shiny::tabPanel("Visit Context", visitContextView(ns("visitContext")), value = "visitContext")
- },
- if ("relationship" %in% enabledTabs) {
- shiny::tabPanel("Cohort Overlap", cohortOverlapView(ns("cohortOverlap")), value = "cohortOverlap")
- },
- if ("temporalCovariateValue" %in% enabledTabs) {
- shiny::tabPanel("Time Distributions", timeDistributionsView(ns("timeDistributions")), value = "timeDistribution")
- },
- if ("temporalCovariateValue" %in% enabledTabs) {
- shiny::tabPanel("Characterization", characterizationView(ns("characterization")), value = "characterization")
- },
- if ("temporalCovariateValue" %in% enabledTabs) {
- shiny::tabPanel("Compare Characterization", compareCohortCharacterizationView(ns("compareCohortCharacterization")),
- value = "compareTemporalCharacterization")
- },
- shiny::tabPanel("Database Information", databaseInformationView(ns("databaseInformation")),
- value = "databaseInformation"),
- type = "pills",
- id = ns("tabs")
- ),
- width = "100%"
- )
- return(ui)
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/DiagnosticsExplorerModule.R b/inst/shiny/DiagnosticsExplorer/R/DiagnosticsExplorerModule.R
deleted file mode 100644
index cebe87866..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/DiagnosticsExplorerModule.R
+++ /dev/null
@@ -1,506 +0,0 @@
-diagnosticsExplorerModule <- function(id = "DiagnosticsExplorer",
- envir = .GlobalEnv,
- dataSource = envir$dataSource,
- databaseTable = envir$database,
- cohortTable = envir$cohort,
- cohortCountTable = envir$cohortCount,
- enableAnnotation = envir$enableAnnotation,
- enableAuthorization = envir$enableAuthorization,
- enabledTabs = envir$enabledTabs,
- conceptSets = envir$conceptSets,
- userCredentials = envir$userCredentials,
- activeUser = envir$activeUser) {
- ns <- shiny::NS(id)
- shiny::moduleServer(id, function(input, output, session) {
-
- activeLoggedInUser <- reactiveVal(activeUser)
- if (enableAnnotation & nrow(userCredentials) > 0) {
- shiny::observeEvent(
- eventExpr = input$annotationUserPopUp,
- handlerExpr = {
- shiny::showModal(
- shiny::modalDialog(
- title = "Annotate",
- easyClose = TRUE,
- size = "s",
- footer = tagList(
- shiny::actionButton(inputId = ns("login"), label = "Login"),
- shiny::modalButton("Cancel")
- ),
- tags$div(
- shiny::textInput(
- inputId = ns("userName"),
- label = "Username",
- width = NULL,
- value = if (enableAuthorization) {
- ""
- } else {
- "annonymous"
- }
- ),
- if (enableAuthorization) {
- shiny::passwordInput(
- inputId = ns("password"),
- label = "Password",
- width = NULL
- )
- },
- )
- )
- )
- }
- )
-
- shiny::observeEvent(
- eventExpr = input$login,
- handlerExpr = {
- tryCatch(
- expr = {
- if (enableAuthorization) {
- if (input$userName == "" || input$password == "") {
- activeLoggedInUser(NULL)
- shiny::showModal(
- shiny::modalDialog(
- title = "Error",
- easyClose = TRUE,
- size = "s",
- fade = TRUE,
- "Please enter both the fields"
- )
- )
- }
- userCredentialsFiltered <- userCredentials %>%
- dplyr::filter(userId == input$userName)
- if (nrow(userCredentialsFiltered) > 0) {
- passwordHash <-
- digest::digest(input$password, algo = "sha512")
- if (passwordHash %in% userCredentialsFiltered$hashCode) {
- activeLoggedInUser(input$userName)
- shiny::removeModal()
- } else {
- activeLoggedInUser(NULL)
- shiny::showModal(
- shiny::modalDialog(
- title = "Error",
- easyClose = TRUE,
- size = "s",
- fade = TRUE,
- "Invalid User"
- )
- )
- }
- } else {
- activeLoggedInUser(NULL)
- shiny::showModal(
- shiny::modalDialog(
- title = "Error",
- easyClose = TRUE,
- size = "s",
- fade = TRUE,
- "Invalid User"
- )
- )
- }
- } else {
- if (input$userName == "") {
- activeLoggedInUser(NULL)
- shiny::showModal(
- shiny::modalDialog(
- title = "Error",
- easyClose = TRUE,
- size = "s",
- fade = TRUE,
- "Please enter the user name."
- )
- )
- } else {
- activeLoggedInUser(input$userName)
- shiny::removeModal()
- }
- }
- },
- error = function() {
- activeLoggedInUser(NULL)
- }
- )
- }
- )
- }
-
- output$userNameLabel <- shiny::renderText({
- if (is.null(activeLoggedInUser())) {
- return("")
- }
- paste(as.character(icon("user")),
- stringr::str_to_title(activeLoggedInUser()))
-
- })
-
- # Display login based on value of active logged in user
- postAnnotaionEnabled <- shiny::reactive(!is.null(activeLoggedInUser()))
- output$postAnnoataionEnabled <- shiny::reactive({
- postAnnotaionEnabled()
- })
-
- output$signInButton <- shiny::renderUI({
- if (enableAuthorization & !postAnnotaionEnabled()) {
- return(
- shiny::actionButton(
- inputId = ns("annotationUserPopUp"),
- label = "Sign in"
- )
- )
- } else {
- return(shiny::span())
- }
- })
-
- outputOptions(output, "postAnnoataionEnabled", suspendWhenHidden = FALSE)
-
- # Reacive: targetCohortId
- targetCohortId <- shiny::reactive({
- return(cohortTable$cohortId[cohortTable$compoundName == input$targetCohort])
- })
-
- # Reacive: cohortIds
- cohortIds <- shiny::reactive({
- cohortTable %>%
- dplyr::filter(compoundName %in% input$cohorts) %>%
- dplyr::select(cohortId) %>%
- dplyr::pull()
- })
-
- selectedConceptSets <- shiny::reactive({
- input$conceptSetsSelected
- })
-
- # conceptSetIds ----
- conceptSetIds <- shiny::reactive(x = {
- conceptSetsFiltered <- conceptSets %>%
- dplyr::filter(conceptSetName %in% selectedConceptSets()) %>%
- dplyr::filter(cohortId %in% targetCohortId()) %>%
- dplyr::select(conceptSetId) %>%
- dplyr::pull() %>%
- unique()
- return(conceptSetsFiltered)
- })
-
- databaseChoices <- databaseTable$databaseId
- names(databaseChoices) <- databaseTable$databaseName
-
- ## ReactiveValue: selectedDatabaseIds ----
- selectedDatabaseIds <- shiny::reactive({
- if (!is.null(input$tabs)) {
- if (input$tabs %in% c(
- "compareCohortCharacterization",
- "compareTemporalCharacterization",
- "temporalCharacterization",
- "databaseInformation"
- )) {
- return(input$database)
- } else {
- return(input$databases)
- }
- }
- })
-
-
- shiny::observe({
- shinyWidgets::updatePickerInput(session = session,
- inputId = "database",
- choices = databaseChoices,
- selected = databaseChoices[[1]],
- )
- shinyWidgets::updatePickerInput(session = session,
- inputId = "databases",
- choices = databaseChoices,
- selected = databaseChoices[[1]],
- )
- })
-
- ## ReactiveValue: selectedTemporalTimeIds ----
- selectedTemporalTimeIds <- reactiveVal(NULL)
- shiny::observeEvent(eventExpr = {
- list(
- input$timeIdChoices_open,
- input$timeIdChoices,
- input$tabs
- )
- }, handlerExpr = {
- if (isFALSE(input$timeIdChoices_open) ||
- !is.null(input$tabs) & !is.null(envir$temporalCharacterizationTimeIdChoices)) {
- selectedTemporalTimeIds(
- envir$temporalCharacterizationTimeIdChoices %>%
- dplyr::filter(temporalChoices %in% input$timeIdChoices) %>%
- dplyr::pull(timeId) %>%
- unique() %>%
- sort()
- )
- }
- })
-
- cohortSubset <- shiny::reactive({
- return(cohortTable %>%
- dplyr::arrange(cohortId))
- })
-
- shiny::observe({
- subset <- cohortSubset()$compoundName
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "targetCohort",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = subset
- )
- })
-
- shiny::observe({
- subset <- cohortSubset()$compoundName
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "cohorts",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = subset,
- selected = c(subset[1], subset[2])
- )
- })
-
-
- inputCohortIds <- shiny::reactive({
- if (input$tabs == "cohortCounts" |
- input$tabs == "cohortOverlap" |
- input$tabs == "incidenceRate" |
- input$tabs == "timeDistribution") {
- subset <- input$cohorts
- } else {
- subset <- input$targetCohort
- }
-
- return(subset)
- })
-
- shiny::observe({
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = paste0("targetCohort", input$tabs),
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = inputCohortIds(),
- selected = inputCohortIds()
- )
- })
-
- shiny::observe({
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = paste0("database", input$tabs),
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = selectedDatabaseIds(),
- selected = selectedDatabaseIds()
- )
- })
-
- shiny::observe({
- subset <- cohortSubset()$compoundName
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "comparatorCohort",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = subset,
- selected = subset[2]
- )
- })
-
- if (enableAnnotation) {
- #--- Annotation modules
- annotationModules <- c("cohortCountsAnnotation",
- "timeDistributionAnnotation",
- "conceptsInDataSourceAnnotation",
- "orphanConceptsAnnotation",
- "inclusionRuleStatsAnnotation",
- "indexEventBreakdownAnnotation",
- "visitContextAnnotation",
- "cohortOverlapAnnotation",
- "cohortCharacterizationAnnotation",
- "temporalCharacterizationAnnotation",
- "compareCohortCharacterizationAnnotation",
- "compareTemporalCharacterizationAnnotation")
-
-
- for (module in annotationModules) {
- annotationModule(id = module,
- dataSource = dataSource,
- activeLoggedInUser = activeLoggedInUser,
- selectedDatabaseIds = selectedDatabaseIds,
- selectedCohortIds = inputCohortIds,
- cohortTable = cohortTable,
- databaseTable = databaseTable,
- postAnnotaionEnabled = postAnnotaionEnabled)
- }
- }
-
- # Characterization (Shared across) -------------------------------------------------
- ## Reactive objects ----
- ### getConceptSetNameForFilter ----
- getConceptSetNameForFilter <- shiny::reactive(x = {
- if (!hasData(targetCohortId()) || !hasData(selectedDatabaseIds())) {
- return(NULL)
- }
-
- jsonExpression <- cohortSubset() %>%
- dplyr::filter(cohortId == targetCohortId()) %>%
- dplyr::select(json)
- jsonExpression <-
- RJSONIO::fromJSON(jsonExpression$json, digits = 23)
- expression <-
- getConceptSetDetailsFromCohortDefinition(cohortDefinitionExpression = jsonExpression)
- if (is.null(expression)) {
- return(NULL)
- }
-
- expression <- expression$conceptSetExpression %>%
- dplyr::select(name)
- return(expression)
- })
-
- shiny::observe({
- subset <- getConceptSetNameForFilter()$name %>%
- sort() %>%
- unique()
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "conceptSetsSelected",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = subset
- )
- })
-
- selectedCohorts <- shiny::reactive({
- cohorts <- cohortSubset() %>%
- dplyr::filter(cohortId %in% cohortIds()) %>%
- dplyr::arrange(cohortId) %>%
- dplyr::select(compoundName)
- return(apply(cohorts, 1, function(x) {
- tags$tr(lapply(x, tags$td))
- }))
- })
-
- selectedCohort <- shiny::reactive({
- return(input$targetCohort)
- })
-
- if ("cohort" %in% enabledTabs) {
- cohortDefinitionsModule(id = "cohortDefinitions",
- dataSource = dataSource,
- cohortDefinitions = cohortSubset,
- cohortTable = cohortTable,
- cohortCount = cohortCountTable,
- databaseTable = databaseTable)
- }
-
- if ("includedSourceConcept" %in% enabledTabs) {
- conceptsInDataSourceModule(id = "conceptsInDataSource",
- dataSource = dataSource,
- selectedCohort = selectedCohort,
- selectedDatabaseIds = selectedDatabaseIds,
- targetCohortId = targetCohortId,
- selectedConceptSets = selectedConceptSets,
- cohortTable = cohortTable,
- databaseTable = databaseTable)
- }
-
- if ("orphanConcept" %in% enabledTabs) {
- orphanConceptsModule("orphanConcepts",
- dataSource = dataSource,
- selectedCohort = selectedCohort,
- selectedDatabaseIds = selectedDatabaseIds,
- targetCohortId = targetCohortId,
- selectedConceptSets = selectedConceptSets,
- conceptSetIds = conceptSetIds)
- }
-
- if ("cohortCount" %in% enabledTabs) {
- cohortCountsModule(id = "cohortCounts",
- dataSource = dataSource,
- cohortTable = cohortTable, # The injection of tables like this should be removed
- databaseTable = databaseTable, # The injection of tables like this should be removed
- selectedCohorts = selectedCohorts,
- selectedDatabaseIds = selectedDatabaseIds,
- cohortIds = cohortIds)
- }
-
- if ("indexEventBreakdown" %in% enabledTabs) {
- indexEventBreakdownModule("indexEvents",
- dataSource = dataSource,
- cohortTable = cohortTable,
- databaseTable = databaseTable,
- selectedCohort = selectedCohort,
- targetCohortId = targetCohortId,
- selectedDatabaseIds = selectedDatabaseIds)
- }
-
- if ("visitContext" %in% enabledTabs) {
- visitContextModule(id = "visitContext",
- dataSource = dataSource,
- selectedCohort = selectedCohort,
- selectedDatabaseIds = selectedDatabaseIds,
- targetCohortId = targetCohortId,
- cohortTable = cohortTable,
- databaseTable = databaseTable)
- }
-
- if ("relationship" %in% enabledTabs) {
- cohortOverlapModule(id = "cohortOverlap",
- dataSource = dataSource,
- selectedCohorts = selectedCohorts,
- selectedDatabaseIds = selectedDatabaseIds,
- targetCohortId = targetCohortId,
- cohortIds = cohortIds,
- cohortTable = cohortTable)
- }
-
- if ("temporalCovariateValue" %in% enabledTabs) {
- timeDistributionsModule(id = "timeDistributions",
- dataSource = dataSource,
- selectedCohorts = selectedCohorts,
- cohortIds = cohortIds,
- selectedDatabaseIds = selectedDatabaseIds,
- cohortTable = cohortTable,
- databaseTable = databaseTable)
-
- characterizationModule(id = "characterization",
- dataSource = dataSource,
- cohortTable = cohortTable,
- databaseTable = databaseTable,
- temporalAnalysisRef = envir$temporalAnalysisRef,
- analysisNameOptions = envir$analysisNameOptions,
- domainIdOptions = envir$domainIdOptions,
- characterizationTimeIdChoices = envir$characterizationTimeIdChoices)
-
- compareCohortCharacterizationModule("compareCohortCharacterization",
- dataSource = dataSource,
- cohortTable = cohortTable,
- databaseTable = databaseTable,
- conceptSets = conceptSets,
- temporalAnalysisRef = envir$temporalAnalysisRef,
- analysisNameOptions = envir$analysisNameOptions,
- domainIdOptions = envir$domainIdOptions,
- temporalChoices = envir$temporalChoices)
- }
-
- if ("incidenceRate" %in% enabledTabs) {
- incidenceRatesModule(id = "incidenceRates",
- dataSource = dataSource,
- selectedCohorts = selectedCohorts,
- cohortIds = cohortIds,
- selectedDatabaseIds = selectedDatabaseIds,
- cohortTable = cohortTable)
- }
-
- databaseInformationModule(id = "databaseInformation",
- dataSource = dataSource,
- selectedDatabaseIds = selectedDatabaseIds,
- databaseMetadata = envir$databaseMetadata)
-
- })
-
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/DisplayFunctions.R b/inst/shiny/DiagnosticsExplorer/R/DisplayFunctions.R
deleted file mode 100644
index bb178cc77..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/DisplayFunctions.R
+++ /dev/null
@@ -1,611 +0,0 @@
-formatDataCellValueInDisplayTable <-
- function(showDataAsPercent = FALSE) {
- if (showDataAsPercent) {
- reactable::JS(
- "function(data) {
- if (isNaN(parseFloat(data.value))) return data.value;
- if (Number.isInteger(data.value) && data.value > 0) return (100 * data.value).toFixed(0).toString().replace(/(\\d)(?=(\\d{3})+(?!\\d))/g, '$1,') + '%';
- if (data.value > 999) return (100 * data.value).toFixed(2).replace(/(\\d)(?=(\\d{3})+(?!\\d))/g, '$1,') + '%';
- if (data.value < 0) return '<' + (Math.abs(data.value) * 100).toFixed(2) + '%';
- return (100 * data.value).toFixed(1) + '%';
- }"
- )
- } else {
- reactable::JS(
- "function(data) {
- if (isNaN(parseFloat(data.value))) return data.value;
- if (Number.isInteger(data.value) && data.value > 0) return data.value.toFixed(0).toString().replace(/(\\d)(?=(\\d{3})+(?!\\d))/g, '$1,');
- if (data.value > 999) return data.value.toFixed(1).toString().replace(/(\\d)(?=(\\d{3})+(?!\\d))/g, '$1,');
- if (data.value < 0) return '<' + Math.abs(data.value.toFixed(3));
- return data.value.toFixed(1);
- }"
- )
- }
- }
-
-copyToClipboardButton <-
- function(toCopyId,
- label = "Copy to clipboard",
- icon = shiny::icon("clipboard"),
- ...) {
- script <- sprintf(
- "
- text = document.getElementById('%s').textContent;
- html = document.getElementById('%s').innerHTML;
- function listener(e) {
- e.clipboardData.setData('text/html', html);
- e.clipboardData.setData('text/plain', text);
- e.preventDefault();
- }
- document.addEventListener('copy', listener);
- document.execCommand('copy');
- document.removeEventListener('copy', listener);
- return false;",
- toCopyId,
- toCopyId
- )
-
- tags$button(
- type = "button",
- class = "btn btn-default action-button",
- onclick = script,
- icon,
- label,
- ...
- )
- }
-
-
-getDisplayTableHeaderCount <-
- function(dataSource,
- cohortIds,
- databaseIds,
- source = "Datasource",
- fields = "Both") {
- if (source == "Datasource") {
- countsForHeader <- getDatabaseCounts(
- dataSource = dataSource,
- databaseIds = databaseIds
- )
- } else if (source == "cohort") {
- countsForHeader <-
- getResultsCohortCounts(
- dataSource = dataSource,
- cohortIds = cohortIds,
- databaseIds = databaseIds
- ) %>%
- dplyr::rename(
- records = cohortEntries,
- persons = cohortSubjects
- )
- }
-
- if (fields %in% c("Persons")) {
- countsForHeader <- countsForHeader %>%
- dplyr::select(-records) %>%
- dplyr::rename(count = persons)
- } else if (fields %in% c("Events", "Records")) {
- countsForHeader <- countsForHeader %>%
- dplyr::select(-persons) %>%
- dplyr::rename(count = records)
- }
- return(countsForHeader)
- }
-
-
-prepDataForDisplay <- function(data,
- keyColumns,
- dataColumns) {
- # ensure the data has required fields
- keyColumns <- c(keyColumns %>% unique())
- dataColumns <- dataColumns %>% unique()
- commonColumns <- intersect(
- colnames(data),
- c(keyColumns, dataColumns, "databaseId", "temporalChoices")
- ) %>% unique()
-
- missingColumns <-
- setdiff(
- x = c(keyColumns, dataColumns) %>% unique(),
- y = colnames(data)
- )
- if (length(missingColumns) > 0 && missingColumns != "") {
- stop(
- paste0(
- "Improper specification for sketch, following fields are missing in data ",
- paste0(missingColumns, collapse = ", ")
- )
- )
- }
- data <- data %>%
- dplyr::select(dplyr::all_of(commonColumns))
-
- if ("databaseId" %in% colnames(data)) {
- data <- data %>%
- dplyr::relocate("databaseId")
- }
- return(data)
-}
-
-pallete <- function(x) {
- cr <- colorRamp(c("white", "#9ccee7"))
- col <- "#ffffff"
- tryCatch({
- if (x > 1.0) {
- x <- 1
- }
-
- col <- rgb(cr(x), maxColorValue = 255)
- }, error = function(...) {
- })
- return(col)
-}
-
-getDisplayTableGroupedByDatabaseId <- function(data,
- cohort,
- databaseTable,
- headerCount = NULL,
- keyColumns,
- dataColumns,
- countLocation,
- maxCount,
- sort = TRUE,
- showDataAsPercent = FALSE,
- excludedColumnFromPercentage = NULL,
- pageSize = 20,
- valueFill = 0,
- selection = NULL,
- isTemporal = FALSE) {
- data <- prepDataForDisplay(
- data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns
- )
-
- data <- data %>%
- tidyr::pivot_longer(
- cols = dplyr::all_of(dataColumns),
- names_to = "type",
- values_to = "valuesData"
- )
-
- data <- data %>%
- dplyr::inner_join(databaseTable %>%
- dplyr::select(databaseId, databaseName),
- by = "databaseId")
-
- if (isTemporal) {
- data <- data %>%
- dplyr::mutate(type = paste0(
- databaseId,
- "-",
- temporalChoices,
- "_sep_",
- type
- ))
- distinctColumnGroups <- data$temporalChoices %>% unique()
- } else {
- data <- data %>%
- dplyr::mutate(type = paste0(
- databaseId,
- "_sep_",
- type
- ))
- distinctColumnGroups <- data$databaseId %>% unique()
- }
-
- data <- data %>%
- tidyr::pivot_wider(
- id_cols = dplyr::all_of(keyColumns),
- names_from = "type",
- values_from = "valuesData"
- )
-
- if (sort) {
- sortByColumns <- colnames(data)
- sortByColumns <-
- sortByColumns[stringr::str_detect(
- string = sortByColumns,
- pattern = paste(dataColumns, collapse = "|")
- )]
- if (length(sortByColumns) > 0) {
- sortByColumns <- sortByColumns[[1]]
- data <- data %>%
- dplyr::arrange(dplyr::desc(dplyr::across(dplyr::all_of(
- sortByColumns
- ))))
- }
- }
-
- dataColumns <-
- colnames(data)[stringr::str_detect(
- string = colnames(data),
- pattern = paste0(keyColumns, collapse = "|"),
- negate = TRUE
- )]
-
- columnDefinitions <- list()
- columnTotalMinWidth <- 0
- columnTotalMaxWidth <- 0
-
- for (i in (1:length(keyColumns))) {
- columnName <- SqlRender::camelCaseToTitleCase(colnames(data)[i])
- displayTableColumnMinMaxWidth <-
- getDisplayTableColumnMinMaxWidth(
- data = data,
- columnName = keyColumns[[i]]
- )
- columnTotalMinWidth <-
- columnTotalMinWidth + displayTableColumnMinMaxWidth$minValue
- columnTotalMaxWidth <-
- columnTotalMaxWidth + displayTableColumnMinMaxWidth$maxValue
- if (class(data[[keyColumns[[i]]]]) == "logical") {
- data[[keyColumns[[i]]]] <- ifelse(data[[keyColumns[[i]]]],
- as.character(icon("check")), ""
- )
- }
-
- colnames(data)[which(names(data) == keyColumns[i])] <-
- columnName
- columnDefinitions[[columnName]] <-
- reactable::colDef(
- name = columnName,
- sortable = sort,
- resizable = TRUE,
- filterable = TRUE,
- show = TRUE,
- minWidth = displayTableColumnMinMaxWidth$minValue,
- maxWidth = displayTableColumnMinMaxWidth$maxValue,
- html = TRUE,
- na = "",
- align = "left"
- )
- }
-
- maxValue <- 0
- if (valueFill == 0) {
- maxValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(data = data, string = dataColumns)
- }
-
- for (i in (1:length(dataColumns))) {
- columnNameWithDatabaseAndCount <-
- stringr::str_split(dataColumns[i], "_sep_")[[1]]
- columnName <- columnNameWithDatabaseAndCount[2]
- displayTableColumnMinMaxWidth <-
- getDisplayTableColumnMinMaxWidth(
- data = data,
- columnName = columnName
- )
- columnTotalMinWidth <- columnTotalMinWidth + 200
- columnTotalMaxWidth <- columnTotalMaxWidth + 200
-
- if (!is.null(headerCount)) {
- if (countLocation == 2) {
- filteredHeaderCount <- headerCount %>%
- dplyr::filter(databaseId == columnNameWithDatabaseAndCount[1])
- columnCount <- filteredHeaderCount[[columnName]]
- columnName <-
- paste0(columnName, " (", scales::comma(columnCount), ")")
- }
- }
- showPercent <- showDataAsPercent
- if (showDataAsPercent &&
- !is.null(excludedColumnFromPercentage)) {
- if (stringr::str_detect(
- tolower(dataColumns[i]),
- tolower(excludedColumnFromPercentage)
- )) {
- showPercent <- FALSE
- }
- }
- columnDefinitions[[dataColumns[i]]] <-
- reactable::colDef(
- name = SqlRender::camelCaseToTitleCase(columnName),
- cell = formatDataCellValueInDisplayTable(showDataAsPercent = showPercent),
- sortable = sort,
- resizable = FALSE,
- filterable = TRUE,
- show = TRUE,
- minWidth = 200,
- maxWidth = 200,
- html = TRUE,
- na = "",
- align = "left",
- style = function(value) {
- color <- '#fff'
- dt <- data[[dataColumns[i]]]
- if (is.list(dt)) {
- dt <- dt %>% unlist()
- }
- if (is.numeric(value) & hasData(dt)) {
- value <- ifelse(is.na(value), min(dt, na.rm = TRUE), value)
- normalized <- (value - min(dt, na.rm = TRUE)) / (max(dt, na.rm = TRUE) - min(dt, na.rm = TRUE))
- color <- pallete(normalized)
- }
- list(background = color)
- }
- )
- }
- if (columnTotalMaxWidth > 1300) {
- columnTotalMaxWidth <- "auto"
- columnTotalMinWidth <- "auto"
- }
-
- dbNameMap <- list()
- for (i in 1:nrow(databaseTable)) {
- dbNameMap[[databaseTable[i,]$databaseId]] <- databaseTable[i,]$databaseName
- }
-
-
- columnGroups <- list()
- for (i in 1:length(distinctColumnGroups)) {
- extractedDataColumns <-
- dataColumns[stringr::str_detect(
- string = dataColumns,
- pattern = stringr::fixed(distinctColumnGroups[i])
- )]
-
- columnName <- dbNameMap[[distinctColumnGroups[i]]]
-
- if (!is.null(headerCount)) {
- if (countLocation == 1) {
- columnName <- headerCount %>%
- dplyr::filter(databaseId == distinctColumnGroups[i]) %>%
- dplyr::mutate(count = paste0(
- databaseName,
- " (",
- scales::comma(count),
- ")"
- )) %>%
- dplyr::pull(count)
- }
- }
- columnGroups[[i]] <-
- reactable::colGroup(
- name = columnName,
- columns = extractedDataColumns
- )
- }
-
- dataTable <-
- reactable::reactable(
- data = data,
- columns = columnDefinitions,
- columnGroups = columnGroups,
- sortable = sort,
- resizable = TRUE,
- filterable = TRUE,
- searchable = TRUE,
- pagination = TRUE,
- showPagination = TRUE,
- showPageInfo = TRUE,
- highlight = TRUE,
- striped = TRUE,
- compact = TRUE,
- wrap = FALSE,
- showSortIcon = sort,
- showSortable = sort,
- fullWidth = TRUE,
- bordered = TRUE,
- showPageSizeOptions = TRUE,
- pageSizeOptions = c(10, 20, 50, 100, 1000),
- defaultPageSize = pageSize,
- selection = selection,
- onClick = "select",
- style = list(maxWidth = columnTotalMaxWidth, minWidth = columnTotalMinWidth),
- theme = reactable::reactableTheme(
- rowSelectedStyle = list(backgroundColor = "#eee", boxShadow = "inset 2px 0 0 0 #ffa62d")
- )
- )
- return(dataTable)
-}
-
-
-getDisplayTableSimple <- function(data,
- keyColumns,
- dataColumns,
- selection = NULL,
- showDataAsPercent = FALSE,
- defaultSelected = NULL,
- databaseTable = NULL,
- pageSize = 20) {
- data <- prepDataForDisplay(
- data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns
- )
-
- columnDefinitions <- list()
- for (i in (1:length(keyColumns))) {
- columnName <- SqlRender::camelCaseToTitleCase(keyColumns[i])
-
- displayTableColumnMinMaxWidth <-
- getDisplayTableColumnMinMaxWidth(
- data = data,
- columnName = keyColumns[[i]]
- )
-
- colnames(data)[which(names(data) == keyColumns[i])] <-
- columnName
-
- columnDefinitions[[columnName]] <-
- reactable::colDef(
- name = columnName,
- cell = if ("logical" %in% class(data[[columnName]])) {
- function(value) {
- if (value) {
- "\u2714\ufe0f"
- } else {
- "\u274C"
- }
- }
- },
- minWidth = displayTableColumnMinMaxWidth$minValue,
- maxWidth = displayTableColumnMinMaxWidth$maxValue,
- sortable = TRUE,
- resizable = TRUE,
- filterable = TRUE,
- show = TRUE,
- html = TRUE,
- na = "",
- align = "left"
- )
- }
-
- if (hasData(dataColumns)) {
- maxValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(data = data, string = dataColumns)
-
- for (i in (1:length(dataColumns))) {
- columnName <- SqlRender::camelCaseToTitleCase(dataColumns[i])
- colnames(data)[which(names(data) == dataColumns[i])] <- columnName
- columnDefinitions[[columnName]] <- reactable::colDef(
- name = columnName,
- cell = formatDataCellValueInDisplayTable(showDataAsPercent = showDataAsPercent),
- sortable = TRUE,
- resizable = FALSE,
- filterable = TRUE,
- show = TRUE,
- html = TRUE,
- na = "",
- align = "left",
- style = function(value) {
- color <- '#fff'
- if (is.numeric(value) & hasData(data[[columnName]])) {
- value <- ifelse(is.na(value), min(data[[columnName]], na.rm = TRUE), value)
- normalized <- (value - min(data[[columnName]], na.rm = TRUE)) / (maxValue - min(data[[columnName]], na.rm = TRUE))
- color <- pallete(normalized)
- }
- list(background = color)
- }
- )
- }
- }
-
- dataTable <- reactable::reactable(
- data = data,
- columns = columnDefinitions,
- sortable = TRUE,
- resizable = TRUE,
- filterable = TRUE,
- searchable = TRUE,
- pagination = TRUE,
- showPagination = TRUE,
- showPageInfo = TRUE,
- highlight = TRUE,
- striped = TRUE,
- compact = TRUE,
- wrap = FALSE,
- showSortIcon = TRUE,
- showSortable = TRUE,
- fullWidth = TRUE,
- bordered = TRUE,
- selection = selection,
- defaultSelected = defaultSelected,
- onClick = "select",
- showPageSizeOptions = TRUE,
- pageSizeOptions = c(10, 20, 50, 100, 1000),
- defaultPageSize = pageSize,
- theme = reactable::reactableTheme(
- rowSelectedStyle = list(backgroundColor = "#eee", boxShadow = "inset 2px 0 0 0 #ffa62d")
- )
- )
- return(dataTable)
-}
-
-# This is bad
-getMaxValueForStringMatchedColumnsInDataFrame <-
- function(data, string) {
- if (!hasData(data)) {
- return(0)
- }
- string <- intersect(
- string,
- colnames(data)
- )
- data <- data %>%
- dplyr::select(dplyr::all_of(string)) %>%
- tidyr::pivot_longer(values_to = "value", cols = dplyr::everything()) %>%
- dplyr::filter(!is.na(value)) %>%
- dplyr::pull(value)
-
- if (is.list(data)) {
- data <- data %>% unlist()
- }
-
- if (!hasData(data)) {
- return(0)
- } else {
- return(max(data, na.rm = TRUE))
- }
- }
-
-
-getDisplayTableColumnMinMaxWidth <- function(data,
- columnName,
- pixelMultipler = 10,
- # approximate number of pixels per character
- padPixel = 25,
- maxWidth = NULL,
- minWidth = 10 * pixelMultipler) {
- columnNameFormatted <- SqlRender::camelCaseToTitleCase(columnName)
-
- if ("character" %in% class(data[[columnName]])) {
- maxWidth <- (max(stringr::str_length(
- c(
- stringr::str_replace_na(
- string = data[[columnName]],
- replacement = ""
- ),
- columnNameFormatted
- )
- )) * pixelMultipler) + padPixel # to pad for table icon like sort
- minWidth <-
- min(
- stringr::str_length(columnNameFormatted) * pixelMultipler,
- maxWidth
- ) + padPixel
- }
-
- if ("logical" %in% class(data[[columnName]])) {
- maxWidth <-
- max(stringr::str_length(columnNameFormatted) * pixelMultipler,
- na.rm = TRUE
- ) + padPixel
- minWidth <-
- (stringr::str_length(columnNameFormatted) * pixelMultipler) + padPixel
- }
-
- if ("numeric" %in% class(data[[columnName]])) {
- maxWidth <-
- (max(stringr::str_length(
- c(
- as.character(data[[columnName]]),
- columnNameFormatted
- )
- ), na.rm = TRUE) * pixelMultipler) + padPixel # to pad for table icon like sort
- minWidth <-
- min(stringr::str_length(columnNameFormatted) * pixelMultipler,
- maxWidth,
- na.rm = TRUE
- ) + padPixel
- }
-
- data <- list(
- minValue = minWidth,
- maxValue = maxWidth
- )
- return(data)
-}
-
-
-csvDownloadButton <- function(ns,
- outputTableId,
- buttonText = "Download CSV (filtered)") {
-
- shiny::tagList(
- shiny::tags$br(),
- shiny::tags$button(buttonText,
- onclick = paste0("Reactable.downloadDataCSV('", ns(outputTableId), "')")))
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/IncidenceRatesModule.R b/inst/shiny/DiagnosticsExplorer/R/IncidenceRatesModule.R
deleted file mode 100644
index 13b0fd4b2..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/IncidenceRatesModule.R
+++ /dev/null
@@ -1,679 +0,0 @@
-plotIncidenceRate <- function(data,
- cohortTable = NULL,
- stratifyByAgeGroup = TRUE,
- stratifyByGender = TRUE,
- stratifyByCalendarYear = TRUE,
- yscaleFixed = FALSE) {
- errorMessage <- checkmate::makeAssertCollection()
- checkmate::assertTibble(
- x = data,
- any.missing = TRUE,
- min.rows = 1,
- min.cols = 5,
- null.ok = FALSE,
- add = errorMessage
- )
- checkmate::assertLogical(
- x = stratifyByAgeGroup,
- any.missing = FALSE,
- min.len = 1,
- max.len = 1,
- null.ok = FALSE,
- add = errorMessage
- )
- checkmate::assertLogical(
- x = stratifyByGender,
- any.missing = FALSE,
- min.len = 1,
- max.len = 1,
- null.ok = FALSE,
- add = errorMessage
- )
- checkmate::assertLogical(
- x = stratifyByCalendarYear,
- any.missing = FALSE,
- min.len = 1,
- max.len = 1,
- null.ok = FALSE,
- add = errorMessage
- )
- checkmate::assertLogical(
- x = yscaleFixed,
- any.missing = FALSE,
- min.len = 1,
- max.len = 1,
- null.ok = FALSE,
- add = errorMessage
- )
- checkmate::assertDouble(
- x = data$incidenceRate,
- lower = 0,
- any.missing = FALSE,
- null.ok = FALSE,
- min.len = 1,
- add = errorMessage
- )
- checkmate::reportAssertions(collection = errorMessage)
- checkmate::assertDouble(
- x = data$incidenceRate,
- lower = 0,
- any.missing = FALSE,
- null.ok = FALSE,
- min.len = 1,
- add = errorMessage
- )
- checkmate::reportAssertions(collection = errorMessage)
-
- cohortNames <- cohortTable %>% dplyr::select(cohortId,
- cohortName)
-
- plotData <- data %>%
- dplyr::inner_join(cohortNames, by = "cohortId",) %>%
- addShortName(cohortTable) %>%
- dplyr::mutate(incidenceRate = round(incidenceRate, digits = 3))
- plotData <- plotData %>%
- dplyr::mutate(
- strataGender = !is.na(gender),
- strataAgeGroup = !is.na(ageGroup),
- strataCalendarYear = !is.na(calendarYear)
- ) %>%
- dplyr::filter(
- strataGender %in% !!stratifyByGender &
- strataAgeGroup %in% !!stratifyByAgeGroup &
- strataCalendarYear %in% !!stratifyByCalendarYear
- ) %>%
- dplyr::select(-dplyr::starts_with("strata"))
-
- aesthetics <- list(y = "incidenceRate")
- if (stratifyByCalendarYear) {
- aesthetics$x <- "calendarYear"
- xLabel <- "Calender year"
- showX <- TRUE
- if (stratifyByGender) {
- aesthetics$group <- "gender"
- aesthetics$color <- "gender"
- }
- plotType <- "line"
- } else {
- xLabel <- ""
- if (stratifyByGender) {
- aesthetics$x <- "gender"
- aesthetics$color <- "gender"
- aesthetics$fill <- "gender"
- showX <- TRUE
- } else if (stratifyByAgeGroup) {
- aesthetics$x <- "ageGroup"
- showX <- TRUE
- } else {
- aesthetics$x <- 1
- showX <- FALSE
- }
- plotType <- "bar"
- }
-
-
- sortShortName <- plotData %>%
- dplyr::select(shortName) %>%
- dplyr::distinct() %>%
- dplyr::arrange(as.integer(sub(
- pattern = "^C", "", x = shortName
- )))
-
- plotData <- plotData %>%
- dplyr::arrange(
- shortName = factor(shortName, levels = sortShortName$shortName),
- shortName
- )
-
-
- plotData$shortName <- factor(plotData$shortName,
- levels = sortShortName$shortName)
-
- if (stratifyByAgeGroup) {
- sortAgeGroup <- plotData %>%
- dplyr::select(ageGroup) %>%
- dplyr::distinct() %>%
- dplyr::arrange(as.integer(sub(
- pattern = "-.+$", "", x = ageGroup
- )))
-
- plotData <- plotData %>%
- dplyr::arrange(
- ageGroup = factor(ageGroup, levels = sortAgeGroup$ageGroup),
- ageGroup
- )
-
- plotData$ageGroup <- factor(plotData$ageGroup,
- levels = sortAgeGroup$ageGroup
- )
- }
-
- plotData$tooltip <- c(
- paste0(
- plotData$cohortName,
- "\n",
- plotData$databaseName,
- "\nIncidence Rate = ",
- scales::comma(plotData$incidenceRate, accuracy = 0.01),
- "/per 1k PY",
- "\nIncidence Proportion = ",
- scales::percent(plotData$cohortCount / plotData$cohortSubjects, accuracy = 0.1),
- "\nPerson years = ",
- scales::comma(plotData$personYears, accuracy = 0.01),
- "\nCohort count = ",
- scales::comma(plotData$cohortSubjects, accuracy = 1),
- "\nCount = ",
- paste0(scales::comma(plotData$cohortCount, accuracy = 1))
- )
- )
-
- if (stratifyByAgeGroup) {
- plotData$tooltip <-
- c(paste0(plotData$tooltip, "\nAge Group = ", plotData$ageGroup))
- }
-
- if (stratifyByGender) {
- plotData$tooltip <-
- c(paste0(plotData$tooltip, "\nSex = ", plotData$gender))
- }
-
- if (stratifyByCalendarYear) {
- plotData$tooltip <-
- c(paste0(plotData$tooltip, "\nYear = ", plotData$calendarYear))
- }
-
- if (stratifyByGender) {
- # Make sure colors are consistent, no matter which genders are included:
- genders <- c("Female", "Male", "No matching concept")
- # Code used to generate palette:
- # writeLines(paste(RColorBrewer::brewer.pal(n = 2, name = "Dark2"), collapse = "\", \""))
- colors <- c("#D95F02", "#1B9E77", "#444444")
- colors <- colors[genders %in% unique(plotData$gender)]
- plotData$gender <- factor(plotData$gender, levels = genders)
- }
-
-
- plot <-
- ggplot2::ggplot(data = plotData, do.call(ggplot2::aes_string, aesthetics)) +
- ggplot2::xlab(xLabel) +
- ggplot2::ylab("Incidence Rate (/1,000 person years)") +
- ggplot2::scale_y_continuous(expand = c(0, 0))
-
- if (stratifyByCalendarYear) {
- distinctCalenderYear <- plotData$calendarYear %>%
- unique() %>%
- sort()
- if (all(!is.na(distinctCalenderYear))) {
- if (length(distinctCalenderYear) >= 8) {
- plot <-
- plot + ggplot2::scale_x_continuous(n.breaks = 8, labels = round)
- } else {
- plot <-
- plot + ggplot2::scale_x_continuous(breaks = distinctCalenderYear)
- }
- }
- }
-
-
- plot <- plot + ggplot2::theme(
- legend.position = "top",
- legend.title = ggplot2::element_blank(),
- axis.text.x = if (showX) {
- ggplot2::element_text(angle = 90, vjust = 0.5)
- } else {
- ggplot2::element_blank()
- }
- )
-
- if (plotType == "line") {
- plot <- plot +
- ggiraph::geom_line_interactive(ggplot2::aes(), size = 1, alpha = 0.6) +
- ggiraph::geom_point_interactive(ggplot2::aes(tooltip = tooltip),
- size = 2,
- alpha = 0.6
- )
- } else {
- plot <-
- plot + ggiraph::geom_col_interactive(ggplot2::aes(tooltip = tooltip), alpha = 0.6)
- }
- if (stratifyByGender) {
- plot <- plot + ggplot2::scale_color_manual(values = colors)
- plot <- plot + ggplot2::scale_fill_manual(values = colors)
- }
- # databaseId field only present when called in Shiny app:
- if (!is.null(data$databaseId) && length(data$databaseId) > 1) {
- if (yscaleFixed) {
- scales <- "fixed"
- } else {
- scales <- "free_y"
- }
- if (stratifyByGender | stratifyByCalendarYear) {
- if (stratifyByAgeGroup) {
- plot <-
- plot + ggh4x::facet_nested(databaseName + shortName ~ plotData$ageGroup, scales = scales)
- } else {
- plot <-
- plot + ggh4x::facet_nested(databaseName + shortName ~ ., scales = scales)
- }
- } else {
- plot <-
- plot + ggh4x::facet_nested(databaseName + shortName ~ ., scales = scales)
- }
- # spacing <- rep(c(1, rep(0.5, length(unique(plotData$shortName)) - 1)), length(unique(plotData$databaseId)))[-1]
- spacing <- plotData %>%
- dplyr::distinct(databaseId, shortName) %>%
- dplyr::arrange(databaseId) %>%
- dplyr::group_by(databaseId) %>%
- dplyr::summarise(count = dplyr::n(), .groups = "keep") %>%
- dplyr::ungroup()
- spacing <-
- unlist(sapply(spacing$count, function(x) {
- c(1, rep(0.5, x - 1))
- }))[-1]
-
- if (length(spacing) > 0) {
- plot <-
- plot + ggplot2::theme(
- panel.spacing.y = ggplot2::unit(spacing, "lines"),
- strip.background = ggplot2::element_blank()
- )
- } else {
- plot <-
- plot + ggplot2::theme(strip.background = ggplot2::element_blank())
- }
- } else {
- if (stratifyByAgeGroup) {
- plot <- plot + ggplot2::facet_grid(~ageGroup)
- }
- }
- height <-
- 1.5 + 1 * nrow(dplyr::distinct(plotData, databaseId, shortName))
- plot <- ggiraph::girafe(
- ggobj = plot,
- options = list(
- ggiraph::opts_sizing(width = .7),
- ggiraph::opts_zoom(max = 5)
- ),
- width_svg = 15,
- height_svg = height
- )
- return(plot)
-}
-
-incidenceRatesView <- function(id) {
- ns <- shiny::NS(id)
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Incidence Rates",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "incidenceRate.html"))
- ),
- shinydashboard::box(
- status = "warning",
- width = "100%",
- tags$div(
- style = "max-height: 100px; overflow-y: auto",
- shiny::uiOutput(outputId = ns("selectedCohorts"))
- )
- ),
- shinydashboard::box(
- width = NULL,
- status = "primary",
-
- shiny::fluidRow(
- shiny::column(
- width = 4,
- shiny::checkboxGroupInput(
- inputId = ns("irStratification"),
- label = "Stratify by",
- choices = c("Age", "Sex", "Calendar Year"),
- selected = c("Age", "Sex", "Calendar Year"),
- inline = TRUE
- )
- ),
- shiny::column(
- width = 3,
- tags$br(),
- shiny::checkboxInput(
- inputId = ns("irYscaleFixed"),
- label = "Use same y-scale across databases"),
- ),
- shiny::column(
- width = 5,
- shiny::conditionalPanel(
- condition = "input.irYscaleFixed",
- ns = ns,
- shiny::sliderInput(
- inputId = ns("YscaleMinAndMax"),
- label = "Limit y-scale range to:",
- min = c(0),
- max = c(0),
- value = c(0, 0),
- dragRange = TRUE, width = 400,
- step = 1,
- sep = "",
- )
- )
- )
- ),
- shiny::fluidRow(
- shiny::conditionalPanel(
- condition = "input.irStratification.indexOf('Age') > -1",
- ns = ns,
- shiny::column(
- width = 6,
- shinyWidgets::pickerInput(
- inputId = ns("incidenceRateAgeFilter"),
- label = "Filter By Age",
- choices = c("All"),
- selected = c("All"),
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- dropupAuto = TRUE,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- )
- ),
- shiny::conditionalPanel(
- condition = "input.irStratification.indexOf('Sex') > -1",
- ns = ns,
- shiny::column(
- width = 6,
- shinyWidgets::pickerInput(
- inputId = ns("incidenceRateGenderFilter"),
- label = "Filter By Sex",
- choices = c("All"),
- selected = c("All"),
- multiple = TRUE,
- choicesOpt = list(style = rep_len("color: black;", 999)),
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- dropupAuto = TRUE,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- )
- )
- ),
-
- shiny::fluidRow(
- shiny::column(
- width = 3,
- shiny::numericInput(
- inputId = ns("minPersonYear"),
- label = "Minimum person years",
- value = 1000,
- min = 0
- )
- ),
- shiny::column(
- width = 3,
- shiny::numericInput(
- inputId = ns("minSubjetCount"),
- label = "Minimum subject count",
- value = NULL
- )
- ),
- shiny::column(
- width = 6,
- shiny::conditionalPanel(
- condition = "input.irStratification.indexOf('Calendar Year') > -1",
- ns = ns,
- shiny::sliderInput(
- inputId = ns("incidenceRateCalenderFilter"),
- label = "Filter By Calender Year",
- min = c(0),
- max = c(0),
- value = c(0, 0),
- dragRange = TRUE,
- pre = "Year ",
- step = 1,
- sep = ""
- )
- )
- )
- ),
- shiny::actionButton(inputId = ns("generatePlot"), label = "Generate Plot")
- ),
- shiny::conditionalPanel(
- ns = ns,
- condition = "input.generatePlot > 0",
- shinydashboard::box(
- width = NULL,
- shiny::htmlOutput(outputId = ns("hoverInfoIr")),
- shinycssloaders::withSpinner(
- ggiraph::ggiraphOutput(
- outputId = ns("incidenceRatePlot"),
- width = "100%",
- height = "100%"
- )
- )
- )
- )
- )
-}
-
-incidenceRatesModule <- function(id,
- dataSource,
- selectedCohorts,
- selectedDatabaseIds,
- cohortIds,
- cohortTable) {
- ns <- shiny::NS(id)
- shiny::moduleServer(id, function(input, output, session) {
- irRanges <- getIncidenceRateRanges(dataSource)
- output$selectedCohorts <- shiny::renderUI({ selectedCohorts() })
-
- # Incidence rate ---------------------------
-
- incidenceRateData <- reactive({
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- validate(need(length(cohortIds()) > 0, "No cohorts chosen"))
- stratifyByAge <- "Age" %in% input$irStratification
- stratifyByGender <- "Sex" %in% input$irStratification
- stratifyByCalendarYear <-
- "Calendar Year" %in% input$irStratification
- if (length(cohortIds()) > 0) {
- data <- getIncidenceRateResult(
- dataSource = dataSource,
- cohortIds = cohortIds(),
- databaseIds = selectedDatabaseIds(),
- stratifyByGender = stratifyByGender,
- stratifyByAgeGroup = stratifyByAge,
- stratifyByCalendarYear = stratifyByCalendarYear,
- minPersonYears = input$minPersonYear,
- minSubjectCount = input$minSubjetCount
- ) %>%
- dplyr::mutate(incidenceRate = dplyr::case_when(
- incidenceRate < 0 ~ 0,
- TRUE ~ incidenceRate
- ))
- } else {
- data <- NULL
- }
- return(data)
- })
-
- shiny::observe({
- ageFilter <- irRanges$ageGroups %>%
- dplyr::filter(ageGroup != " ", ageGroup != "NA", !is.na(ageGroup)) %>%
- dplyr::distinct() %>%
- dplyr::arrange(as.integer(sub(
- pattern = "-.+$", "", x = ageGroup
- )))
-
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "incidenceRateAgeFilter",
- selected = ageFilter$ageGroup,
- choices = ageFilter$ageGroup,
- choicesOpt = list(style = rep_len("color: black;", 999))
- )
-
- })
-
- shiny::observe({
- genderFilter <- irRanges$gender %>%
- dplyr::select(gender) %>%
- dplyr::filter(
- gender != "NA",
- gender != " ",
- !is.na(gender),
- !is.null(gender)
- ) %>%
- dplyr::distinct() %>%
- dplyr::arrange(gender)
-
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "incidenceRateGenderFilter",
- choicesOpt = list(style = rep_len("color: black;", 999)),
- choices = genderFilter$gender,
- selected = genderFilter$gender
- )
-
- })
-
- shiny::observe({
- calenderFilter <- irRanges$calendarYear %>%
- dplyr::select(calendarYear) %>%
- dplyr::filter(
- calendarYear != " ",
- calendarYear != "NA",
- !is.na(calendarYear)
- ) %>%
- dplyr::distinct(calendarYear) %>%
- dplyr::arrange(calendarYear)
-
- minValue <- min(calenderFilter$calendarYear)
-
- maxValue <- max(calenderFilter$calendarYear)
-
- shiny::updateSliderInput(
- session = session,
- inputId = "incidenceRateCalenderFilter",
- min = minValue,
- max = maxValue,
- value = c(2010, maxValue)
- )
- })
-
- shiny::observe({
- minIncidenceRateValue <- round(min(irRanges$incidenceRate$minIr), digits = 2)
- maxIncidenceRateValue <- round(max(irRanges$incidenceRate$maxIr), digits = 2)
- shiny::updateSliderInput(
- session = session,
- inputId = "YscaleMinAndMax",
- min = 0,
- max = maxIncidenceRateValue,
- value = c(minIncidenceRateValue, maxIncidenceRateValue),
- step = round((maxIncidenceRateValue - minIncidenceRateValue) / 5, digits = 2)
- )
- })
-
- incidenceRateCalenderFilter <- shiny::reactive({
- calenderFilter <- incidenceRateData() %>%
- dplyr::select(calendarYear) %>%
- dplyr::filter(
- calendarYear != "NA",
- !is.na(calendarYear)
- ) %>%
- dplyr::distinct(calendarYear) %>%
- dplyr::arrange(calendarYear)
- calenderFilter <-
- calenderFilter[calenderFilter$calendarYear >= input$incidenceRateCalenderFilter[1] &
- calenderFilter$calendarYear <= input$incidenceRateCalenderFilter[2], , drop = FALSE] %>%
- dplyr::pull(calendarYear)
- return(calenderFilter)
- })
-
-
- incidenceRateYScaleFilter <- shiny::reactive({
- incidenceRateFilter <- incidenceRateData() %>%
- dplyr::select(incidenceRate) %>%
- dplyr::filter(
- incidenceRate != "NA",
- !is.na(incidenceRate)
- ) %>%
- dplyr::distinct(incidenceRate) %>%
- dplyr::arrange(incidenceRate)
- incidenceRateFilter <-
- incidenceRateFilter[incidenceRateFilter$incidenceRate >= input$YscaleMinAndMax[1] &
- incidenceRateFilter$incidenceRate <= input$YscaleMinAndMax[2], , drop = FALSE] %>%
- dplyr::pull(incidenceRate)
- return(incidenceRateFilter)
- })
-
- getIrPlot <- shiny::eventReactive(input$generatePlot, {
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- validate(need(length(cohortIds()) > 0, "No cohorts chosen"))
- stratifyByAge <- "Age" %in% input$irStratification
- stratifyByGender <- "Sex" %in% input$irStratification
- stratifyByCalendarYear <-
- "Calendar Year" %in% input$irStratification
- shiny::withProgress(
- message = paste(
- "Building incidence rate plot data for ",
- length(cohortIds()),
- " cohorts and ",
- length(selectedDatabaseIds()),
- " databases"
- ),
- {
- data <- incidenceRateData()
-
- validate(need(all(!is.null(data), nrow(data) > 0), paste0("No data for this combination")))
-
- if (stratifyByAge && !"All" %in% input$incidenceRateAgeFilter) {
- data <- data %>%
- dplyr::filter(ageGroup %in% input$incidenceRateAgeFilter)
- }
- if (stratifyByGender &&
- !"All" %in% input$incidenceRateGenderFilter) {
- data <- data %>%
- dplyr::filter(gender %in% input$incidenceRateGenderFilter)
- }
- if (stratifyByCalendarYear) {
- data <- data %>%
- dplyr::filter(calendarYear %in% incidenceRateCalenderFilter())
- }
- if (input$irYscaleFixed) {
- data <- data %>%
- dplyr::filter(incidenceRate %in% incidenceRateYScaleFilter())
- }
- if (all(!is.null(data), nrow(data) > 0)) {
- plot <- plotIncidenceRate(
- data = data,
- cohortTable = cohortTable,
- stratifyByAgeGroup = stratifyByAge,
- stratifyByGender = stratifyByGender,
- stratifyByCalendarYear = stratifyByCalendarYear,
- yscaleFixed = input$irYscaleFixed
- )
- return(plot)
- }
- },
- detail = "Please Wait"
- )
-
- })
-
- output$incidenceRatePlot <- ggiraph::renderggiraph(expr = {
- getIrPlot()
- })
-
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/InclusionRulesModule.R b/inst/shiny/DiagnosticsExplorer/R/InclusionRulesModule.R
deleted file mode 100644
index 2df211ba0..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/InclusionRulesModule.R
+++ /dev/null
@@ -1,158 +0,0 @@
-#' inclusion Rules View
-inclusionRulesView <- function(id) {
- ns <- shiny::NS(id)
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Inclusion Rules",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "inclusionRuleStats.html"))
- ),
- shinydashboard::box(
- status = "warning",
- width = "100%",
- tags$div(
- style = "max-height: 100px; overflow-y: auto",
- shiny::uiOutput(outputId = ns("selectedCohort"))
- )
- ),
- shinydashboard::box(
- title = NULL,
- width = NULL,
- htmltools::withTags(
- table(
- width = "100%",
- tr(
- td(
- align = "left",
- shiny::radioButtons(
- inputId = ns("inclusionRuleTableFilters"),
- label = "Inclusion Rule Events",
- choices = c("All", "Meet", "Gain", "Remain"),
- selected = "All",
- inline = TRUE
- )
- ),
- tags$td(
- shiny::checkboxInput(
- inputId = ns("inclusionRulesShowAsPercent"),
- label = "Show as percent",
- value = TRUE
- )
- ),
- td(
- align = "right",
- )
- )
- )
- ),
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("inclusionRuleTable"))),
- csvDownloadButton(ns, "inclusionRuleTable")
- )
- )
-}
-
-#' inclusion Rules Module
-#'
-#'
-#'
-#'
-inclusionRulesModule <- function(id,
- dataSource,
- cohortTable,
- databaseTable,
- selectedCohort,
- targetCohortId,
- selectedDatabaseIds) {
-
- shiny::moduleServer(id, function(input, output, session) {
- output$selectedCohort <- shiny::renderUI(selectedCohort())
-
- # Inclusion rules table ------------------
- output$inclusionRuleTable <- reactable::renderReactable(expr = {
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- table <- getInclusionRuleStats(
- dataSource = dataSource,
- cohortIds = targetCohortId(),
- databaseIds = selectedDatabaseIds(),
- mode = 0
- )
- validate(need(hasData(table), "There is no data for the selected combination."))
-
- showDataAsPercent <- input$inclusionRulesShowAsPercent
-
- if (showDataAsPercent) {
- table <- table %>%
- dplyr::mutate(
- Meet = meetSubjects / totalSubjects,
- Gain = gainSubjects / totalSubjects,
- Remain = remainSubjects / totalSubjects,
- id = ruleSequenceId
- )
- } else {
- table <- table %>%
- dplyr::mutate(
- Meet = meetSubjects,
- Gain = gainSubjects,
- Remain = remainSubjects,
- Total = totalSubjects,
- id = ruleSequenceId
- )
- }
-
- table <- table %>%
- dplyr::arrange(cohortId,
- databaseId,
- id)
-
- validate(need(
- (nrow(table) > 0),
- "There is no data for the selected combination."
- ))
-
- keyColumnFields <-
- c("id", "ruleName")
- countLocation <- 1
-
- if (any(!hasData(input$inclusionRuleTableFilters),
- input$inclusionRuleTableFilters == "All")) {
- dataColumnFields <- c("Meet", "Gain", "Remain")
- } else {
- dataColumnFields <- c(input$inclusionRuleTableFilters)
- }
-
- if (all(hasData(showDataAsPercent), !showDataAsPercent)) {
- dataColumnFields <- c(dataColumnFields, "Total")
- }
-
- countsForHeader <-
- getDisplayTableHeaderCount(
- dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortIds = targetCohortId(),
- source = "cohort",
- fields = "Persons"
- )
-
- maxCountValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(
- data = table,
- string = dataColumnFields
- )
-
- getDisplayTableGroupedByDatabaseId(
- data = table,
- cohort = cohortTable,
- databaseTable = databaseTable,
- headerCount = countsForHeader,
- keyColumns = keyColumnFields,
- countLocation = countLocation,
- dataColumns = dataColumnFields,
- maxCount = maxCountValue,
- showDataAsPercent = showDataAsPercent,
- sort = FALSE
- )
- })
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/IndexEventModule.R b/inst/shiny/DiagnosticsExplorer/R/IndexEventModule.R
deleted file mode 100644
index 7ccec6356..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/IndexEventModule.R
+++ /dev/null
@@ -1,227 +0,0 @@
-#'
-#'
-#'
-#'
-indexEventBreakdownView <- function(id) {
- ns <- shiny::NS(id)
-
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Index Events",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "indexEventBreakdown.html"))
- ),
- shinydashboard::box(
- status = "warning",
- width = "100%",
- tags$div(
- style = "max-height: 100px; overflow-y: auto",
- shiny::uiOutput(outputId = ns("selectedCohort"))
- )
- ),
- shinydashboard::box(
- width = NULL,
- title = NULL,
- htmltools::withTags(
- table(
- width = "100%",
- tr(
- td(
- shiny::radioButtons(
- inputId = ns("indexEventBreakdownTableRadioButton"),
- label = "Concept type",
- choices = c("All", "Standard concepts", "Non Standard Concepts"),
- selected = "All",
- inline = TRUE
- )
- ),
- td(HTML(" ")),
- td(
- shiny::radioButtons(
- inputId = ns("indexEventBreakdownTableFilter"),
- label = "Display",
- choices = c("Both", "Records", "Persons"),
- selected = "Persons",
- inline = TRUE
- )
- ),
- td(
- shiny::checkboxInput(
- inputId = ns("showAsPercent"),
- label = "Show as percentage",
- value = TRUE
- )
- )
- )
- )
- ),
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("breakdownTable"))),
- csvDownloadButton(ns, "breakdownTable")
- )
- )
-}
-
-#'
-#'
-#'
-indexEventBreakdownModule <- function(id,
- dataSource,
- cohortTable,
- databaseTable,
- selectedCohort,
- targetCohortId,
- selectedDatabaseIds) {
- ns <- shiny::NS(id)
-
- serverFunction <- function(input, output, session) {
-
- output$selectedCohort <- shiny::renderUI(selectedCohort())
-
- # Index event breakdown -----------
- indexEventBreakDownData <- shiny::reactive(x = {
- if (length(targetCohortId()) > 0 &&
- length(selectedDatabaseIds()) > 0) {
- data <- getIndexEventBreakdown(
- dataSource = dataSource,
- cohortIds = targetCohortId(),
- databaseIds = selectedDatabaseIds()
- )
- if (any(
- is.null(data),
- nrow(data) == 0
- )) {
- return(NULL)
- }
- if (!is.null(data)) {
- if (!"domainTable" %in% colnames(data)) {
- data$domainTable <- "Not in data"
- }
- if (!"domainField" %in% colnames(data)) {
- data$domainField <- "Not in data"
- }
- return(data)
- } else {
- return(NULL)
- }
- } else {
- return(NULL)
- }
- })
-
- indexEventBreakDownDataFilteredByRadioButton <-
- shiny::reactive(x = {
- data <- indexEventBreakDownData()
- if (!is.null(data) && nrow(data) > 0) {
- if (input$indexEventBreakdownTableRadioButton == "All") {
- return(data)
- } else if (input$indexEventBreakdownTableRadioButton == "Standard concepts") {
- return(data %>% dplyr::filter(standardConcept == "S"))
- } else {
- return(data %>% dplyr::filter(is.na(standardConcept)))
- }
- } else {
- return(NULL)
- }
- })
-
- output$breakdownTable <- reactable::renderReactable(expr = {
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- validate(need(length(targetCohortId()) > 0, "No cohorts chosen chosen"))
-
- showDataAsPercent <- input$showAsPercent
- data <- indexEventBreakDownDataFilteredByRadioButton()
-
- validate(need(
- all(!is.null(data), nrow(data) > 0),
- "There is no data for the selected combination."
- ))
-
- validate(need(
- nrow(data) > 0,
- "No data available for selected combination."
- ))
-
- data <- data %>%
- dplyr::arrange(databaseId) %>%
- dplyr::select(
- conceptId,
- conceptName,
- domainField,
- databaseId,
- vocabularyId,
- conceptCode,
- conceptCount,
- subjectCount,
- subjectPercent,
- conceptPercent
- ) %>%
- dplyr::filter(conceptId > 0) %>%
- dplyr::distinct()
-
- if (showDataAsPercent) {
- data <- data %>%
- dplyr::rename(
- persons = subjectPercent,
- records = conceptPercent
- )
- } else {
- data <- data %>%
- dplyr::rename(
- persons = subjectCount,
- records = conceptCount
- )
- }
-
- data <- data %>%
- dplyr::arrange(dplyr::desc(abs(dplyr::across(
- c("records", "persons")
- ))))
-
- keyColumnFields <-
- c("conceptId", "conceptName", "conceptCode", "domainField", "vocabularyId")
- if (input$indexEventBreakdownTableFilter == "Persons") {
- dataColumnFields <- c("persons")
- countLocation <- 1
- } else if (input$indexEventBreakdownTableFilter == "Records") {
- dataColumnFields <- c("records")
- countLocation <- 1
- } else {
- dataColumnFields <- c("persons", "records")
- countLocation <- 2
- }
-
- countsForHeader <-
- getDisplayTableHeaderCount(
- dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortIds = targetCohortId(),
- source = "cohort",
- fields = input$indexEventBreakdownTableFilter
- )
-
- maxCountValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(
- data = data,
- string = dataColumnFields
- )
-
- getDisplayTableGroupedByDatabaseId(
- data = data,
- cohort = cohortTable,
- databaseTable = databaseTable,
- headerCount = countsForHeader,
- keyColumns = keyColumnFields,
- countLocation = countLocation,
- dataColumns = dataColumnFields,
- maxCount = maxCountValue,
- showDataAsPercent = showDataAsPercent,
- sort = TRUE
- )
- })
- }
-
-
- return(shiny::moduleServer(id, serverFunction))
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/OrphanConceptsModule.R b/inst/shiny/DiagnosticsExplorer/R/OrphanConceptsModule.R
deleted file mode 100644
index 90628335f..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/OrphanConceptsModule.R
+++ /dev/null
@@ -1,213 +0,0 @@
-#' Orphan Concepts View
-#'
-orpahanConceptsView <- function(id) {
- ns <- shiny::NS(id)
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Orphan Concepts",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "orphanConcepts.html"))
- ),
- shinydashboard::box(
- status = "warning",
- width = "100%",
- tags$div(
- style = "max-height: 100px; overflow-y: auto",
- shiny::uiOutput(outputId = ns("selectedCohorts"))
- )
- ),
- shinydashboard::box(
- title = NULL,
- width = NULL,
- htmltools::withTags(
- table(
- width = "100%",
- tr(
- td(
- shiny::radioButtons(
- inputId = ns("orphanConceptsType"),
- label = "Filters",
- choices = c("All", "Standard Only", "Non Standard Only"),
- selected = "All",
- inline = TRUE
- )
- ),
- td(HTML(" ")),
- td(
- shiny::radioButtons(
- inputId = ns("orphanConceptsColumFilterType"),
- label = "Display",
- choices = c("All", "Persons", "Records"),
- selected = "All",
- inline = TRUE
- )
- )
- )
- )
- ),
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("orphanConceptsTable"))),
- csvDownloadButton(ns, "orphanConceptsTable")
- )
- )
-}
-
-
-orphanConceptsModule <- function(id,
- dataSource,
- selectedCohort,
- selectedDatabaseIds,
- targetCohortId,
- selectedConceptSets,
- conceptSetIds) {
- ns <- shiny::NS(id)
- shiny::moduleServer(id, function(input, output, session) {
- output$selectedCohorts <- shiny::renderUI({ selectedCohort() })
-
-
- # Orphan concepts table --------------------
- orphanConceptsDataReactive <- shiny::reactive(x = {
- validate(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(conceptCount))
- return(data)
- })
-
- # Reactive below developed for testing purposes
- # Focuses on filtering the standard vs. non-standard codes
- filteringStandardConceptsReactive <- shiny::reactive(x = {
- data <- orphanConceptsDataReactive()
- validate(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(conceptSetId %in% conceptSetIds())
- } else {
- data <- data[0,]
- }
- }
- }
-
- if (input$orphanConceptsType == "Standard Only") {
- data <- data %>%
- dplyr::filter(standardConcept == "S")
- } else if (input$orphanConceptsType == "Non Standard Only") {
- data <- data %>%
- dplyr::filter(is.na(standardConcept) |
- (
- all(!is.na(standardConcept), standardConcept != "S")
- ))
- }
-
- return (data)
-
- })
-
- output$orphanConceptsTable <- reactable::renderReactable(expr = {
- data <- filteringStandardConceptsReactive()
- validate(need(hasData(data), "There is no data for the selected combination."))
-
-
- data <- data %>%
- dplyr::select(
- databaseId,
- cohortId,
- conceptId,
- conceptSubjects,
- conceptCount
- ) %>%
- dplyr::group_by(
- databaseId,
- cohortId,
- conceptId
- ) %>%
- dplyr::summarise(
- conceptSubjects = sum(conceptSubjects),
- conceptCount = sum(conceptCount),
- .groups = "keep"
- ) %>%
- dplyr::ungroup() %>%
- dplyr::arrange(
- databaseId,
- 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")
- ))))
-
- 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
- )
-
- maxCountValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(
- data = data,
- string = dataColumnFields
- )
-
- showDataAsPercent <- FALSE
- ## showDataAsPercent set based on UI selection - proportion
-
- displayTable <- getDisplayTableGroupedByDatabaseId(
- data = data,
- cohort = cohort,
- databaseTable = database,
- headerCount = countsForHeader,
- keyColumns = keyColumnFields,
- countLocation = countLocation,
- dataColumns = dataColumnFields,
- maxCount = maxCountValue,
- showDataAsPercent = showDataAsPercent,
- sort = TRUE
- )
- return(displayTable)
- })
-
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/Plots.R b/inst/shiny/DiagnosticsExplorer/R/Plots.R
deleted file mode 100644
index 2760123c8..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/Plots.R
+++ /dev/null
@@ -1,170 +0,0 @@
-addShortName <-
- function(data,
- shortNameRef = NULL,
- cohortIdColumn = "cohortId",
- shortNameColumn = "shortName") {
- if (is.null(shortNameRef)) {
- shortNameRef <- data %>%
- dplyr::distinct(cohortId) %>%
- dplyr::arrange(cohortId) %>%
- dplyr::mutate(shortName = paste0("C", dplyr::row_number()))
- }
-
- shortNameRef <- shortNameRef %>%
- dplyr::distinct(cohortId, shortName)
- colnames(shortNameRef) <- c(cohortIdColumn, shortNameColumn)
- data <- data %>%
- dplyr::inner_join(shortNameRef, by = dplyr::all_of(cohortIdColumn))
- return(data)
- }
-
-
-plotCohortComparisonStandardizedDifference <- function(balance,
- shortNameRef = NULL,
- xLimitMin = 0,
- xLimitMax = 1,
- yLimitMin = 0,
- yLimitMax = 1,
- domain = "all") {
- domains <-
- c(
- "Condition",
- "Device",
- "Drug",
- "Measurement",
- "Observation",
- "Procedure",
- "Demographics"
- )
-
- balance$domainId[!balance$domainId %in% domains] <- "Other"
- if (domain != "all") {
- balance <- balance %>%
- dplyr::filter(domainId == !!domain)
- }
-
- # Can't make sense of plot with > 1000 dots anyway, so remove
- # anything with small mean in both target and comparator:
- if (nrow(balance) > 1000) {
- balance <- balance %>%
- dplyr::filter(mean1 > 0.01 | mean2 > 0.01)
- }
- if (nrow(balance) > 1000) {
- balance <- balance %>%
- dplyr::filter(sumValue1 > 0 & sumValue2 > 0)
- }
-
- balance <- balance %>%
- addShortName(
- shortNameRef = shortNameRef,
- cohortIdColumn = "cohortId1",
- shortNameColumn = "targetCohort"
- ) %>%
- addShortName(
- shortNameRef = shortNameRef,
- cohortIdColumn = "cohortId2",
- shortNameColumn = "comparatorCohort"
- )
-
- # ggiraph::geom_point_interactive(ggplot2::aes(tooltip = tooltip), size = 3, alpha = 0.6)
- balance$tooltip <-
- c(
- paste0(
- "Covariate Name: ",
- balance$covariateName,
- "\nDomain: ",
- balance$domainId,
- "\nAnalysis: ",
- balance$analysisName,
- "\nY ",
- balance$comparatorCohort,
- ": ",
- scales::comma(balance$mean2, accuracy = 0.01),
- "\nX ",
- balance$targetCohort,
- ": ",
- scales::comma(balance$mean1, accuracy = 0.01),
- "\nStd diff.:",
- scales::comma(balance$stdDiff, accuracy = 0.01)
- )
- )
-
- # Code used to generate palette:
- # writeLines(paste(RColorBrewer::brewer.pal(n = length(domains), name = "Dark2"), collapse = "\", \""))
-
- # Make sure colors are consistent, no matter which domains are included:
- colors <-
- c(
- "#1B9E77",
- "#D95F02",
- "#7570B3",
- "#E7298A",
- "#66A61E",
- "#E6AB02",
- "#444444"
- )
- colors <-
- colors[c(domains, "Other") %in% unique(balance$domainId)]
-
- balance$domainId <-
- factor(balance$domainId, levels = c(domains, "Other"))
-
- # targetLabel <- paste(strwrap(targetLabel, width = 50), collapse = "\n")
- # comparatorLabel <- paste(strwrap(comparatorLabel, width = 50), collapse = "\n")
-
- xCohort <- balance %>%
- dplyr::distinct(balance$targetCohort) %>%
- dplyr::pull()
- yCohort <- balance %>%
- dplyr::distinct(balance$comparatorCohort) %>%
- dplyr::pull()
-
- if (nrow(balance) == 0) {
- return(NULL)
- }
-
- plot <-
- ggplot2::ggplot(
- balance,
- ggplot2::aes(
- x = mean1,
- y = mean2,
- color = domainId
- )
- ) +
- ggiraph::geom_point_interactive(
- ggplot2::aes(tooltip = tooltip),
- size = 3,
- shape = 16,
- alpha = 0.5
- ) +
- ggplot2::geom_abline(
- slope = 1,
- intercept = 0,
- linetype = "dashed"
- ) +
- ggplot2::geom_hline(yintercept = 0) +
- ggplot2::geom_vline(xintercept = 0) +
- # ggplot2::scale_x_continuous("Mean") +
- # ggplot2::scale_y_continuous("Mean") +
- ggplot2::xlab(paste("Covariate Mean in ", xCohort)) +
- ggplot2::ylab(paste("Covariate Mean in ", yCohort)) +
- ggplot2::scale_color_manual("Domain", values = colors) +
- facet_nested(databaseId + targetCohort ~ comparatorCohort) +
- ggplot2::theme(strip.background = ggplot2::element_blank()) +
- ggplot2::xlim(xLimitMin, xLimitMax) +
- ggplot2::ylim(yLimitMin, yLimitMax)
-
- plot <- ggiraph::girafe(
- ggobj = plot,
- options = list(
- ggiraph::opts_sizing(width = .7),
- ggiraph::opts_zoom(max = 5)
- ),
- width_svg = 12,
- height_svg = 5
- )
- return(plot)
-}
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/R/ResultRetrieval.R b/inst/shiny/DiagnosticsExplorer/R/ResultRetrieval.R
deleted file mode 100644
index 01e2a676c..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/ResultRetrieval.R
+++ /dev/null
@@ -1,1294 +0,0 @@
-
-
-
-renderTranslateQuerySql <-
- function(connection,
- sql,
- dbms,
- ...,
- snakeCaseToCamelCase = FALSE) {
- if (is(connection, "Pool")) {
- sql <- SqlRender::render(sql, ...)
- sql <- SqlRender::translate(sql, targetDialect = dbms)
-
- tryCatch(
- {
- data <- DatabaseConnector::dbGetQuery(connection, sql)
- },
- error = function(err) {
- writeLines(sql)
- if (dbms %in% c("postgresql", "redshift")) {
- DatabaseConnector::dbExecute(connection, "ABORT;")
- }
- stop(err)
- }
- )
- if (snakeCaseToCamelCase) {
- colnames(data) <- SqlRender::snakeCaseToCamelCase(colnames(data))
- }
- return(data)
- } else {
- return(
- DatabaseConnector::renderTranslateQuerySql(
- connection = connection,
- sql = sql,
- ...,
- snakeCaseToCamelCase = snakeCaseToCamelCase
- )
- )
- }
- }
-
-
-queryResultCovariateValue <- function(dataSource,
- cohortIds,
- analysisIds = NULL,
- databaseIds,
- startDay = NULL,
- endDay = NULL,
- temporalCovariateValue = TRUE,
- temporalCovariateValueDist = TRUE,
- meanThreshold = 0) {
- # Perform error checks for input variables
- errorMessage <- checkmate::makeAssertCollection()
- checkmate::assertIntegerish(
- x = startDay,
- any.missing = TRUE,
- unique = FALSE,
- null.ok = TRUE,
- add = errorMessage
- )
- checkmate::assertIntegerish(
- x = endDay,
- any.missing = TRUE,
- unique = FALSE,
- null.ok = TRUE,
- add = errorMessage
- )
-
- temporalTimeRefData <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = "SELECT *
- FROM @results_database_schema.@table_name
- WHERE (time_id IS NOT NULL AND time_id != 0)
- {@start_day != \"\"} ? { AND start_day IN (@start_day)}
- {@end_day != \"\"} ? { AND end_day IN (@end_day)};",
- snakeCaseToCamelCase = TRUE,
- results_database_schema = dataSource$resultsDatabaseSchema,
- table_name = dataSource$prefixTable("temporal_time_ref"),
- start_day = startDay,
- end_day = endDay
- ) %>%
- dplyr::tibble()
-
- temporalTimeRefData <- dplyr::bind_rows(
- temporalTimeRefData,
- dplyr::tibble(timeId = -1)
- )
-
- temporalAnalysisRefData <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = "SELECT *
- FROM @results_database_schema.@table_name
- WHERE analysis_id IS NOT NULL
- {@analysis_ids != \"\"} ? { AND analysis_id IN (@analysis_ids)}
- ;",
- analysis_ids = analysisIds,
- table_name = dataSource$prefixTable("temporal_analysis_ref"),
- snakeCaseToCamelCase = TRUE,
- results_database_schema = dataSource$resultsDatabaseSchema
- ) %>%
- dplyr::tibble()
-
- temporalCovariateRefData <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = "SELECT *
- FROM @results_database_schema.@table_name
- WHERE covariate_id IS NOT NULL
- {@analysis_ids != \"\"} ? { AND analysis_id IN (@analysis_ids)};",
- snakeCaseToCamelCase = TRUE,
- analysis_ids = analysisIds,
- table_name = dataSource$prefixTable("temporal_covariate_ref"),
- results_database_schema = dataSource$resultsDatabaseSchema
- ) %>%
- dplyr::tibble()
-
- temporalCovariateValueData <- NULL
- if (temporalCovariateValue) {
- temporalCovariateValueData <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = "SELECT tcv.*
- FROM @results_database_schema.@table_name tcv
- INNER JOIN @results_database_schema.@ref_table_name ref ON ref.covariate_id = tcv.covariate_id
- WHERE ref.covariate_id IS NOT NULL
- {@analysis_ids != \"\"} ? { AND ref.analysis_id IN (@analysis_ids)}
- {@cohort_id != \"\"} ? { AND tcv.cohort_id IN (@cohort_id)}
- {@time_id != \"\"} ? { AND (time_id IN (@time_id) OR time_id IS NULL OR time_id = 0)}
- {@use_database_id} ? { AND database_id IN (@database_id)}
- {@filter_mean_threshold != \"\"} ? { AND tcv.mean > @filter_mean_threshold};",
- snakeCaseToCamelCase = TRUE,
- analysis_ids = analysisIds,
- time_id = temporalTimeRefData$timeId %>% unique(),
- use_database_id = !is.null(databaseIds),
- database_id = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("temporal_covariate_value"),
- ref_table_name = dataSource$prefixTable("temporal_covariate_ref"),
- cohort_id = cohortIds,
- results_database_schema = dataSource$resultsDatabaseSchema,
- filter_mean_threshold = meanThreshold
- ) %>%
- dplyr::tibble() %>%
- tidyr::replace_na(replace = list(timeId = -1))
- }
-
- temporalCovariateValueDistData <- NULL
- if (temporalCovariateValueDist) {
- temporalCovariateValueDistData <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = "SELECT *
- FROM @results_database_schema.@table_name tcv
- WHERE covariate_id IS NOT NULL
- {@covariate_id != \"\"} ? { AND covariate_id IN (@covariate_id)}
- {@cohort_id != \"\"} ? { AND cohort_id IN (@cohort_id)}
- {@time_id != \"\"} ? { AND (time_id IN (@time_id) OR time_id IS NULL OR time_id = 0)}
- {@use_database_id} ? { AND database_id IN (@database_id)}
- {@filter_mean_threshold != \"\"} ? { AND tcv.mean > @filter_mean_threshold};",
- snakeCaseToCamelCase = TRUE,
- covariate_id = temporalCovariateRefData$covariateId %>% unique(),
- time_id = temporalTimeRefData$timeId %>% unique(),
- use_database_id = !is.null(databaseIds),
- database_id = quoteLiterals(databaseIds),
- cohort_id = cohortIds,
- table_name = dataSource$prefixTable("temporal_covariate_value_dist"),
- results_database_schema = dataSource$resultsDatabaseSchema,
- filter_mean_threshold = meanThreshold
- ) %>%
- dplyr::tibble() %>%
- tidyr::replace_na(replace = list(timeId = -1))
- }
-
- if (hasData(temporalCovariateValueData)) {
- temporalCovariateValueData <- temporalCovariateValueData %>%
- dplyr::left_join(temporalTimeRefData,
- by = "timeId"
- )
- }
-
- if (hasData(temporalCovariateValueDistData)) {
- temporalCovariateValueDistData <-
- temporalCovariateValueDistData %>%
- dplyr::left_join(temporalTimeRefData,
- by = "timeId"
- )
- }
-
- data <- list(
- temporalTimeRef = temporalTimeRefData,
- temporalAnalysisRef = temporalAnalysisRefData,
- temporalCovariateRef = temporalCovariateRefData,
- temporalCovariateValue = temporalCovariateValueData,
- temporalCovariateValueDist = temporalCovariateValueDistData
- )
- return(data)
-}
-
-
-getCharacterizationOutput <- function(dataSource,
- cohortIds,
- analysisIds = NULL,
- databaseIds,
- startDay = NULL,
- endDay = NULL,
- temporalCovariateValue = TRUE,
- temporalCovariateValueDist = TRUE,
- meanThreshold = 0.005) {
- temporalChoices <-
- getResultsTemporalTimeRef(dataSource = dataSource)
-
- covariateValue <- queryResultCovariateValue(
- dataSource = dataSource,
- cohortIds = cohortIds,
- analysisIds = analysisIds,
- databaseIds = databaseIds,
- startDay = startDay,
- endDay = endDay,
- temporalCovariateValue = temporalCovariateValue,
- temporalCovariateValueDist = temporalCovariateValueDist,
- meanThreshold = meanThreshold
- )
-
- postProcessCharacterizationValue <- function(data) {
- if ("timeId" %in% colnames(data$temporalCovariateValue)) {
- data$temporalCovariateValue$timeId <- NULL
- }
- resultCovariateValue <- data$temporalCovariateValue %>%
- dplyr::arrange(
- cohortId,
- databaseId,
- covariateId
- ) %>%
- dplyr::inner_join(data$temporalCovariateRef,
- by = "covariateId"
- ) %>%
- dplyr::inner_join(data$temporalAnalysisRef,
- by = "analysisId"
- ) %>%
- dplyr::left_join(
- temporalChoices %>%
- dplyr::select(
- startDay,
- endDay,
- timeId,
- temporalChoices
- ),
- by = c("startDay", "endDay")
- ) %>%
- dplyr::relocate(
- cohortId,
- databaseId,
- timeId,
- startDay,
- endDay,
- temporalChoices,
- analysisId,
- covariateId,
- covariateName,
- isBinary
- )
-
- if ("missingMeansZero" %in% colnames(resultCovariateValue)) {
- resultCovariateValue <- resultCovariateValue %>%
- dplyr::mutate(mean = dplyr::if_else(
- is.na(mean) &
- !is.na(missingMeansZero) &
- missingMeansZero == "Y",
- 0,
- mean
- )) %>%
- dplyr::select(-missingMeansZero)
- }
- resultCovariateValue <- resultCovariateValue %>%
- dplyr::mutate(
- covariateName = stringr::str_replace_all(
- string = covariateName,
- pattern = "^.*: ",
- replacement = ""
- )
- ) %>%
- dplyr::mutate(covariateName = stringr::str_to_sentence(string = covariateName))
-
- if (!hasData(resultCovariateValue)) {
- return(NULL)
- }
- return(resultCovariateValue)
- }
-
- resultCovariateValue <- NULL
- if ("temporalCovariateValue" %in% names(covariateValue) &&
- hasData(covariateValue$temporalCovariateValue)) {
- resultCovariateValue <-
- postProcessCharacterizationValue(data = covariateValue)
- }
-
- cohortRelCharRes <-
- getCohortRelationshipCharacterizationResults(
- dataSource = dataSource,
- cohortIds = cohortIds,
- databaseIds = databaseIds
- )
- resultCohortValue <- NULL
- if ("temporalCovariateValue" %in% names(cohortRelCharRes) &&
- hasData(cohortRelCharRes$temporalCovariateValue)) {
- resultCohortValue <-
- postProcessCharacterizationValue(data = cohortRelCharRes)
- }
-
- resultCovariateValueDist <- NULL
-
- temporalCovariateValue <- NULL
- temporalCovariateValueDist <- NULL
-
- if (hasData(resultCovariateValue)) {
- temporalCovariateValue <- dplyr::bind_rows(
- temporalCovariateValue,
- resultCovariateValue
- )
- }
-
- if (hasData(resultCovariateValueDist)) {
- temporalCovariateValueDist <-
- dplyr::bind_rows(
- temporalCovariateValueDist,
- resultCovariateValueDist
- )
- }
-
- if (hasData(resultCohortValue)) {
- temporalCovariateValue <- dplyr::bind_rows(
- temporalCovariateValue,
- resultCohortValue
- )
- }
-
- return(
- list(
- covariateValue = temporalCovariateValue,
- covariateValueDist = temporalCovariateValueDist
- )
- )
-}
-
-
-
-#' Returns data from time_distribution table of Cohort Diagnostics results data model
-#'
-#' @description
-#' Returns data from time_distribution table of Cohort Diagnostics results data model
-#'
-#' @template DataSource
-#'
-#' @template CohortIds
-#'
-#' @template DatabaseIds
-#'
-#' @return
-#' Returns a data frame (tibble).
-#'
-#' @export
-getTimeDistributionResult <- function(dataSource,
- cohortIds,
- databaseIds,
- databaseTable) {
- data <- queryResultCovariateValue(
- dataSource = dataSource,
- cohortIds = cohortIds,
- databaseIds = databaseIds,
- analysisIds = c(8, 9, 10),
- temporalCovariateValue = FALSE,
- temporalCovariateValueDist = TRUE
- )
- if (!hasData(data)) {
- return(NULL)
- }
- temporalCovariateValueDist <- data$temporalCovariateValueDist
- if (!hasData(temporalCovariateValueDist)) {
- return(NULL)
- }
- data <- temporalCovariateValueDist %>%
- dplyr::inner_join(data$temporalCovariateRef,
- by = "covariateId"
- ) %>%
- dplyr::inner_join(data$temporalAnalysisRef,
- by = "analysisId"
- ) %>%
- dplyr::inner_join(databaseTable,
- by = "databaseId"
- ) %>%
- dplyr::rename(
- "timeMetric" = covariateName,
- "averageValue" = mean,
- "standardDeviation" = sd
- ) %>%
- dplyr::select(
- "cohortId",
- "databaseId",
- "databaseName",
- "timeMetric",
- "averageValue",
- "standardDeviation",
- "minValue",
- "p10Value",
- "p25Value",
- "medianValue",
- "p75Value",
- "p90Value",
- "maxValue"
- )
- return(data)
-}
-
-
-#' Returns matrix of relationship between target and comparator cohortIds
-#'
-#' @description
-#' Given a list of target and comparator cohortIds gets temporal relationship.
-#'
-#' @template DataSource
-#'
-#' @template CohortIds
-#'
-#' @template ComparatorCohortIds
-#'
-#' @template DatabaseIds
-#'
-#' @param relationshipDays A vector of integer representing days comparator cohort
-#' start to target cohort start
-#'
-#' @param relationshipType What type of relationship do you want to retrieve. The
-#' available options are 'start', 'end', 'overlap'.
-#'
-#' @return
-#' Returns a data frame (tibble)
-#'
-#' @export
-getCohortTemporalRelationshipMatrix <- function(dataSource,
- databaseIds = NULL,
- cohortIds = NULL,
- comparatorCohortIds = NULL,
- relationshipType = "start") {
- if (relationshipType == "start") {
- variableName <- "sub_cs_window_t"
- } else if (relationshipType == "end") {
- variableName <- "sub_ce_window_t"
- } else if (relationshipType == "overlap") {
- variableName <- "sub_c_within_t"
- } else {
- stop("Unrecognized relationshipType. Available options are 'start', 'end','overlap'")
- }
-
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = "SELECT DISTINCT database_id,
- cohort_id,
- comparator_cohort_id,
- start_day,
- end_day,
- sub_cs_window_t
- FROM @results_database_schema.@table_name
- WHERE cohort_id IN (@cohort_id) AND
- database_id IN (@database_id)
- {@start_day != \"\"} ? { AND start_day IN (@start_day)}
- {@end_day != \"\"} ? { AND end_day IN (@end_day)};",
- snakeCaseToCamelCase = TRUE,
- results_database_schema = dataSource$resultsDatabaseSchema,
- cohort_id = cohortIds,
- database_id = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("cohort_relationships"),
- start_day = startDay,
- end_day = endDay
- ) %>%
- dplyr::tibble()
- if (any(
- (is.null(data)),
- nrow(data) == 0
- )) {
- return(NULL)
- }
-
- data <- data %>%
- dplyr::select(
- databaseId,
- cohortId,
- comparatorCohortId,
- startDay,
- subCsWindowT
- ) %>%
- dplyr::mutate(
- day = dplyr::case_when(
- startDay < 0 ~ paste0("dm", abs(startDay)),
- startDay > 0 ~ paste0("dp", abs(startDay)),
- startDay == 0 ~ paste0("d", abs(startDay))
- )
- ) %>%
- dplyr::arrange(
- databaseId,
- cohortId,
- comparatorCohortId,
- startDay
- ) %>%
- dplyr::distinct() %>%
- tidyr::pivot_wider(
- id_cols = c("databaseId", "cohortId", "comparatorCohortId"),
- names_from = "day",
- values_from = "subCsWindowT"
- )
-
- return(data)
-}
-
-
-
-#' Returns data for use in cohort co-occurrence matrix
-#'
-#' @description
-#' Returns a a data frame (tibble) that shows the percent (optionally number) of subjects
-#' in target cohort that are also in comparator cohort at certain days relative to
-#' first start date of a subject in target cohort.
-#'
-#' @template DataSource
-#'
-#' @template TargetCohortIds
-#'
-#' @template ComparatorCohortIds
-#'
-#' @template DatabaseIds
-#'
-#' @template StartDays
-#'
-#' @template endDays
-#'
-#' @param showPercent Return percent instead of raw numbers
-#'
-#' @return
-#' Returns a data frame (tibble). Note - the computation is in relation
-#' to first start of target cohort only.
-#'
-#' @export
-getResultsCohortCoOccurrenceMatrix <- function(dataSource,
- targetCohortIds = NULL,
- comparatorCohortIds = NULL,
- databaseIds = NULL,
- startDays = NULL,
- endDays = NULL,
- showPercent = TRUE) {
- cohortCount <- getResultsCohortCount(
- dataSource = dataSource,
- cohortIds = c(targetCohortIds, comparatorCohortIds) %>% unique(),
- databaseIds = databaseIds
- )
- if (is.null(data$cohortCount)) {
- return(NULL)
- }
-
- cohortRelationship <- getResultsCohortRelationships(
- dataSource = dataSource,
- cohortIds = targetCohortIds,
- comparatorCohortIds = comparatorCohortIds,
- databaseIds = databaseIds,
- startDays = startDays,
- endDays = endDays
- )
- if (is.null(cohortRelationship)) {
- return(NULL)
- }
-
-
- cohortRelationship <- cohortRelationship %>%
- dplyr::mutate(records = 0) %>%
- dplyr::rename(
- "targetCohortId" = cohortId,
- "comparatorCohortId" = comparatorCohortId,
- "bothSubjects" = subjects,
- "bothRecords" = records
- ) %>%
- dplyr::select(
- databaseId,
- targetCohortId,
- comparatorCohortId,
- startDay,
- endDay,
- # overlap - comparator period overlaps target period (offset)
- bothSubjects,
- bothRecords,
- # comparator start on Target Start
- recCsOnTs,
- subCsOnTs,
- subCsWindowT
- )
-
- coOccurrenceMatrix <- cohortRelationship %>%
- dplyr::filter(startDay == endDay) %>%
- dplyr::mutate(dayName = dplyr::case_when(
- startDay < 0 ~ paste0("dayNeg", abs(startDay)),
- TRUE ~ paste0("dayPos", abs(startDay))
- )) %>%
- dplyr::select(
- databaseId,
- targetCohortId,
- comparatorCohortId,
- dayName,
- bothSubjects,
- subCsOnTs,
- subCsWindowT
- )
-
- matrixOverlap <- coOccurrenceMatrix %>%
- dplyr::filter(!is.na(bothSubjects)) %>%
- dplyr::select(
- databaseId,
- targetCohortId,
- comparatorCohortId,
- dayName,
- bothSubjects
- ) %>%
- tidyr::pivot_wider(
- id_cols = c(
- databaseId,
- targetCohortId,
- comparatorCohortId
- ),
- names_from = dayName,
- values_from = bothSubjects
- ) %>%
- dplyr::mutate(type = "overlap")
-
- matrixStart <- coOccurrenceMatrix %>%
- dplyr::filter(!is.na(subCsOnTs)) %>%
- dplyr::select(
- databaseId,
- targetCohortId,
- comparatorCohortId,
- dayName,
- subCsOnTs
- ) %>%
- tidyr::pivot_wider(
- id_cols = c(
- databaseId,
- targetCohortId,
- comparatorCohortId
- ),
- names_from = dayName,
- values_from = subCsOnTs
- ) %>%
- dplyr::mutate(type = "start")
-
- matrixStartWindows <- coOccurrenceMatrix %>%
- dplyr::filter(!is.na(subCsWindowT)) %>%
- dplyr::select(
- databaseId,
- targetCohortId,
- comparatorCohortId,
- dayName,
- subCsWindowT
- ) %>%
- tidyr::pivot_wider(
- id_cols = c(
- databaseId,
- targetCohortId,
- comparatorCohortId
- ),
- names_from = dayName,
- values_from = subCsWindowT
- ) %>%
- dplyr::mutate(type = "startWindow")
-
- matrix <- dplyr::bind_rows(
- matrixOverlap,
- matrixStart,
- matrixStartWindows
- )
- if (showPercent) {
- matrix <- matrix %>%
- dplyr::inner_join(
- cohortCount %>%
- dplyr::select(
- databaseId,
- cohortId,
- cohortSubjects
- ) %>%
- dplyr::rename("targetCohortId" = cohortId),
- by = c("targetCohortId", "databaseId")
- ) %>%
- dplyr::mutate(dplyr::across(.cols = dplyr::starts_with("day")) / cohortSubjects)
- }
- return(matrix)
-}
-
-
-
-
-#' Returns data for use in cohort_overlap
-#'
-#' @description
-#' Returns data for use in cohort_overlap
-#'
-#' @template DataSource
-#'
-#' @param targetCohortIds A vector of cohort ids representing target cohorts
-#'
-#' @param comparatorCohortIds A vector of cohort ids representing comparator cohorts
-#'
-#' @template DatabaseIds
-#'
-#' @return
-#' Returns data for use in cohort_overlap
-#'
-#' @export
-getResultsCohortOverlap <- function(dataSource,
- targetCohortIds = NULL,
- comparatorCohortIds = NULL,
- databaseIds = NULL) {
- cohortIds <- c(targetCohortIds, comparatorCohortIds) %>% unique()
- cohortCounts <-
- getResultsCohortCounts(
- dataSource = dataSource,
- cohortIds = cohortIds,
- databaseIds = databaseIds
- )
-
- if (!hasData(cohortCounts)) {
- return(NULL)
- }
-
- cohortRelationship <-
- getResultsCohortRelationships(
- dataSource = dataSource,
- cohortIds = cohortIds,
- comparatorCohortIds = comparatorCohortIds,
- databaseIds = databaseIds,
- startDays = c(-9999, 0),
- endDays = c(9999, 0)
- )
-
- # Fix relationship data so 0 overlap displays
- allCombinations <- dplyr::tibble(databaseId = databaseIds) %>%
- tidyr::crossing(dplyr::tibble(cohortId = cohortIds)) %>%
- tidyr::crossing(dplyr::tibble(comparatorCohortId = comparatorCohortIds)) %>%
- dplyr::filter(comparatorCohortId != cohortId) %>%
- tidyr::crossing(dplyr::tibble(startDay = c(-9999, 0),
- endDay = c(9999, 0)))
-
- cohortRelationship <- allCombinations %>%
- dplyr::left_join(cohortRelationship,
- by = c("databaseId", "cohortId", "comparatorCohortId", "startDay", "endDay")) %>%
- dplyr::mutate(dplyr::across(.cols = where(is.numeric), ~tidyr::replace_na(., 0)))
-
- fullOffSet <- cohortRelationship %>%
- dplyr::filter(startDay == -9999) %>%
- dplyr::filter(endDay == 9999) %>%
- dplyr::filter(cohortId %in% c(targetCohortIds)) %>%
- dplyr::filter(comparatorCohortId %in% c(comparatorCohortIds)) %>%
- dplyr::select(
- databaseId,
- cohortId,
- comparatorCohortId,
- subjects
- ) %>%
- dplyr::inner_join(
- cohortCounts %>%
- dplyr::select(-cohortEntries) %>%
- dplyr::rename(targetCohortSubjects = cohortSubjects),
- by = c("databaseId", "cohortId")
- ) %>%
- dplyr::mutate(tOnlySubjects = targetCohortSubjects - subjects) %>%
- dplyr::inner_join(
- cohortCounts %>%
- dplyr::select(-cohortEntries) %>%
- dplyr::rename(
- comparatorCohortSubjects = cohortSubjects,
- comparatorCohortId = cohortId
- ),
- by = c("databaseId", "comparatorCohortId")
- ) %>%
- dplyr::mutate(cOnlySubjects = comparatorCohortSubjects - subjects) %>%
- dplyr::mutate(eitherSubjects = cOnlySubjects + tOnlySubjects + subjects) %>%
- dplyr::rename(
- targetCohortId = cohortId,
- bothSubjects = subjects
- ) %>%
- dplyr::select(
- databaseId,
- targetCohortId,
- comparatorCohortId,
- bothSubjects,
- tOnlySubjects,
- cOnlySubjects,
- eitherSubjects
- )
-
-
- noOffset <- cohortRelationship %>%
- dplyr::filter(comparatorCohortId %in% comparatorCohortIds) %>%
- dplyr::filter(cohortId %in% targetCohortIds) %>%
- dplyr::filter(startDay == 0) %>%
- dplyr::filter(endDay == 0) %>%
- dplyr::select(
- databaseId,
- cohortId,
- comparatorCohortId,
- subCsBeforeTs,
- subCWithinT,
- subCsAfterTs,
- subCsAfterTe,
- subCsBeforeTs,
- subCsBeforeTe,
- subCsOnTs,
- subCsOnTe
- ) %>%
- dplyr::rename(
- cBeforeTSubjects = subCsBeforeTs,
- targetCohortId = cohortId,
- cInTSubjects = subCWithinT,
- cStartAfterTStart = subCsAfterTs,
- cStartAfterTEnd = subCsAfterTe,
- cStartBeforeTStart = subCsBeforeTs,
- cStartBeforeTEnd = subCsBeforeTe,
- cStartOnTStart = subCsOnTs,
- cStartOnTEnd = subCsOnTe
- )
-
- result <- fullOffSet %>%
- dplyr::left_join(noOffset,
- by = c("databaseId", "targetCohortId", "comparatorCohortId")
- ) %>%
- dplyr::filter(targetCohortId != comparatorCohortId) %>%
- dplyr::select(
- databaseId,
- # cohortId,
- comparatorCohortId,
- eitherSubjects,
- tOnlySubjects,
- cOnlySubjects,
- bothSubjects,
- # cBeforeTSubjects,
- targetCohortId,
- cInTSubjects,
- cStartAfterTStart,
- cStartAfterTEnd,
- cStartBeforeTStart,
- cStartBeforeTEnd,
- cStartOnTStart,
- cStartOnTEnd,
- )
-
- databaseNames <- cohortCounts %>% dplyr::distinct(databaseId, databaseName)
- result <- result %>% dplyr::inner_join(databaseNames, by = "databaseId")
-
- return(result)
-}
-
-
-#' Returns data from cohort_relationships table of Cohort Diagnostics results data model
-#'
-#' @description
-#' Returns data from cohort_relationships table of Cohort Diagnostics results data model
-#'
-#' @template DataSource
-#'
-#' @template CohortIds
-#'
-#' @template ComparatorCohortIds
-#'
-#' @template DatabaseIds
-#'
-#' @param startDays A vector of days in relation to cohort_start_date of target
-#'
-#' @param endDays A vector of days in relation to cohort_end_date of target
-#'
-#' @return
-#' Returns a data frame (tibble) with results that conform to cohort_relationships
-#' table in Cohort Diagnostics results data model.
-#'
-#' @export
-getResultsCohortRelationships <- function(dataSource,
- cohortIds = NULL,
- comparatorCohortIds = NULL,
- databaseIds = NULL,
- startDays = NULL,
- endDays = NULL) {
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = "SELECT cr.*, db.database_name
- FROM @results_database_schema.@table_name cr
- INNER JOIN @results_database_schema.@database_table db ON db.database_id = cr.database_id
- WHERE cr.cohort_id IN (@cohort_id)
- AND cr.database_id IN (@database_id)
- {@comparator_cohort_id != \"\"} ? { AND cr.comparator_cohort_id IN (@comparator_cohort_id)}
- {@start_day != \"\"} ? { AND cr.start_day IN (@start_day)}
- {@end_day != \"\"} ? { AND cr.end_day IN (@end_day)};",
- snakeCaseToCamelCase = TRUE,
- results_database_schema = dataSource$resultsDatabaseSchema,
- database_id = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("cohort_relationships"),
- database_table = dataSource$databaseTableName,
- cohort_id = cohortIds,
- comparator_cohort_id = comparatorCohortIds,
- start_day = startDays,
- end_day = endDays
- ) %>%
- dplyr::tibble()
-
- return(data)
-}
-
-
-#' Returns cohort as feature characterization
-#'
-#' @description
-#' Returns a list object with covariateValue,
-#' covariateRef, analysisRef output of cohort as features.
-#'
-#' @template DataSource
-#'
-#' @template CohortIds
-#'
-#' @template DatabaseIds
-#'
-#' @return
-#' Returns a list object with covariateValue,
-#' covariateRef, analysisRef output of cohort as features. To avoid clash
-#' with covaraiteId and conceptId returned from Feature Extraction
-#' the output is a negative integer.
-#'
-#' @export
-getCohortRelationshipCharacterizationResults <-
- function(dataSource = .GlobalEnv,
- cohortIds = NULL,
- databaseIds = NULL) {
- cohortCounts <-
- getResultsCohortCounts(
- dataSource = dataSource,
- cohortIds = cohortIds,
- databaseIds = databaseIds
- )
- cohort <- getResultsCohort(dataSource = dataSource)
-
- cohortRelationships <-
- getResultsCohortRelationships(
- dataSource = dataSource,
- cohortIds = cohortIds,
- databaseIds = databaseIds
- )
-
- # cannot do records because comparator cohorts may have sumValue > target cohort (which is first occurrence only)
- # subjects overlap
- subjectsOverlap <- cohortRelationships %>%
- dplyr::inner_join(cohortCounts,
- by = c("cohortId", "databaseId")
- ) %>%
- dplyr::mutate(sumValue = subCeWindowT + subCsWindowT - subCWithinT) %>%
- dplyr::mutate(mean = sumValue / cohortSubjects) %>%
- dplyr::select(
- cohortId,
- comparatorCohortId,
- databaseId,
- startDay,
- endDay,
- mean,
- sumValue
- ) %>%
- dplyr::mutate(analysisId = -301)
-
- # subjects start
- subjectsStart <- cohortRelationships %>%
- dplyr::inner_join(cohortCounts,
- by = c("cohortId", "databaseId")
- ) %>%
- dplyr::mutate(sumValue = subCsWindowT) %>%
- dplyr::mutate(mean = sumValue / cohortSubjects) %>%
- dplyr::select(
- cohortId,
- comparatorCohortId,
- databaseId,
- startDay,
- endDay,
- mean,
- sumValue
- ) %>%
- dplyr::mutate(analysisId = -201)
-
- data <- dplyr::bind_rows(
- subjectsOverlap,
- subjectsStart
- ) %>%
- dplyr::filter(comparatorCohortId > 0) %>%
- dplyr::mutate(covariateId = (comparatorCohortId * -1000) + analysisId)
-
- # suppressing warning because of - negative causing NaN values
- data <- suppressWarnings(expr = {
- data %>%
- dplyr::mutate(sd = sqrt(mean * (1 - mean)))
- }, classes = "warning")
-
- temporalTimeRefFull <-
- getResultsTemporalTimeRef(dataSource = dataSource)
-
- temporalTimeRef <- data %>%
- dplyr::select(
- startDay,
- endDay
- ) %>%
- dplyr::distinct() %>%
- dplyr::inner_join(temporalTimeRefFull,
- by = c(
- "startDay",
- "endDay"
- )
- )
-
- analysisRef <-
- dplyr::tibble(
- analysisId = c(-201, -301),
- analysisName = c("CohortEraStart", "CohortEraOverlap"),
- domainId = "Cohort",
- isBinary = "Y",
- missingMeansZero = "Y"
- ) %>%
- dplyr::inner_join(data %>%
- dplyr::select(analysisId) %>%
- dplyr::distinct(),
- by = c("analysisId")
- )
- covariateRef <- tidyr::crossing(
- cohort,
- analysisRef %>%
- dplyr::select(
- analysisId,
- analysisName
- )
- ) %>%
- dplyr::mutate(covariateId = (cohortId * -1000) + analysisId) %>%
- dplyr::inner_join(data %>% dplyr::select(covariateId) %>% dplyr::distinct(),
- by = "covariateId"
- ) %>%
- dplyr::mutate(covariateName = paste0(
- analysisName,
- ": (",
- cohortId,
- ") ",
- cohortName
- )) %>%
- dplyr::mutate(conceptId = cohortId * -1) %>%
- dplyr::arrange(covariateId) %>%
- dplyr::select(
- analysisId,
- conceptId,
- covariateId,
- covariateName
- )
- concept <- cohort %>%
- dplyr::filter(cohortId %in% c(data$comparatorCohortId %>% unique())) %>%
- dplyr::mutate(
- conceptId = cohortId * -1,
- conceptName = cohortName,
- domainId = "Cohort",
- vocabularyId = "Cohort",
- conceptClassId = "Cohort",
- standardConcept = "S",
- conceptCode = as.character(cohortId),
- validStartDate = as.Date("2002-01-31"),
- validEndDate = as.Date("2099-12-31"),
- invalidReason = as.character(NA)
- ) %>%
- dplyr::select(
- conceptId,
- conceptName,
- domainId,
- vocabularyId,
- conceptClassId,
- standardConcept,
- conceptCode,
- validStartDate,
- validEndDate,
- invalidReason
- ) %>%
- dplyr::arrange(conceptId)
-
- covariateValue <- data %>%
- dplyr::select(
- cohortId,
- covariateId,
- databaseId,
- startDay,
- endDay,
- mean,
- sd,
- sumValue
- )
-
- data <- list(
- temporalCovariateRef = covariateRef,
- temporalCovariateValue = covariateValue,
- temporalCovariateValueDist = NULL,
- temporalAnalysisRef = analysisRef,
- concept = concept
- )
- return(data)
- }
-
-
-# Cohort ----
-#' Returns data from cohort table of Cohort Diagnostics results data model
-#'
-#' @description
-#' Returns data from cohort table of Cohort Diagnostics results data model
-#'
-#' @template DataSource
-#'
-#' @template CohortIds
-#'
-#' @return
-#' Returns a data frame (tibble)
-#'
-#' @export
-getResultsCohort <- function(dataSource, cohortIds = NULL) {
- data <- renderTranslateQuerySql(
- connection = dataSource$connection,
- results_database_schema = dataSource$resultsDatabaseSchema,
- dbms = dataSource$dbms,
- sql = "SELECT * FROM @results_database_schema.@table_name
- {@cohort_id != \"\"} ? { WHERE cohort_id IN (@cohort_id)};",
- cohort_id = cohortIds,
- table_name = dataSource$cohortTableName,
- snakeCaseToCamelCase = TRUE
- )
- return(data)
-}
-
-
-# not exported
-getResultsCovariateRef <- function(dataSource,
- covariateIds = NULL) {
- sql <- "SELECT *
- FROM @results_database_schema.@table_name
- {@covariate_ids == ''} ? { WHERE covariate_id IN (@covariate_ids)}
- ;"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- covariate_id = covariateIds,
- table_name = dataSource$prefixTable("covariate_ref"),
- snakeCaseToCamelCase = TRUE
- )
-
- if (!hasData(data)) {
- return(NULL)
- }
- return(data)
-}
-
-# not exported
-getResultsTemporalCovariateRef <- function(dataSource,
- covariateIds = NULL) {
- sql <- "SELECT *
- FROM @results_database_schema.@table_name
- {@covariate_ids == ''} ? { WHERE covariate_id IN (@covariate_ids)};"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- table_name = dataSource$prefixTable("temporal_time_ref"),
- covariate_id = covariateIds,
- snakeCaseToCamelCase = TRUE
- )
-
- if (!hasData(data)) {
- return(NULL)
- }
- return(data)
-}
-
-# not exported
-getResultsTemporalTimeRef <- function(dataSource) {
- sql <- "SELECT *
- FROM @results_database_schema.@table_name;"
- temporalTimeRef <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- table_name = dataSource$prefixTable("temporal_time_ref"),
- snakeCaseToCamelCase = TRUE
- )
-
- if (nrow(temporalTimeRef) == 0) {
- return(NULL)
- }
-
- temporalChoices <- temporalTimeRef %>%
- dplyr::mutate(temporalChoices = paste0("T (", startDay, "d to ", endDay, "d)")) %>%
- dplyr::arrange(startDay, endDay) %>%
- dplyr::select(
- timeId,
- startDay,
- endDay,
- temporalChoices
- ) %>%
- dplyr::mutate(primaryTimeId = dplyr::if_else(
- condition = (
- (startDay == -365 & endDay == -31) |
- (startDay == -30 & endDay == -1) |
- (startDay == 0 & endDay == 0) |
- (startDay == 1 & endDay == 30) |
- (startDay == 31 & endDay == 365) |
- (startDay == -365 & endDay == 0) |
- (startDay == -30 & endDay == 0)
- ),
- true = 1,
- false = 0
- )) %>%
- dplyr::mutate(isTemporal = dplyr::if_else(
- condition = (
- (endDay == 0 & startDay == -30) |
- (endDay == 0 & startDay == -180) |
- (endDay == 0 & startDay == -365) |
- (endDay == 0 & startDay == -9999)
- ),
- true = 0,
- false = 1
- )) %>%
- dplyr::arrange(startDay, timeId, endDay)
-
- temporalChoices <- dplyr::bind_rows(
- temporalChoices %>% dplyr::slice(0),
- dplyr::tibble(
- timeId = -1,
- temporalChoices = "Time invariant",
- primaryTimeId = 1,
- isTemporal = 0
- ),
- temporalChoices
- ) %>%
- dplyr::mutate(sequence = dplyr::row_number())
-
- return(temporalChoices)
-}
-
-
-# not exported
-getResultsAnalysisRef <- function(dataSource) {
- dataTableName <- "analysisRef"
- sql <- "SELECT *
- FROM @results_database_schema.@table_name;"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- table_name = dataSource$prefixTable("analysis_ref"),
- snakeCaseToCamelCase = TRUE
- )
- if (nrow(data) == 0) {
- return(NULL)
- }
- return(data)
-}
-
-
-# not exported
-getResultsTemporalAnalysisRef <- function(dataSource) {
- sql <- "SELECT *
- FROM @results_database_schema.@table_name;"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- table_name = dataSource$prefixTable("temporal_analysis_ref"),
- snakeCaseToCamelCase = TRUE
- )
- if (nrow(data) == 0) {
- return(NULL)
- }
- return(data)
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/Results.R b/inst/shiny/DiagnosticsExplorer/R/Results.R
deleted file mode 100644
index fe2e2f8fe..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/Results.R
+++ /dev/null
@@ -1,1011 +0,0 @@
-renderTranslateExecuteSql <- function(dataSource, sql, ...) {
- if (is(dataSource$connection, "Pool")) {
- sql <- SqlRender::render(sql, ...)
- sqlFinal <- SqlRender::translate(sql, targetDialect = dataSource$dbms)
- DatabaseConnector::dbExecute(dataSource$connection, sqlFinal)
- } else {
- DatabaseConnector::renderTranslateExecuteSql(
- connection = dataSource$connection,
- sql = sql,
- ...
- )
- }
-}
-
-getResultsCohortCounts <- function(dataSource,
- cohortIds = NULL,
- databaseIds = NULL) {
- sql <- "SELECT cc.*, db.database_name
- FROM @results_database_schema.@table_name cc
- INNER JOIN @results_database_schema.@database_table db ON db.database_id = cc.database_id
- WHERE cc.cohort_id IS NOT NULL
- {@use_database_ids} ? { AND cc.database_id in (@database_ids)}
- {@cohort_ids != ''} ? { AND cc.cohort_id in (@cohort_ids)}
- ;"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- cohort_ids = cohortIds,
- use_database_ids = !is.null(databaseIds),
- database_ids = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("cohort_count"),
- database_table = dataSource$databaseTableName,
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- return(data)
-}
-
-#' Global ranges for IR values
-getIncidenceRateRanges <- function(dataSource, minPersonYears = 0) {
- sql <- "SELECT DISTINCT age_group FROM @results_database_schema.@ir_table WHERE person_years >= @person_years"
-
- ageGroups <- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- ir_table = dataSource$prefixTable("incidence_rate"),
- person_years = minPersonYears,
- snakeCaseToCamelCase = TRUE
- ) %>%
- dplyr::mutate(ageGroup = dplyr::na_if(ageGroup, ""))
-
- sql <- "SELECT DISTINCT calendar_year FROM @results_database_schema.@ir_table WHERE person_years >= @person_years"
-
- calendarYear <- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- ir_table = dataSource$prefixTable("incidence_rate"),
- person_years = minPersonYears,
- snakeCaseToCamelCase = TRUE
- ) %>%
- dplyr::mutate(
- calendarYear = dplyr::na_if(calendarYear, "")
- ) %>%
- dplyr::mutate(calendarYear = as.integer(calendarYear))
-
- sql <- "SELECT DISTINCT gender FROM @results_database_schema.@ir_table WHERE person_years >= @person_years"
-
- gender <- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- ir_table = dataSource$prefixTable("incidence_rate"),
- person_years = minPersonYears,
- snakeCaseToCamelCase = TRUE
- ) %>%
- dplyr::mutate(gender = dplyr::na_if(gender, ""))
-
-
- sql <- "SELECT
- min(incidence_rate) as min_ir,
- max(incidence_rate) as max_ir
- FROM @results_database_schema.@ir_table
- WHERE person_years >= @person_years
- AND incidence_rate > 0.0
- "
-
- incidenceRate <- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- ir_table = dataSource$prefixTable("incidence_rate"),
- person_years = minPersonYears,
- snakeCaseToCamelCase = TRUE
- )
-
- return(list(gender = gender,
- incidenceRate = incidenceRate,
- calendarYear = calendarYear,
- ageGroups = ageGroups))
-}
-
-
-getIncidenceRateResult <- function(dataSource,
- cohortIds,
- databaseIds,
- stratifyByGender = c(TRUE, FALSE),
- stratifyByAgeGroup = c(TRUE, FALSE),
- stratifyByCalendarYear = c(TRUE, FALSE),
- minPersonYears = 1000,
- minSubjectCount = NA) {
- # Perform error checks for input variables
- errorMessage <- checkmate::makeAssertCollection()
- errorMessage <-
- checkErrorCohortIdsDatabaseIds(
- cohortIds = cohortIds,
- databaseIds = databaseIds,
- errorMessage = errorMessage
- )
- checkmate::assertLogical(
- x = stratifyByGender,
- add = errorMessage,
- min.len = 1,
- max.len = 2,
- unique = TRUE
- )
- checkmate::assertLogical(
- x = stratifyByAgeGroup,
- add = errorMessage,
- min.len = 1,
- max.len = 2,
- unique = TRUE
- )
- checkmate::assertLogical(
- x = stratifyByCalendarYear,
- add = errorMessage,
- min.len = 1,
- max.len = 2,
- unique = TRUE
- )
- checkmate::reportAssertions(collection = errorMessage)
-
- sql <- "SELECT ir.*, dt.database_name, cc.cohort_subjects
- FROM @results_database_schema.@ir_table ir
- INNER JOIN @results_database_schema.@database_table dt ON ir.database_id = dt.database_id
- INNER JOIN @results_database_schema.@cc_table cc ON (
- ir.database_id = cc.database_id AND ir.cohort_id = cc.cohort_id
- )
- WHERE ir.cohort_id in (@cohort_ids)
- AND ir.database_id in (@database_ids)
- {@gender == TRUE} ? {AND ir.gender != ''} : { AND ir.gender = ''}
- {@age_group == TRUE} ? {AND ir.age_group != ''} : { AND ir.age_group = ''}
- {@calendar_year == TRUE} ? {AND ir.calendar_year != ''} : { AND ir.calendar_year = ''}
- AND ir.person_years > @personYears;"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- cohort_ids = cohortIds,
- database_ids = quoteLiterals(databaseIds),
- gender = stratifyByGender,
- age_group = stratifyByAgeGroup,
- calendar_year = stratifyByCalendarYear,
- personYears = minPersonYears,
- ir_table = dataSource$prefixTable("incidence_rate"),
- cc_table = dataSource$prefixTable("cohort_count"),
- database_table = dataSource$databaseTableName,
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- data <- data %>%
- dplyr::mutate(
- gender = dplyr::na_if(gender, ""),
- ageGroup = dplyr::na_if(ageGroup, ""),
- calendarYear = dplyr::na_if(calendarYear, "")
- ) %>%
- dplyr::mutate(calendarYear = as.integer(calendarYear)) %>%
- dplyr::arrange(cohortId, databaseId)
-
-
- if (!is.na(minSubjectCount)) {
- data <- data %>%
- dplyr::filter(cohortSubjects > !!minSubjectCount)
- }
-
- return(data)
-}
-
-# modeId = 0 -- Events
-# modeId = 1 -- Persons
-getInclusionRuleStats <- function(dataSource,
- cohortIds = NULL,
- databaseIds,
- modeId = 1) {
- sql <- "SELECT *
- FROM @resultsDatabaseSchema.@table_name
- WHERE database_id in (@database_id)
- {@cohort_ids != ''} ? { AND cohort_id in (@cohort_ids)}
- ;"
-
- inclusion <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- resultsDatabaseSchema = dataSource$resultsDatabaseSchema,
- cohort_ids = cohortIds,
- database_id = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("cohort_inclusion"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- inclusionResults <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- resultsDatabaseSchema = dataSource$resultsDatabaseSchema,
- cohort_ids = cohortIds,
- database_id = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("cohort_inc_result"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- inclusionStats <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- resultsDatabaseSchema = dataSource$resultsDatabaseSchema,
- cohort_ids = cohortIds,
- database_id = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("cohort_inc_stats"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
-
- if (!hasData(inclusion) || !hasData(inclusionStats)) {
- return(NULL)
- }
-
- result <- inclusion %>%
- dplyr::select(cohortId, databaseId, ruleSequence, name) %>%
- dplyr::distinct() %>%
- dplyr::left_join(
- inclusionStats %>%
- dplyr::filter(modeId == !!modeId) %>%
- dplyr::select(
- cohortId,
- databaseId,
- ruleSequence,
- personCount,
- gainCount,
- personTotal
- ),
- by = c("cohortId", "databaseId", "ruleSequence")
- ) %>%
- dplyr::arrange(cohortId,
- databaseId,
- ruleSequence) %>%
- dplyr::mutate(remain = 0)
-
- inclusionResults <- inclusionResults %>%
- dplyr::filter(modeId == !!modeId)
-
- combis <- result %>%
- dplyr::select(cohortId,
- databaseId) %>%
- dplyr::distinct()
-
- resultFinal <- c()
- for (j in (1:nrow(combis))) {
- combi <- combis[j,]
- data <- result %>%
- dplyr::inner_join(combi,
- by = c("cohortId", "databaseId"))
-
- inclusionResult <- inclusionResults %>%
- dplyr::inner_join(combi,
- by = c("cohortId", "databaseId"))
- mask <- 0
- for (ruleId in (0:(nrow(data) - 1))) {
- mask <- bitwOr(mask, 2^ruleId) #bitwise OR operation: if both are 0, then 0; else 1
- idx <-
- bitwAnd(inclusionResult$inclusionRuleMask, mask) == mask
- data$remain[data$ruleSequence == ruleId] <-
- sum(inclusionResult$personCount[idx])
- }
- resultFinal[[j]] <- data
- }
- resultFinal <- dplyr::bind_rows(resultFinal) %>%
- dplyr::rename(
- "meetSubjects" = personCount,
- "gainSubjects" = gainCount,
- "remainSubjects" = remain,
- "totalSubjects" = personTotal,
- "ruleName" = name,
- "ruleSequenceId" = ruleSequence
- ) %>%
- dplyr::select(
- cohortId,
- ruleSequenceId,
- ruleName,
- meetSubjects,
- gainSubjects,
- remainSubjects,
- totalSubjects,
- databaseId
- )
- return(resultFinal)
-}
-
-
-getIndexEventBreakdown <- function(dataSource,
- cohortIds,
- databaseIds) {
- errorMessage <- checkmate::makeAssertCollection()
- errorMessage <-
- checkErrorCohortIdsDatabaseIds(
- cohortIds = cohortIds,
- databaseIds = databaseIds,
- errorMessage = errorMessage
- )
- checkmate::reportAssertions(collection = errorMessage)
-
- sql <- "SELECT index_event_breakdown.*,
- concept.concept_name,
- concept.domain_id,
- concept.vocabulary_id,
- concept.standard_concept,
- concept.concept_code
- FROM @results_database_schema.@table_name index_event_breakdown
- INNER JOIN @vocabulary_database_schema.@concept_table concept
- ON index_event_breakdown.concept_id = concept.concept_id
- WHERE database_id in (@database_id)
- AND cohort_id in (@cohort_ids);"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- vocabulary_database_schema = dataSource$vocabularyDatabaseSchema,
- cohort_ids = cohortIds,
- database_id = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("index_event_breakdown"),
- concept_table = dataSource$prefixVocabTable("concept"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
-
- data <- data %>%
- dplyr::inner_join(cohortCount,
- by = c("databaseId", "cohortId")
- ) %>%
- dplyr::mutate(
- subjectPercent = subjectCount / cohortSubjects,
- conceptPercent = conceptCount / cohortEntries
- )
-
- return(data)
-}
-
-getVisitContextResults <- function(dataSource,
- cohortIds,
- databaseIds) {
- errorMessage <- checkmate::makeAssertCollection()
- errorMessage <-
- checkErrorCohortIdsDatabaseIds(
- cohortIds = cohortIds,
- databaseIds = databaseIds,
- errorMessage = errorMessage
- )
- checkmate::reportAssertions(collection = errorMessage)
-
- sql <- "SELECT visit_context.*,
- standard_concept.concept_name AS visit_concept_name
- FROM @results_database_schema.@table_name visit_context
- INNER JOIN @vocabulary_database_schema.@concept_table standard_concept
- ON visit_context.visit_concept_id = standard_concept.concept_id
- WHERE database_id in (@database_id)
- AND cohort_id in (@cohort_ids);"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- vocabulary_database_schema = dataSource$vocabularyDatabaseSchema,
- cohort_ids = cohortIds,
- database_id = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("visit_context"),
- concept_table = dataSource$prefixVocabTable("concept"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- data <- data %>%
- dplyr::inner_join(cohortCount,
- by = c("cohortId", "databaseId")
- ) %>%
- dplyr::mutate(subjectPercent = subjects / cohortSubjects)
- return(data)
-}
-
-getConceptsInCohort <-
- function(dataSource,
- cohortId,
- databaseIds) {
- sql <- "SELECT concepts.*,
- c.concept_name,
- c.vocabulary_id,
- c.domain_id,
- c.standard_concept,
- c.concept_code
- FROM (
- SELECT isc.database_id,
- isc.cohort_id,
- isc.concept_id,
- 0 source_concept_id,
- max(concept_subjects) concept_subjects,
- sum(concept_count) concept_count
- FROM @results_database_schema.@table_name isc
- WHERE isc.cohort_id = @cohort_id
- AND isc.database_id IN (@database_ids)
- GROUP BY isc.database_id,
- isc.cohort_id,
- isc.concept_id
-
- UNION
-
- SELECT c.database_id,
- c.cohort_id,
- c.source_concept_id as concept_id,
- 1 source_concept_id,
- max(c.concept_subjects) concept_subjects,
- sum(c.concept_count) concept_count
- FROM @results_database_schema.@table_name c
- WHERE c.cohort_id = @cohort_id
- AND c.database_id IN (@database_ids)
- GROUP BY
- c.database_id,
- c.cohort_id,
- c.source_concept_id
- ) concepts
- INNER JOIN @results_database_schema.@concept_table c ON concepts.concept_id = c.concept_id
- WHERE c.invalid_reason IS NULL;"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- cohort_id = cohortId,
- database_ids = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("included_source_concept"),
- concept_table = dataSource$prefixTable("concept"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
- return(data)
- }
-
-
-getCountForConceptIdInCohort <-
- function(dataSource,
- cohortId,
- databaseIds) {
- sql <- "SELECT ics.*
- FROM @results_database_schema.@table_name ics
- WHERE ics.cohort_id = @cohort_id
- AND database_id in (@database_ids);"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- cohort_id = cohortId,
- database_ids = quoteLiterals(databaseIds),
- table_name = dataSource$prefixTable("included_source_concept"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- standardConceptId <- data %>%
- dplyr::select(
- databaseId,
- conceptId,
- conceptSubjects,
- conceptCount
- ) %>%
- dplyr::group_by(
- databaseId,
- conceptId
- ) %>%
- dplyr::summarise(
- conceptSubjects = max(conceptSubjects),
- conceptCount = sum(conceptCount),
- .groups = "keep"
- ) %>%
- dplyr::ungroup()
-
-
- sourceConceptId <- data %>%
- dplyr::select(
- databaseId,
- sourceConceptId,
- conceptSubjects,
- conceptCount
- ) %>%
- dplyr::rename(conceptId = sourceConceptId) %>%
- dplyr::group_by(
- databaseId,
- conceptId
- ) %>%
- dplyr::summarise(
- conceptSubjects = max(conceptSubjects),
- conceptCount = sum(conceptCount),
- .groups = "keep"
- ) %>%
- dplyr::ungroup()
-
- data <- dplyr::bind_rows(
- standardConceptId,
- sourceConceptId %>%
- dplyr::anti_join(
- y = standardConceptId %>%
- dplyr::select(databaseId, conceptId),
- by = c("databaseId", "conceptId")
- )
- ) %>%
- dplyr::distinct() %>%
- dplyr::arrange(databaseId, conceptId)
-
- return(data)
- }
-
-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 @results_database_schema.@orphan_table_name oc
- INNER JOIN @results_database_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 <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- 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)
-}
-
-resolveMappedConceptSetFromVocabularyDatabaseSchema <-
- function(dataSource,
- conceptSets,
- vocabularyDatabaseSchema = "vocabulary") {
- sqlBase <-
- paste(
- "SELECT DISTINCT codeset_id AS concept_set_id, concept.*",
- "FROM (",
- paste(conceptSets$conceptSetSql, collapse = ("\nUNION ALL\n")),
- ") concept_sets",
- sep = "\n"
- )
- sqlResolved <- paste(
- sqlBase,
- "INNER JOIN @vocabulary_database_schema.@concept",
- " ON concept_sets.concept_id = concept.concept_id;",
- sep = "\n"
- )
-
- sqlBaseMapped <-
- paste(
- "SELECT DISTINCT codeset_id AS concept_set_id,
- concept_sets.concept_id AS resolved_concept_id,
- concept.*",
- "FROM (",
- paste(conceptSets$conceptSetSql, collapse = ("\nUNION ALL\n")),
- ") concept_sets",
- sep = "\n"
- )
- sqlMapped <- paste(
- sqlBaseMapped,
- "INNER JOIN @vocabulary_database_schema.@concept_relationship",
- " ON concept_sets.concept_id = concept_relationship.concept_id_2",
- "INNER JOIN @vocabulary_database_schema.@concept",
- " ON concept_relationship.concept_id_1 = concept.concept_id",
- "WHERE relationship_id = 'Maps to'",
- " AND standard_concept IS NULL;",
- sep = "\n"
- )
-
- resolved <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sqlResolved,
- vocabulary_database_schema = vocabularyDatabaseSchema,
- concept = dataSource$prefixVocabTable("concept"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble() %>%
- dplyr::select(
- conceptSetId,
- conceptId,
- conceptName,
- domainId,
- vocabularyId,
- conceptClassId,
- standardConcept,
- conceptCode,
- invalidReason
- ) %>%
- dplyr::arrange(conceptId)
- mapped <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sqlMapped,
- vocabulary_database_schema = vocabularyDatabaseSchema,
- concept = dataSource$prefixVocabTable("concept"),
- concept_relationship = dataSource$prefixVocabTable("concept_relationship"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble() %>%
- dplyr::select(
- resolvedConceptId,
- conceptId,
- conceptName,
- domainId,
- vocabularyId,
- conceptClassId,
- standardConcept,
- conceptCode,
- conceptSetId
- ) %>%
- dplyr::distinct() %>%
- dplyr::arrange(resolvedConceptId, conceptId)
-
- data <- list(resolved = resolved, mapped = mapped)
- return(data)
- }
-
-
-resolvedConceptSet <- function(dataSource,
- databaseIds,
- cohortId,
- conceptSetId = NULL) {
- sqlResolved <- "SELECT DISTINCT rc.cohort_id,
- rc.concept_set_id,
- c.concept_id,
- c.concept_name,
- c.domain_id,
- c.vocabulary_id,
- c.concept_class_id,
- c.standard_concept,
- c.concept_code,
- rc.database_id
- FROM @results_database_schema.@resolved_concepts_table rc
- LEFT JOIN @results_database_schema.@concept_table c
- ON rc.concept_id = c.concept_id
- WHERE rc.database_id IN (@database_ids)
- AND rc.cohort_id = @cohortId
- {@concept_set_id != \"\"} ? { AND rc.concept_set_id IN (@concept_set_id)}
- ORDER BY c.concept_id;"
- resolved <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sqlResolved,
- results_database_schema = dataSource$resultsDatabaseSchema,
- database_ids = quoteLiterals(databaseIds),
- cohortId = cohortId,
- concept_set_id = conceptSetId,
- resolved_concepts_table = dataSource$prefixTable("resolved_concepts"),
- concept_table = dataSource$prefixTable("concept"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble() %>%
- dplyr::arrange(conceptId)
-
- return(resolved)
-}
-
-getMappedStandardConcepts <-
- function(dataSource,
- conceptIds) {
- sql <-
- "SELECT cr.CONCEPT_ID_2 AS SEARCHED_CONCEPT_ID,
- c.*
- FROM @results_database_schema.@concept_relationship cr
- JOIN @results_database_schema.@concept c ON c.concept_id = cr.concept_id_1
- WHERE cr.concept_id_2 IN (@concept_ids)
- AND cr.INVALID_REASON IS NULL
- AND relationship_id IN ('Mapped from');"
-
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- concept_ids = conceptIds,
- concept = dataSource$prefixTable("concept"),
- concept_relationship = dataSource$prefixTable("concept_relationship"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- return(data)
- }
-
-
-getMappedSourceConcepts <-
- function(dataSource,
- conceptIds) {
- sql <-
- "
- SELECT cr.CONCEPT_ID_2 AS SEARCHED_CONCEPT_ID,
- c.*
- FROM @results_database_schema.@concept_relationship cr
- JOIN @results_database_schema.@concept c ON c.concept_id = cr.concept_id_1
- WHERE cr.concept_id_2 IN (@concept_ids)
- AND cr.INVALID_REASON IS NULL
- AND relationship_id IN ('Maps to');"
-
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- concept_ids = conceptIds,
- concept = dataSource$prefixTable("concept"),
- concept_relationship = dataSource$prefixTable("concept_relationship"),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- return(data)
- }
-
-
-mappedConceptSet <- function(dataSource,
- databaseIds,
- cohortId) {
- sqlMapped <-
- "WITH resolved_concepts_mapped
- AS (
- SELECT concept_sets.concept_id AS resolved_concept_id,
- c1.concept_id,
- c1.concept_name,
- c1.domain_id,
- c1.vocabulary_id,
- c1.concept_class_id,
- c1.standard_concept,
- c1.concept_code
- FROM (
- SELECT DISTINCT concept_id
- FROM @results_database_schema.@resolved_concepts
- WHERE database_id IN (@databaseIds)
- AND cohort_id = @cohort_id
- ) concept_sets
- INNER JOIN @results_database_schema.@concept_relationship cr ON concept_sets.concept_id = cr.concept_id_2
- INNER JOIN @results_database_schema.@concept c1 ON cr.concept_id_1 = c1.concept_id
- WHERE relationship_id = 'Maps to'
- AND standard_concept IS NULL
- )
- SELECT
- c.database_id,
- c.cohort_id,
- c.concept_set_id,
- mapped.*
- FROM (SELECT DISTINCT concept_id, database_id, cohort_id, concept_set_id FROM @results_database_schema.@resolved_concepts) c
- INNER JOIN resolved_concepts_mapped mapped ON c.concept_id = mapped.resolved_concept_id
- {@cohort_id != ''} ? { WHERE c.cohort_id = @cohort_id};
- "
- mapped <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sqlMapped,
- results_database_schema = dataSource$resultsDatabaseSchema,
- databaseIds = quoteLiterals(databaseIds),
- concept = dataSource$prefixTable("concept"),
- concept_relationship = dataSource$prefixTable("concept_relationship"),
- resolved_concepts = dataSource$prefixTable("resolved_concepts"),
- cohort_id = cohortId,
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble() %>%
- dplyr::arrange(resolvedConceptId)
- return(mapped)
-}
-
-
-getDatabaseCounts <- function(dataSource,
- databaseIds) {
- sql <- "SELECT *
- FROM @results_database_schema.@database_table
- WHERE database_id in (@database_ids);"
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- results_database_schema = dataSource$resultsDatabaseSchema,
- database_ids = quoteLiterals(databaseIds),
- database_table = dataSource$databaseTableName,
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- return(data)
-}
-
-getMetaDataResults <- function(dataSource, databaseId) {
- sql <- "SELECT *
- FROM @results_database_schema.@metadata
- WHERE database_id = @database_id;"
-
- data <-
- renderTranslateQuerySql(
- connection = dataSource$connection,
- dbms = dataSource$dbms,
- sql = sql,
- metadata = dataSource$prefixTable("metadata"),
- results_database_schema = dataSource$resultsDatabaseSchema,
- database_id = quoteLiterals(databaseId),
- snakeCaseToCamelCase = TRUE
- ) %>%
- tidyr::tibble()
-
- return(data)
-}
-
-
-getExecutionMetadata <- function(dataSource, databaseId) {
- databaseMetadata <-
- getMetaDataResults(dataSource, databaseId)
-
- if (!hasData(databaseMetadata)) {
- return(NULL)
- }
- columnNames <-
- databaseMetadata$variableField %>%
- unique() %>%
- sort()
- columnNamesNoJson <-
- columnNames[stringr::str_detect(
- string = tolower(columnNames),
- pattern = "json",
- negate = TRUE
- )]
- columnNamesJson <-
- columnNames[stringr::str_detect(
- string = tolower(columnNames),
- pattern = "json",
- negate = FALSE
- )]
-
- transposeNonJsons <- databaseMetadata %>%
- dplyr::filter(variableField %in% c(columnNamesNoJson)) %>%
- dplyr::rename(name = "variableField") %>%
- dplyr::group_by(databaseId, startTime, name) %>%
- dplyr::summarise(
- valueField = max(valueField),
- .groups = "keep"
- ) %>%
- dplyr::ungroup() %>%
- tidyr::pivot_wider(
- names_from = name,
- values_from = valueField
- ) %>%
- dplyr::mutate(startTime = stringr::str_replace(
- string = startTime,
- pattern = "TM_",
- replacement = ""
- ))
-
- transposeNonJsons$startTime <-
- transposeNonJsons$startTime %>% lubridate::as_datetime()
-
- transposeJsons <- databaseMetadata %>%
- dplyr::filter(variableField %in% c(columnNamesJson)) %>%
- dplyr::rename(name = "variableField") %>%
- dplyr::group_by(databaseId, startTime, name) %>%
- dplyr::summarise(
- valueField = max(valueField),
- .groups = "keep"
- ) %>%
- dplyr::ungroup() %>%
- tidyr::pivot_wider(
- names_from = name,
- values_from = valueField
- ) %>%
- dplyr::mutate(startTime = stringr::str_replace(
- string = startTime,
- pattern = "TM_",
- replacement = ""
- ))
-
- transposeJsons$startTime <-
- transposeJsons$startTime %>% lubridate::as_datetime()
-
- transposeJsonsTemp <- list()
- for (i in (1:nrow(transposeJsons))) {
- transposeJsonsTemp[[i]] <- transposeJsons[i,]
- for (j in (1:length(columnNamesJson))) {
- transposeJsonsTemp[[i]][[columnNamesJson[[j]]]] <-
- transposeJsonsTemp[[i]][[columnNamesJson[[j]]]] %>%
- RJSONIO::fromJSON(digits = 23) %>%
- RJSONIO::toJSON(digits = 23, pretty = TRUE)
- }
- }
- transposeJsons <- dplyr::bind_rows(transposeJsonsTemp)
- data <- transposeNonJsons %>%
- dplyr::left_join(transposeJsons,
- by = c("databaseId", "startTime")
- )
- if ("observationPeriodMaxDate" %in% colnames(data)) {
- data$observationPeriodMaxDate <-
- tryCatch(
- expr = lubridate::as_date(data$observationPeriodMaxDate),
- error = data$observationPeriodMaxDate
- )
- }
- if ("observationPeriodMinDate" %in% colnames(data)) {
- data$observationPeriodMinDate <-
- tryCatch(
- expr = lubridate::as_date(data$observationPeriodMinDate),
- error = data$observationPeriodMinDate
- )
- }
- if ("sourceReleaseDate" %in% colnames(data)) {
- data$sourceReleaseDate <-
- tryCatch(
- expr = lubridate::as_date(data$sourceReleaseDate),
- error = data$sourceReleaseDate
- )
- }
- if ("personDaysInDatasource" %in% colnames(data)) {
- data$personDaysInDatasource <-
- tryCatch(
- expr = as.numeric(data$personDaysInDatasource),
- error = data$personDaysInDatasource
- )
- }
- if ("recordsInDatasource" %in% colnames(data)) {
- data$recordsInDatasource <-
- tryCatch(
- expr = as.numeric(data$recordsInDatasource),
- error = data$recordsInDatasource
- )
- }
- if ("personDaysInDatasource" %in% colnames(data)) {
- data$personDaysInDatasource <-
- tryCatch(
- expr = as.numeric(data$personDaysInDatasource),
- error = data$personDaysInDatasource
- )
- }
- if ("runTime" %in% colnames(data)) {
- data$runTime <-
- tryCatch(
- expr = round(as.numeric(data$runTime), digits = 1),
- error = data$runTime
- )
- }
- return(data)
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/Shared.R b/inst/shiny/DiagnosticsExplorer/R/Shared.R
deleted file mode 100644
index 2e1069a33..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/Shared.R
+++ /dev/null
@@ -1,37 +0,0 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
-#
-# This file is part of CohortDiagnostics
-#
-# 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.
-
-hasData <- function(data) {
- if (is.null(data)) {
- return(FALSE)
- }
- if (is.data.frame(data)) {
- if (nrow(data) == 0) {
- return(FALSE)
- }
- }
- if (!is.data.frame(data)) {
- if (length(data) == 0) {
- return(FALSE)
- }
- if (length(data) == 1) {
- if (is.na(data)) {
- return(FALSE)
- }
- }
- }
- return(TRUE)
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/StartUpScripts.R b/inst/shiny/DiagnosticsExplorer/R/StartUpScripts.R
deleted file mode 100644
index c569e26fa..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/StartUpScripts.R
+++ /dev/null
@@ -1,480 +0,0 @@
-# Copyright 2022 Observational Health Data Sciences and Informatics
-#
-# This file is part of CohortDiagnostics
-#
-# 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.
-
-
-loadResultsTable <- function(dataSource, tableName, required = FALSE, tablePrefix = "") {
- selectTableName <- paste0(tablePrefix, tableName)
-
- resultsTablesOnServer <-
- tolower(DatabaseConnector::dbListTables(dataSource$connection, schema = dataSource$resultsDatabaseSchema))
-
- if (required || selectTableName %in% resultsTablesOnServer) {
- if (tableIsEmpty(dataSource, selectTableName)) {
- return(NULL)
- }
-
- tryCatch(
- {
- table <- DatabaseConnector::dbReadTable(
- dataSource$connection,
- paste(dataSource$resultsDatabaseSchema, selectTableName, sep = ".")
- )
- },
- error = function(err) {
- stop(
- "Error reading from ",
- paste(dataSource$resultsDatabaseSchema, selectTableName, sep = "."),
- ": ",
- err$message
- )
- }
- )
- colnames(table) <-
- SqlRender::snakeCaseToCamelCase(colnames(table))
- if (nrow(table) > 0) {
- return(dplyr::as_tibble(table))
- }
- }
-
- return(NULL)
-}
-
-
-# Create empty objects in memory for all other tables. This is used by the Shiny app to decide what tabs to show:
-tableIsEmpty <- function(dataSource, tableName) {
- sql <- "SELECT * FROM @result_schema.@table LIMIT 1"
- row <- data.frame()
- tryCatch({
- row <- renderTranslateQuerySql(dataSource$connection,
- sql,
- dataSource$dbms,
- result_schema = dataSource$resultsDatabaseSchema,
- table = tableName)
- }, error = function(...) {
- message("Table not found: ", tableName)
- })
-
- return(nrow(row) == 0)
-}
-
-getTimeAsInteger <- function(time = Sys.time()) {
- return(floor(as.numeric(as.POSIXlt(time))))
-}
-
-getTimeFromInteger <- function(x) {
- originDate <- as.POSIXct("1970-01-01")
- originDate <- originDate + x
- return(originDate)
-}
-
-processMetadata <- function(data) {
- data <- data %>%
- tidyr::pivot_wider(
- id_cols = c(startTime, databaseId),
- names_from = variableField,
- values_from = valueField
- ) %>%
- dplyr::mutate(
- startTime = stringr::str_replace(
- string = startTime,
- pattern = stringr::fixed("TM_"),
- replacement = ""
- )
- ) %>%
- dplyr::mutate(startTime = paste0(startTime, " ", timeZone)) %>%
- dplyr::mutate(startTime = as.POSIXct(startTime)) %>%
- dplyr::group_by(
- databaseId,
- startTime
- ) %>%
- dplyr::arrange(databaseId, dplyr::desc(startTime), .by_group = TRUE) %>%
- dplyr::mutate(rn = dplyr::row_number()) %>%
- dplyr::filter(rn == 1) %>%
- dplyr::select(-timeZone)
-
- if ("runTime" %in% colnames(data)) {
- data$runTime <- round(x = as.numeric(data$runTime), digits = 2)
- }
- if ("observationPeriodMinDate" %in% colnames(data)) {
- data$observationPeriodMinDate <-
- as.Date(data$observationPeriodMinDate)
- }
- if ("observationPeriodMaxDate" %in% colnames(data)) {
- data$observationPeriodMaxDate <-
- as.Date(data$observationPeriodMaxDate)
- }
- if ("personsInDatasource" %in% colnames(data)) {
- data$personsInDatasource <- as.numeric(data$personsInDatasource)
- }
- if ("recordsInDatasource" %in% colnames(data)) {
- data$recordsInDatasource <- as.numeric(data$recordsInDatasource)
- }
- if ("personDaysInDatasource" %in% colnames(data)) {
- data$personDaysInDatasource <-
- as.numeric(data$personDaysInDatasource)
- }
- colnamesOfInterest <-
- c(
- "startTime",
- "databaseId",
- "runTime",
- "runTimeUnits",
- "sourceReleaseDate",
- "cdmVersion",
- "cdmReleaseDate",
- "observationPeriodMinDate",
- "observationPeriodMaxDate",
- "personsInDatasource",
- "recordsInDatasource",
- "personDaysInDatasource"
- )
-
- commonColNames <- intersect(colnames(data), colnamesOfInterest)
-
- data <- data %>%
- dplyr::select(dplyr::all_of(commonColNames))
- return(data)
-}
-
-checkErrorCohortIdsDatabaseIds <- function(errorMessage,
- cohortIds,
- databaseIds) {
- checkmate::assertNumeric(
- x = cohortIds,
- null.ok = FALSE,
- lower = 1,
- upper = 2^53,
- any.missing = FALSE,
- add = errorMessage
- )
- checkmate::assertCharacter(
- x = databaseIds,
- min.len = 1,
- any.missing = FALSE,
- unique = TRUE,
- add = errorMessage
- )
- checkmate::reportAssertions(collection = errorMessage)
- return(errorMessage)
-}
-
-quoteLiterals <- function(x) {
- if (is.null(x)) {
- return("")
- } else {
- return(paste0("'", paste(x, collapse = "', '"), "'"))
- }
-}
-
-getConnectionPool <- function(connectionDetails) {
- connectionPool <-
- pool::dbPool(
- drv = DatabaseConnector::DatabaseConnectorDriver(),
- dbms = connectionDetails$dbms,
- server = connectionDetails$server(),
- port = connectionDetails$port(),
- user = connectionDetails$user(),
- password = connectionDetails$password(),
- connectionString = connectionDetails$connectionString()
- )
-
- return(connectionPool)
-}
-
-loadShinySettings <- function(configPath) {
- stopifnot(file.exists(configPath))
- shinySettings <- yaml::read_yaml(configPath)
-
- defaultValues <- list(
- resultsDatabaseSchema = c("main"),
- vocabularyDatabaseSchemas = c("main"),
- enableAnnotation = TRUE,
- enableAuthorization = TRUE,
- userCredentialsFile = "UserCredentials.csv",
- tablePrefix = "",
- cohortTableName = "cohort",
- databaseTableName = "database",
- connectionEnvironmentVariables = NULL
- )
-
- for (key in names(defaultValues)) {
- if (is.null(shinySettings[[key]])) {
- shinySettings[[key]] <- defaultValues[[key]]
- }
- }
-
- if (shinySettings$cohortTableName == "cohort") {
- shinySettings$cohortTableName <- paste0(shinySettings$tablePrefix, shinySettings$cohortTableName)
- }
-
- if (shinySettings$databaseTableName == "database") {
- shinySettings$databaseTableName <- paste0(shinySettings$tablePrefix, shinySettings$databaseTableName)
- }
-
- if (!is.null(shinySettings$connectionDetailsSecureKey)) {
- shinySettings$connectionDetails <- jsonlite::fromJSON(keyring::key_get(shinySettings$connectionDetailsSecureKey))
- } else if(!is.null(shinySettings$connectionEnvironmentVariables$server)) {
-
- defaultValues <- list(
- dbms = "",
- user = "",
- password = "",
- port = "",
- extraSettings = ""
- )
-
- for (key in names(defaultValues)) {
- if (is.null(shinySettings$connectionEnvironmentVariables[[key]])) {
- shinySettings$connectionEnvironmentVariables[[key]] <- defaultValues[[key]]
- }
- }
-
- serverStr <- Sys.getenv(shinySettings$connectionEnvironmentVariables$server)
- if (!is.null(shinySettings$connectionEnvironmentVariables$database)) {
- serverStr <- paste0(serverStr, "/", Sys.getenv(shinySettings$connectionEnvironmentVariables$database))
- }
-
- shinySettings$connectionDetails <- list(
- dbms = Sys.getenv(shinySettings$connectionEnvironmentVariables$dbms, unset = shinySettings$connectionDetails$dbms),
- server = serverStr,
- user = Sys.getenv(shinySettings$connectionEnvironmentVariables$user),
- password = Sys.getenv(shinySettings$connectionEnvironmentVariables$password),
- port = Sys.getenv(shinySettings$connectionEnvironmentVariables$port, unset = shinySettings$connectionDetails$port),
- extraSettings = Sys.getenv(shinySettings$connectionEnvironmentVariables$extraSettings)
- )
- }
- shinySettings$connectionDetails <- do.call(DatabaseConnector::createConnectionDetails,
- shinySettings$connectionDetails)
-
- return(shinySettings)
-}
-
-createDatabaseDataSource <- function(connection,
- resultsDatabaseSchema,
- vocabularyDatabaseSchema = resultsDatabaseSchema,
- dbms,
- tablePrefix = "",
- cohortTableName = "cohort",
- databaseTableName = "database") {
- return(
- list(
- connection = connection,
- resultsDatabaseSchema = resultsDatabaseSchema,
- vocabularyDatabaseSchema = vocabularyDatabaseSchema,
- dbms = dbms,
- resultsTablesOnServer = tolower(DatabaseConnector::dbListTables(connection, schema = resultsDatabaseSchema)),
- tablePrefix = tablePrefix,
- prefixTable = function(tableName) { paste0(tablePrefix, tableName) },
- prefixVocabTable = function(tableName) {
- # don't prexfix table if we us a dedicated vocabulary schema
- if (vocabularyDatabaseSchema == resultsDatabaseSchema)
- return(paste0(tablePrefix, tableName))
-
- return(tableName)
- },
- cohortTableName = cohortTableName,
- databaseTableName = databaseTableName
- )
- )
-}
-
-#' Initialize variables required in applications global shared environment
-#' These settings are shared accross settings (e.g. accessed by all users) and should be read only during run time
-initializeEnvironment <- function(shinySettings,
- dataModelSpecificationsPath = "data/resultsDataModelSpecification.csv",
- envir = .GlobalEnv) {
- envir$shinySettings <- shinySettings
-
- envir$connectionPool <- getConnectionPool(envir$shinySettings$connectionDetails)
- shiny::onStop(function() {
- if (DBI::dbIsValid(envir$connectionPool)) {
- writeLines("Closing database pool")
- pool::poolClose(envir$connectionPool)
- }
- })
-
- envir$dataSource <-
- createDatabaseDataSource(
- connection = envir$connectionPool,
- resultsDatabaseSchema = envir$shinySettings$resultsDatabaseSchema,
- vocabularyDatabaseSchema = envir$
- shinySettings$
- vocabularyDatabaseSchemas,
- dbms = envir$shinySettings$connectionDetails$dbms,
- tablePrefix = envir$shinySettings$tablePrefix,
- cohortTableName = envir$shinySettings$cohortTableName,
- databaseTableName = envir$shinySettings$databaseTableName
- )
-
- envir$userCredentials <- data.frame()
- envir$enableAuthorization <- envir$shinySettings$enableAuthorization
- if (is.null(envir$enableAuthorization)) {
- envir$enableAuthorization <- FALSE
- }
-
- if (envir$enableAuthorization & !is.null(envir$shinySettings$userCredentialsFile)) {
- if (file.exists(envir$shinySettings$userCredentialsFile)) {
- envir$userCredentials <-
- readr::read_csv(file = envir$shinySettings$userCredentialsFile, col_types = readr::cols())
- }
- }
-
- envir$enableAnnotation <- envir$shinySettings$enableAnnotation
-
- if (nrow(envir$userCredentials) == 0) {
- envir$enableAuthorization <- FALSE
- }
-
- dataModelSpecifications <- read.csv(dataModelSpecificationsPath)
- envir$dataModelSpecifications <- dataModelSpecifications
- # Cleaning up any tables alreadu in memory:
- suppressWarnings(rm(
- list = SqlRender::snakeCaseToCamelCase(envir$dataModelSpecifications$tableName),
- envir = envir
- ))
-
- envir$database <- loadResultsTable(envir$dataSource, envir$dataSource$databaseTableName, required = TRUE)
- envir$cohort <- loadResultsTable(envir$dataSource, envir$dataSource$cohortTableName, required = TRUE)
- envir$metadata <- loadResultsTable(envir$dataSource, "metadata", required = TRUE, tablePrefix = envir$dataSource$tablePrefix)
- envir$temporalTimeRef <- loadResultsTable(envir$dataSource, "temporal_time_ref", tablePrefix = envir$dataSource$tablePrefix)
- envir$temporalAnalysisRef <- loadResultsTable(envir$dataSource, "temporal_analysis_ref", tablePrefix = envir$dataSource$tablePrefix)
- envir$conceptSets <- loadResultsTable(envir$dataSource, "concept_sets", tablePrefix = envir$dataSource$tablePrefix)
- envir$cohortCount <- loadResultsTable(envir$dataSource, "cohort_count", required = TRUE, tablePrefix = envir$dataSource$tablePrefix)
- envir$relationship <- loadResultsTable(envir$dataSource, "relationship", tablePrefix = envir$dataSource$tablePrefix)
-
-
- if (is.numeric(envir$database$databaseId)) {
- envir$metadata$databaseId <- as.numeric(envir$metadata$databaseId)
- }
-
- if (!is.null(envir$cohort)) {
- if ("cohortDefinitionId" %in% names(envir$cohort)) {
- envir$cohort <- envir$cohort %>% dplyr::mutate(cohortId = cohortDefinitionId)
-
- ## Note this is because the tables were labled wrong!
- envir$cohort <- envir$cohort %>% dplyr::mutate(cohortId = cohortDefinitionId,
- sql = json,
- json = sqlCommand)
- }
-
- envir$cohort <- envir$cohort %>%
- dplyr::arrange(cohortId) %>%
- dplyr::mutate(shortName = paste0("C", cohortId)) %>%
- dplyr::mutate(compoundName = paste0(shortName, ": ", cohortName))
- }
-
- if (!is.null(envir$database)) {
- if (nrow(envir$database) > 0 &
- "vocabularyVersion" %in% colnames(envir$database)) {
- envir$database <- envir$database %>%
- dplyr::mutate(
- databaseIdWithVocabularyVersion = paste0(databaseId, " (", vocabularyVersion, ")")
- )
- }
-
- envir$databaseMetadata <- processMetadata(envir$metadata)
- envir$databaseMetadata <- envir$database %>%
- dplyr::distinct() %>%
- dplyr::mutate(id = dplyr::row_number()) %>%
- dplyr::mutate(shortName = paste0("D", id)) %>%
- dplyr::left_join(envir$databaseMetadata,
- by = "databaseId"
- ) %>%
- dplyr::relocate(id, databaseId, shortName)
-
-
- if ("databaseName" %in% names(envir$database)) {
- envir$dbMapping <- envir$database %>%
- dplyr::select(databaseId, databaseName) %>%
- dplyr::distinct()
- } else {
- envir$dbMapping <- envir$database %>%
- dplyr::select(databaseId, cdmSourceName) %>%
- dplyr::distinct() %>%
- dplyr::mutate(databaseName = cdmSourceName)
- }
- }
-
- envir$temporalChoices <- NULL
- envir$temporalCharacterizationTimeIdChoices <- NULL
-
- if (!is.null(envir$temporalTimeRef)) {
- envir$temporalChoices <- getResultsTemporalTimeRef(dataSource = envir$dataSource)
- envir$temporalCharacterizationTimeIdChoices <- envir$temporalChoices %>%
- dplyr::arrange(sequence)
-
- envir$characterizationTimeIdChoices <- envir$temporalChoices %>%
- dplyr::filter(isTemporal == 0) %>%
- dplyr::filter(primaryTimeId == 1) %>%
- dplyr::arrange(sequence)
- }
-
- if (!is.null(envir$temporalAnalysisRef)) {
- envir$temporalAnalysisRef <- dplyr::bind_rows(
- envir$temporalAnalysisRef,
- dplyr::tibble(
- analysisId = c(-201, -301),
- analysisName = c("CohortEraStart", "CohortEraOverlap"),
- domainId = "Cohort",
- isBinary = "Y",
- missingMeansZero = "Y"
- )
- )
-
- envir$domainIdOptions <- envir$temporalAnalysisRef %>%
- dplyr::select(domainId) %>%
- dplyr::pull(domainId) %>%
- unique() %>%
- sort()
-
- envir$analysisNameOptions <- envir$temporalAnalysisRef %>%
- dplyr::select(analysisName) %>%
- dplyr::pull(analysisName) %>%
- unique() %>%
- sort()
- }
-
- envir$resultsTables <- tolower(DatabaseConnector::dbListTables(envir$dataSource$connection,
- schema = envir$dataSource$resultsDatabaseSchema))
- envir$enabledTabs <- c()
- for (table in envir$dataModelSpecifications$tableName %>% unique()) {
- if (envir$dataSource$prefixTable(table) %in% envir$resultsTables) {
- if (!tableIsEmpty(envir$dataSource, envir$dataSource$prefixTable(table))) {
- envir$enabledTabs <- c(envir$enabledTabs, SqlRender::snakeCaseToCamelCase(table))
- }
- }
- }
-
- if (!(envir$dataSource$cohortTableName %in% envir$resultsTables & envir$dataSource$databaseTableName %in% envir$resultsTables)) {
- stop(paste("cohort table:", envir$dataSource$cohortTableName, "and database table:", envir$dataSource$databaseTableName, "must be in results schema"))
- }
-
- envir$enabledTabs <- c(envir$enabledTabs, "database", "cohort")
-
- if (envir$enableAnnotation &
- "annotation" %in% envir$resultsTables &
- "annotation_link" %in% envir$resultsTables &
- "annotation_attributes" %in% envir$resultsTables) {
- envir$showAnnotation <- TRUE
- envir$enableAnnotation <- TRUE
- } else {
- envir$enableAnnotation <- FALSE
- envir$showAnnotation <- FALSE
- envir$enableAuthorization <- FALSE
- }
-
- return(envir)
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/Tables.R b/inst/shiny/DiagnosticsExplorer/R/Tables.R
deleted file mode 100644
index 269094219..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/Tables.R
+++ /dev/null
@@ -1,262 +0,0 @@
-library(magrittr)
-
-prepareTable1 <- function(covariates,
- prettyTable1Specifications,
- cohort) {
- if (!all(
- is.data.frame(prettyTable1Specifications),
- nrow(prettyTable1Specifications) > 0
- )) {
- return(NULL)
- }
- keyColumns <- prettyTable1Specifications %>%
- dplyr::select(
- labelOrder,
- label,
- covariateId,
- analysisId,
- sequence
- ) %>%
- dplyr::distinct() %>%
- dplyr::left_join(
- covariates %>%
- dplyr::select(
- covariateId,
- covariateName
- ) %>%
- dplyr::distinct(),
- by = c("covariateId")
- ) %>%
- dplyr::filter(!is.na(covariateName)) %>%
- tidyr::crossing(
- covariates %>%
- dplyr::select(
- cohortId,
- databaseId
- ) %>%
- dplyr::distinct()
- ) %>%
- dplyr::arrange(
- cohortId,
- databaseId,
- analysisId,
- covariateId
- ) %>%
- dplyr::mutate(
- covariateName = stringr::str_replace(
- string = covariateName,
- pattern = "black or african american",
- replacement = "Black or African American"
- )
- ) %>%
- dplyr::mutate(
- covariateName = stringr::str_replace(
- string = covariateName,
- pattern = "white",
- replacement = "White"
- )
- ) %>%
- dplyr::mutate(
- covariateName = stringr::str_replace(
- string = covariateName,
- pattern = "asian",
- replacement = "Asian"
- )
- )
-
- covariates <- keyColumns %>%
- dplyr::left_join(
- covariates %>%
- dplyr::select(-covariateName),
- by = c(
- "cohortId",
- "databaseId",
- "covariateId",
- "analysisId"
- )
- ) %>%
- dplyr::filter(!is.na(covariateName))
-
- space <- " "
- resultsTable <- tidyr::tibble()
-
- # labels
- tableHeaders <-
- covariates %>%
- dplyr::select(
- cohortId,
- databaseId,
- label,
- labelOrder,
- sequence
- ) %>%
- dplyr::distinct() %>%
- dplyr::group_by(
- cohortId,
- databaseId,
- label,
- labelOrder
- ) %>%
- dplyr::summarise(
- sequence = min(sequence),
- .groups = "keep"
- ) %>%
- dplyr::ungroup() %>%
- dplyr::mutate(
- characteristic = paste0(
- "",
- label,
- ""
- ),
- header = 1
- ) %>%
- dplyr::select(
- cohortId,
- databaseId,
- sequence,
- header,
- labelOrder,
- characteristic
- ) %>%
- dplyr::distinct()
-
- tableValues <-
- covariates %>%
- dplyr::mutate(
- characteristic = paste0(
- space,
- space,
- space,
- space,
- covariateName
- ),
- header = 0,
- valueCount = sumValue
- ) %>%
- dplyr::select(
- cohortId,
- databaseId,
- covariateId,
- analysisId,
- sequence,
- header,
- labelOrder,
- characteristic,
- valueCount
- )
-
- table <- dplyr::bind_rows(tableHeaders, tableValues) %>%
- dplyr::mutate(sequence = sequence - header) %>%
- dplyr::arrange(sequence) %>%
- dplyr::select(
- cohortId,
- databaseId,
- sequence,
- characteristic,
- valueCount
- ) %>%
- dplyr::rename(count = valueCount) %>%
- dplyr::inner_join(cohort %>%
- dplyr::select(
- cohortId,
- shortName
- ),
- by = "cohortId"
- ) %>%
- dplyr::group_by(
- databaseId,
- characteristic,
- shortName
- ) %>%
- dplyr::summarise(
- sequence = min(sequence),
- count = min(count),
- .groups = "keep"
- ) %>%
- dplyr::ungroup() %>%
- tidyr::pivot_wider(
- id_cols = c(
- databaseId,
- characteristic,
- sequence
- ),
- values_from = count,
- names_from = shortName
- ) %>%
- dplyr::arrange(sequence)
-
-
-
- if (nrow(table) == 0) {
- return(NULL)
- }
- return(table)
-}
-
-compareCohortCharacteristics <-
- function(characteristics1, characteristics2) {
- characteristics1Renamed <- characteristics1 %>%
- dplyr::rename(
- sumValue1 = sumValue,
- mean1 = mean,
- sd1 = sd,
- cohortId1 = cohortId
- )
- cohortId1Value <- characteristics1Renamed$cohortId1 %>% unique()
- if (length(cohortId1Value) > 1) {
- stop("Can only compare one target cohort id to one comparator cohort id")
- }
-
- characteristics2Renamed <- characteristics2 %>%
- dplyr::rename(
- sumValue2 = sumValue,
- mean2 = mean,
- sd2 = sd,
- cohortId2 = cohortId
- )
- cohortId2Value <- characteristics2Renamed$cohortId2 %>% unique()
- if (length(cohortId2Value) > 1) {
- stop("Can only compare one target cohort id to one comparator cohort id")
- }
-
- characteristics <- characteristics1Renamed %>%
- dplyr::full_join(
- characteristics2Renamed,
- na_matches = c("na"),
- by = c(
- "timeId",
- "startDay",
- "endDay",
- "temporalChoices",
- "analysisId",
- "covariateId",
- "covariateName",
- "isBinary",
- "conceptId",
- "analysisName",
- "domainId"
- )
- ) %>%
- dplyr::mutate(
- mean2 = ifelse(is.na(mean2), 0, mean2),
- sd2 = ifelse(is.na(sd2), 0, sd2),
- sd1 = ifelse(is.na(sd1), 0, sd1),
- mean1 = ifelse(is.na(mean1), 0, mean1),
- ) %>%
- dplyr::mutate(
- sdd = sqrt(sd1^2 + sd2^2)
- )
-
- characteristics$stdDiff <- (characteristics$mean1 - characteristics$mean2) / characteristics$sdd
-
- characteristics <- characteristics %>%
- dplyr::arrange(-abs(stdDiff)) %>%
- dplyr::mutate(stdDiff = dplyr::na_if(stdDiff, 0)) %>%
- dplyr::mutate(
- absStdDiff = abs(stdDiff),
- cohortId1 = !!cohortId1Value,
- cohortId2 = !!cohortId2Value,
- )
-
- return(characteristics)
- }
diff --git a/inst/shiny/DiagnosticsExplorer/R/TimeDistributionsModule.R b/inst/shiny/DiagnosticsExplorer/R/TimeDistributionsModule.R
deleted file mode 100644
index ad8c3155e..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/TimeDistributionsModule.R
+++ /dev/null
@@ -1,299 +0,0 @@
-plotTimeDistribution <- function(data, shortNameRef = NULL) {
- errorMessage <- checkmate::makeAssertCollection()
- checkmate::assertTibble(
- x = data,
- any.missing = FALSE,
- min.rows = 1,
- min.cols = 5,
- null.ok = FALSE,
- add = errorMessage
- )
- checkmate::assertNames(
- x = colnames(data),
- must.include = c(
- "minValue",
- "p25Value",
- "medianValue",
- "p75Value",
- "maxValue"
- ),
- add = errorMessage
- )
- checkmate::reportAssertions(collection = errorMessage)
-
- plotData <-
- addShortName(data = data, shortNameRef = shortNameRef)
-
- plotData$tooltip <- c(
- paste0(
- plotData$shortName,
- "\nDatabase = ",
- plotData$databaseId,
- "\nMin = ",
- scales::comma(plotData$minValue, accuracy = 1),
- "\nP25 = ",
- scales::comma(plotData$p25Value, accuracy = 1),
- "\nMedian = ",
- scales::comma(plotData$medianValue, accuracy = 1),
- "\nP75 = ",
- scales::comma(plotData$p75Value, accuracy = 1),
- "\nMax = ",
- scales::comma(plotData$maxValue, accuracy = 1),
- "\nTime Measure = ",
- plotData$timeMetric,
- "\nAverage = ",
- scales::comma(x = plotData$averageValue, accuracy = 0.01)
- )
- )
-
- sortShortName <- plotData %>%
- dplyr::select(shortName) %>%
- dplyr::distinct() %>%
- dplyr::arrange(-as.integer(sub(
- pattern = "^C", "", x = shortName
- )))
-
- plotData <- plotData %>%
- dplyr::arrange(
- shortName = factor(shortName, levels = sortShortName$shortName),
- shortName
- )
-
- plotData$shortName <- factor(plotData$shortName,
- levels = sortShortName$shortName
- )
-
- plot <- ggplot2::ggplot(data = plotData) +
- ggplot2::aes(
- x = shortName,
- ymin = minValue,
- lower = p25Value,
- middle = medianValue,
- upper = p75Value,
- ymax = maxValue,
- average = averageValue
- ) +
- ggplot2::geom_errorbar(size = 0.5) +
- ggiraph::geom_boxplot_interactive(
- ggplot2::aes(tooltip = tooltip),
- stat = "identity",
- fill = rgb(0, 0, 0.8, alpha = 0.25),
- size = 0.2
- ) +
- ggplot2::facet_grid(databaseName ~ timeMetric, scales = "free") +
- ggplot2::coord_flip() +
- ggplot2::theme(
- panel.grid.major.y = ggplot2::element_blank(),
- panel.grid.minor.y = ggplot2::element_blank(),
- axis.title.y = ggplot2::element_blank(),
- axis.ticks.y = ggplot2::element_blank(),
- strip.background = ggplot2::element_blank(),
- strip.text.y = ggplot2::element_text(size = 5)
- )
- height <-
- 1.5 + 0.4 * nrow(dplyr::distinct(plotData, databaseId, shortName))
- plot <- ggiraph::girafe(
- ggobj = plot,
- options = list(
- ggiraph::opts_sizing(width = .7),
- ggiraph::opts_zoom(max = 5)
- ),
- width_svg = 12,
- height_svg = height
- )
-}
-
-timeDistributionsView <- function(id) {
- ns <- shiny::NS(id)
- selectableCols <- c(
- "Average",
- "SD",
- "Min",
- "P10",
- "P25",
- "Median",
- "P75",
- "P90",
- "Max"
- )
-
- selectableTimeMeasures <- c(
- "observation time (days) prior to index",
- "observation time (days) after index",
- "time (days) between cohort start and end"
- )
-
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Time Distributions",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "timeDistribution.html"))
- ),
- shinydashboard::box(
- status = "warning",
- width = "100%",
- tags$div(
- style = "max-height: 100px; overflow-y: auto",
- shiny::uiOutput(outputId = ns("selectedCohorts"))
- )
- ),
- shinydashboard::box(
- title = "Time Distributions",
- width = NULL,
- status = "primary",
-
- shiny::fluidRow(
- shiny::column(
- width = 2,
- shiny::radioButtons(
- inputId = ns("timeDistributionType"),
- label = "",
- choices = c("Table", "Plot"),
- selected = "Plot",
- inline = TRUE
- )
- ),
- shiny::column(
- width = 5,
- shinyWidgets::pickerInput(
- label = "View Time Measures",
- inputId = ns("selecatableTimeMeasures"),
- multiple = TRUE,
- selected = selectableTimeMeasures,
- choices = selectableTimeMeasures,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- dropupAuto = TRUE,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- ),
- shiny::column(
- width = 5,
- shiny::conditionalPanel(
- condition = "input.timeDistributionType=='Table'",
- ns = ns,
- shinyWidgets::pickerInput(
- label = "View Columns",
- inputId = ns("selecatableCols"),
- multiple = TRUE,
- selected = selectableCols,
- choices = selectableCols,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- dropupAuto = TRUE,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
- )
- )
- )
- )
- ),
- shiny::conditionalPanel(
- condition = "input.timeDistributionType=='Table'",
- ns = ns,
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("timeDistributionTable"))),
- csvDownloadButton(ns, "timeDistributionTable")
- ),
- shiny::conditionalPanel(
- condition = "input.timeDistributionType=='Plot'",
- ns = ns,
- tags$br(),
- shinycssloaders::withSpinner(ggiraph::ggiraphOutput(ns("timeDistributionPlot"), width = "100%", height = "100%"))
- )
- )
- )
-}
-
-timeDistributionsModule <- function(id,
- dataSource,
- selectedCohorts,
- selectedDatabaseIds,
- cohortIds,
- cohortTable,
- databaseTable) {
- ns <- shiny::NS(id)
- shiny::moduleServer(id, function(input, output, session) {
- output$selectedCohorts <- shiny::renderUI({ selectedCohorts() })
-
- # Time distribution -----
- ## timeDistributionData -----
- timeDistributionData <- shiny::reactive({
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- validate(need(length(cohortIds()) > 0, "No cohorts chosen"))
-
- data <- getTimeDistributionResult(
- dataSource = dataSource,
- cohortIds = cohortIds(),
- databaseIds = selectedDatabaseIds(),
- databaseTable = databaseTable
- )
-
- if (hasData(data)) {
- data <- data %>% dplyr::filter(timeMetric %in% input$selecatableTimeMeasures)
- }
-
- return(data)
- })
-
- ## output: timeDistributionPlot -----
- output$timeDistributionPlot <- ggiraph::renderggiraph(expr = {
- data <- timeDistributionData()
- validate(need(hasData(data), "No data for this combination"))
- plot <- plotTimeDistribution(data = data, shortNameRef = cohortTable)
- return(plot)
- })
-
- ## output: timeDistributionTable -----
- output$timeDistributionTable <- reactable::renderReactable(expr = {
- data <- timeDistributionData()
- validate(need(hasData(data), "No data for this combination"))
-
- data <- data %>%
- dplyr::inner_join(cohortTable %>% dplyr::select(cohortName, cohortId), by = "cohortId") %>%
- dplyr::arrange(databaseId, cohortId) %>%
- dplyr::select(
- cohortId,
- Database = databaseName,
- Cohort = cohortName,
- TimeMeasure = timeMetric,
- Average = averageValue,
- SD = standardDeviation,
- Min = minValue,
- P10 = p10Value,
- P25 = p25Value,
- Median = medianValue,
- P75 = p75Value,
- P90 = p90Value,
- Max = maxValue
- ) %>%
- dplyr::select(all_of(c("Database", "cohortId", "Cohort", "TimeMeasure", input$selecatableCols)))
-
- validate(need(hasData(data), "No data for this combination"))
-
- keyColumns <- c(
- "Database",
- "cohortId",
- "Cohort",
- "TimeMeasure"
- )
- dataColumns <- input$selecatableCols
-
- table <- getDisplayTableSimple(
- data = data,
- keyColumns = keyColumns,
- dataColumns = dataColumns
- )
- return(table)
- })
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/R/VisitContextModule.R b/inst/shiny/DiagnosticsExplorer/R/VisitContextModule.R
deleted file mode 100644
index dfcc0d261..000000000
--- a/inst/shiny/DiagnosticsExplorer/R/VisitContextModule.R
+++ /dev/null
@@ -1,218 +0,0 @@
-visitContextView <- function(id) {
- ns <- shiny::NS(id)
- shiny::tagList(
- shinydashboard::box(
- collapsible = TRUE,
- collapsed = TRUE,
- title = "Visit Context",
- width = "100%",
- shiny::htmlTemplate(file.path("html", "visitContext.html"))
- ),
- shinydashboard::box(
- status = "warning",
- width = "100%",
- tags$div(
- style = "max-height: 100px; overflow-y: auto",
- shiny::uiOutput(outputId = ns("selectedCohorts"))
- )
- ),
- shinydashboard::box(
- width = NULL,
- title = NULL,
- tags$table(
- width = "100%",
- tags$tr(
- tags$td(
- shiny::radioButtons(
- inputId = ns("visitContextTableFilters"),
- label = "Display",
- choices = c("All", "Before", "During", "Simultaneous", "After"),
- selected = "All",
- inline = TRUE
- )
- ),
- tags$td(
- shiny::radioButtons(
- inputId = ns("visitContextPersonOrRecords"),
- label = "Display",
- choices = c("Persons", "Records"),
- selected = "Persons",
- inline = TRUE
- )
- ),
- tags$td(
- align = "right"
- )
- )
- ),
- shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("visitContextTable"))),
- csvDownloadButton(ns, "visitContextTable")
- )
- )
-}
-
-
-visitContextModule <- function(id,
- dataSource,
- selectedCohort, #this is selectedCohorts in other modules
- selectedDatabaseIds,
- targetCohortId,
- cohortTable,
- databaseTable) {
- ns <- shiny::NS(id)
- shiny::moduleServer(id, function(input, output, session) {
- output$selectedCohorts <- shiny::renderUI(selectedCohort())
-
- # Visit Context ----------------------------------------
- getVisitContextData <- shiny::reactive(x = {
- if (!hasData(selectedDatabaseIds())) {
- return(NULL)
- }
- if (all(is(dataSource, "environment"), !exists("visitContext"))) {
- return(NULL)
- }
- visitContext <-
- getVisitContextResults(
- dataSource = dataSource,
- cohortIds = targetCohortId(),
- databaseIds = selectedDatabaseIds()
- )
- if (!hasData(visitContext)) {
- return(NULL)
- }
- return(visitContext)
- })
-
- ## getVisitContexDataEnhanced----
- getVisitContexDataEnhanced <- shiny::reactive(x = { #spelling error here missing the t in Context
- visitContextData <- getVisitContextData() %>%
- dplyr::rename(visitContextSubject = subjects)
- if (!hasData(visitContextData)) {
- return(NULL)
- }
- visitContextData <-
- expand.grid(
- visitContext = c("Before", "During visit", "On visit start", "After"),
- visitConceptName = unique(visitContextData$visitConceptName),
- databaseId = unique(visitContextData$databaseId),
- cohortId = unique(visitContextData$cohortId)
- ) %>%
- dplyr::tibble() %>%
- dplyr::left_join(
- visitContextData,
- by = c(
- "visitConceptName",
- "visitContext",
- "databaseId",
- "cohortId"
- )
- ) %>%
- dplyr::rename(
- subjects = cohortSubjects,
- records = cohortEntries
- ) %>%
- dplyr::select(
- databaseId,
- cohortId,
- visitConceptName,
- visitContext,
- subjects,
- records,
- visitContextSubject
- ) %>%
- dplyr::mutate(
- visitContext = dplyr::case_when(
- visitContext == "During visit" ~ "During",
- visitContext == "On visit start" ~ "Simultaneous",
- TRUE ~ visitContext
- )
- ) %>%
- tidyr::replace_na(replace = list(subjects = 0, records = 0))
-
-
- if (input$visitContextTableFilters == "Before") {
- visitContextData <- visitContextData %>%
- dplyr::filter(visitContext == "Before")
- } else if (input$visitContextTableFilters == "During") {
- visitContextData <- visitContextData %>%
- dplyr::filter(visitContext == "During")
- } else if (input$visitContextTableFilters == "Simultaneous") {
- visitContextData <- visitContextData %>%
- dplyr::filter(visitContext == "Simultaneous")
- } else if (input$visitContextTableFilters == "After") {
- visitContextData <- visitContextData %>%
- dplyr::filter(visitContext == "After")
- }
- if (!hasData(visitContextData)) {
- return(NULL)
- }
- visitContextData <- visitContextData %>%
- tidyr::pivot_wider(
- id_cols = c("databaseId", "visitConceptName"),
- names_from = "visitContext",
- values_from = c("visitContextSubject")
- )
-
- return(visitContextData)
- })
-
- output$visitContextTable <- reactable::renderReactable(expr = {
- validate(need(length(selectedDatabaseIds()) > 0, "No data sources chosen"))
- validate(need(length(targetCohortId()) > 0, "No cohorts chosen"))
- data <- getVisitContexDataEnhanced()
- validate(need(
- nrow(data) > 0,
- "No data available for selected combination."
- ))
-
- dataColumnFields <-
- c(
- "Before",
- "During",
- "Simultaneous",
- "After"
- )
-
- if (input$visitContextTableFilters == "Before") {
- dataColumnFields <- "Before"
- } else if (input$visitContextTableFilters == "During") {
- dataColumnFields <- "During"
- } else if (input$visitContextTableFilters == "Simultaneous") {
- dataColumnFields <- "Simultaneous"
- } else if (input$visitContextTableFilters == "After") {
- dataColumnFields <- "After"
- }
- keyColumnFields <- "visitConceptName"
-
- countsForHeader <-
- getDisplayTableHeaderCount(
- dataSource = dataSource,
- databaseIds = selectedDatabaseIds(),
- cohortIds = targetCohortId(),
- source = "cohort",
- fields = input$visitContextPersonOrRecords
- )
- if (!hasData(countsForHeader)) {
- return(NULL)
- }
-
- maxCountValue <-
- getMaxValueForStringMatchedColumnsInDataFrame(
- data = data,
- string = dataColumnFields
- )
-
- getDisplayTableGroupedByDatabaseId(
- data = data,
- cohort = cohortTable,
- databaseTable = databaseTable,
- headerCount = countsForHeader,
- keyColumns = keyColumnFields,
- countLocation = 1,
- dataColumns = dataColumnFields,
- maxCount = maxCountValue,
- sort = TRUE
- )
- })
- })
-}
diff --git a/inst/shiny/DiagnosticsExplorer/data/resultsDataModelSpecification.csv b/inst/shiny/DiagnosticsExplorer/data/resultsDataModelSpecification.csv
deleted file mode 100644
index 1af142cec..000000000
--- a/inst/shiny/DiagnosticsExplorer/data/resultsDataModelSpecification.csv
+++ /dev/null
@@ -1,237 +0,0 @@
-tableName,columnName,dataType,isRequired,primaryKey,optional,emptyIsNa,minCellCount,isVocabularyTable,neverIncremental
-annotation,annotation_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation,created_by,varchar,Yes,No,No,Yes,No,No,No
-annotation,created_on,bigint,Yes,No,No,Yes,No,No,No
-annotation,modified_last_on,bigint,No,No,Yes,Yes,No,No,No
-annotation,deleted_on,bigint,No,No,Yes,Yes,No,No,No
-annotation,annotation,varchar,Yes,No,No,Yes,No,No,No
-annotation_link,annotation_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation_link,diagnostics_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation_link,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation_link,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-annotation_attributes,annotation_id,bigint,Yes,Yes,No,Yes,No,No,No
-annotation_attributes,created_by,varchar,Yes,Yes,No,Yes,No,No,No
-annotation_attributes,annotation_attributes,int,Yes,No,No,Yes,No,No,No
-annotation_attributes,created_on,bigint,Yes,No,No,Yes,No,No,No
-cohort,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort,cohort_name,varchar,Yes,No,No,Yes,No,No,No
-cohort,metadata,varchar,No,No,Yes,Yes,No,No,No
-cohort,sql,varchar,Yes,No,No,Yes,No,No,No
-cohort,json,varchar,Yes,No,No,Yes,No,No,No
-cohort_count,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_count,cohort_entries,float,Yes,No,No,Yes,Yes,No,No
-cohort_count,cohort_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_count,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-cohort_inclusion,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-cohort_inclusion,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_inclusion,rule_sequence,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_inclusion,name,varchar,Yes,No,No,Yes,No,No,No
-cohort_inclusion,description,varchar,No,No,No,Yes,No,No,No
-cohort_inc_result,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-cohort_inc_result,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_inc_result,mode_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_inc_result,inclusion_rule_mask,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_inc_result,person_count,float,Yes,No,No,Yes,Yes,No,No
-cohort_inc_stats,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-cohort_inc_stats,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_inc_stats,rule_sequence,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_inc_stats,mode_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_inc_stats,person_count,float,Yes,No,No,Yes,Yes,No,No
-cohort_inc_stats,gain_count,float,Yes,No,No,Yes,Yes,No,No
-cohort_inc_stats,person_total,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,either_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,both_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,t_only_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,c_only_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,t_before_c_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,c_before_t_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,same_day_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,t_in_c_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,c_in_t_subjects,float,Yes,No,No,Yes,Yes,No,No
-cohort_overlap,target_cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_overlap,comparator_cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_overlap,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-cohort_relationships,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-cohort_relationships,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_relationships,comparator_cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_relationships,start_day,bigint,No,Yes,No,Yes,No,No,No
-cohort_relationships,end_day,float,No,Yes,No,Yes,No,No,No
-cohort_relationships,subjects,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_cs_before_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_cs_before_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_cs_on_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_cs_on_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_cs_after_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_cs_after_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_cs_before_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_cs_before_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_cs_on_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_cs_on_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_cs_after_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_cs_after_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_cs_window_t,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_cs_window_t,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_ce_window_t,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_ce_window_t,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_cs_window_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_cs_window_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_cs_window_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_cs_window_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_ce_window_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_ce_window_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_ce_window_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_ce_window_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,sub_c_within_t,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,rec_c_within_t,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,c_days_before_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,c_days_before_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,c_days_within_t_days,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,c_days_after_ts,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,c_days_after_te,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,t_days,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_relationships,c_days,bigint,Yes,No,No,Yes,Yes,No,No
-cohort_summary_stats,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-cohort_summary_stats,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_summary_stats,mode_id,bigint,Yes,Yes,No,Yes,No,No,No
-cohort_summary_stats,base_count,float,Yes,No,No,Yes,Yes,No,No
-cohort_summary_stats,final_count,float,Yes,No,No,Yes,Yes,No,No
-concept,concept_id,bigint,Yes,Yes,No,Yes,No,Yes,No
-concept,concept_name,varchar(255),Yes,No,No,Yes,No,Yes,No
-concept,domain_id,varchar(20),Yes,No,No,Yes,No,Yes,No
-concept,vocabulary_id,varchar(50),Yes,No,No,Yes,No,Yes,No
-concept,concept_class_id,varchar(20),Yes,No,No,Yes,No,Yes,No
-concept,standard_concept,varchar(1),No,No,No,Yes,No,Yes,No
-concept,concept_code,varchar(50),Yes,No,No,Yes,No,Yes,No
-concept,valid_start_date,Date,Yes,No,No,Yes,No,Yes,No
-concept,valid_end_date,Date,Yes,No,No,Yes,No,Yes,No
-concept,invalid_reason,varchar,No,No,No,Yes,No,Yes,No
-concept_ancestor,ancestor_concept_id,bigint,Yes,Yes,No,Yes,No,Yes,No
-concept_ancestor,descendant_concept_id,bigint,Yes,Yes,No,Yes,No,Yes,No
-concept_ancestor,min_levels_of_separation,int,Yes,No,No,Yes,No,Yes,No
-concept_ancestor,max_levels_of_separation,int,Yes,No,No,Yes,No,Yes,No
-concept_relationship,concept_id_1,bigint,Yes,Yes,No,Yes,No,Yes,No
-concept_relationship,concept_id_2,bigint,Yes,Yes,No,Yes,No,Yes,No
-concept_relationship,relationship_id,varchar(20),Yes,Yes,No,Yes,No,Yes,No
-concept_relationship,valid_start_date,Date,Yes,No,No,Yes,No,Yes,No
-concept_relationship,valid_end_date,Date,Yes,No,No,Yes,No,Yes,No
-concept_relationship,invalid_reason,varchar(1),No,No,No,Yes,No,Yes,No
-concept_sets,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-concept_sets,concept_set_id,int,Yes,Yes,No,Yes,No,No,No
-concept_sets,concept_set_sql,varchar,Yes,No,No,Yes,No,No,No
-concept_sets,concept_set_name,varchar(255),Yes,No,No,Yes,No,No,No
-concept_sets,concept_set_expression,varchar,Yes,No,No,Yes,No,No,No
-concept_synonym,concept_id,bigint,Yes,Yes,No,Yes,No,Yes,No
-concept_synonym,concept_synonym_name,varchar,Yes,Yes,No,Yes,No,Yes,No
-concept_synonym,language_concept_id,bigint,Yes,Yes,No,Yes,No,Yes,No
-database,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-database,database_name,varchar,No,No,No,Yes,No,No,No
-database,description,varchar,No,No,No,Yes,No,No,No
-database,is_meta_analysis,varchar(1),Yes,No,No,Yes,No,No,No
-database,vocabulary_version,varchar,No,No,Yes,Yes,No,No,No
-database,vocabulary_version_cdm,varchar,No,No,Yes,Yes,No,No,No
-domain,domain_id,varchar(20),Yes,Yes,No,Yes,No,Yes,Yes
-domain,domain_name,varchar(255),Yes,No,No,Yes,No,Yes,Yes
-domain,domain_concept_id,bigint,Yes,No,No,Yes,No,Yes,Yes
-incidence_rate,cohort_count,float,Yes,No,No,Yes,Yes,No,No
-incidence_rate,person_years,float,Yes,No,No,Yes,Yes,No,No
-incidence_rate,gender,varchar,No,Yes,No,No,No,No,No
-incidence_rate,age_group,varchar,No,Yes,No,No,No,No,No
-incidence_rate,calendar_year,varchar(4),No,Yes,No,No,No,No,No
-incidence_rate,incidence_rate,float,Yes,No,No,Yes,No,No,No
-incidence_rate,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-incidence_rate,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-included_source_concept,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-included_source_concept,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-included_source_concept,concept_set_id,int,Yes,Yes,No,Yes,No,No,No
-included_source_concept,concept_id,bigint,Yes,Yes,No,Yes,No,No,No
-included_source_concept,source_concept_id,bigint,No,Yes,Yes,No,No,No,No
-included_source_concept,concept_subjects,float,Yes,No,No,Yes,Yes,No,No
-included_source_concept,concept_count,float,Yes,No,No,Yes,Yes,No,No
-index_event_breakdown,concept_id,bigint,Yes,Yes,No,Yes,No,No,No
-index_event_breakdown,concept_count,float,Yes,No,No,Yes,Yes,No,No
-index_event_breakdown,subject_count,float,Yes,No,No,Yes,Yes,No,No
-index_event_breakdown,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-index_event_breakdown,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-index_event_breakdown,domain_field,varchar,Yes,Yes,No,Yes,No,No,No
-index_event_breakdown,domain_table,varchar,Yes,Yes,No,Yes,No,No,No
-metadata,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-metadata,start_time,varchar,No,Yes,No,Yes,No,No,No
-metadata,variable_field,varchar,Yes,Yes,No,Yes,No,No,No
-metadata,value_field,varchar,Yes,No,No,Yes,No,No,No
-orphan_concept,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-orphan_concept,concept_set_id,int,Yes,Yes,No,Yes,No,No,No
-orphan_concept,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-orphan_concept,concept_id,bigint,Yes,Yes,No,Yes,No,No,No
-orphan_concept,concept_count,float,Yes,No,No,Yes,Yes,No,No
-orphan_concept,concept_subjects,float,Yes,No,No,Yes,Yes,No,No
-relationship,relationship_id,varchar(20),Yes,Yes,No,Yes,No,Yes,Yes
-relationship,relationship_name,varchar(255),Yes,No,No,Yes,No,Yes,Yes
-relationship,is_hierarchical,varchar(1),Yes,No,No,Yes,No,Yes,Yes
-relationship,defines_ancestry,varchar(1),Yes,No,No,Yes,No,Yes,Yes
-relationship,reverse_relationship_id,varchar(20),Yes,Yes,No,Yes,No,Yes,Yes
-relationship,relationship_concept_id,bigint,Yes,Yes,No,Yes,No,Yes,Yes
-resolved_concepts,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-resolved_concepts,concept_set_id,int,Yes,Yes,No,Yes,No,No,No
-resolved_concepts,concept_id,bigint,Yes,Yes,No,Yes,No,No,No
-resolved_concepts,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-temporal_analysis_ref,analysis_id,int,Yes,Yes,No,Yes,No,No,No
-temporal_analysis_ref,analysis_name,varchar,Yes,No,No,Yes,No,No,No
-temporal_analysis_ref,domain_id,varchar(20),Yes,Yes,No,Yes,No,No,No
-temporal_analysis_ref,is_binary,varchar(1),Yes,No,No,Yes,No,No,No
-temporal_analysis_ref,missing_means_zero,varchar(1),No,No,No,Yes,No,No,No
-temporal_covariate_ref,covariate_id,bigint,Yes,Yes,No,Yes,No,No,No
-temporal_covariate_ref,covariate_name,varchar,Yes,No,No,Yes,No,No,No
-temporal_covariate_ref,analysis_id,int,Yes,No,No,Yes,No,No,No
-temporal_covariate_ref,concept_id,bigint,Yes,No,No,Yes,No,No,No
-temporal_covariate_value,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-temporal_covariate_value,time_id,int,No,Yes,Yes,Yes,No,No,No
-temporal_covariate_value,covariate_id,bigint,Yes,Yes,No,Yes,No,No,No
-temporal_covariate_value,sum_value,float,Yes,No,No,Yes,Yes,No,No
-temporal_covariate_value,mean,float,Yes,No,No,Yes,No,No,No
-temporal_covariate_value,sd,float,No,No,No,Yes,No,No,No
-temporal_covariate_value,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-temporal_covariate_value_dist,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-temporal_covariate_value_dist,time_id,int,No,Yes,Yes,Yes,No,No,No
-temporal_covariate_value_dist,covariate_id,bigint,Yes,Yes,No,Yes,No,No,No
-temporal_covariate_value_dist,count_value,float,Yes,No,No,Yes,Yes,No,No
-temporal_covariate_value_dist,min_value,float,Yes,No,No,Yes,Yes,No,No
-temporal_covariate_value_dist,max_value,float,Yes,No,No,Yes,Yes,No,No
-temporal_covariate_value_dist,mean,float,Yes,No,No,Yes,No,No,No
-temporal_covariate_value_dist,sd,float,Yes,No,No,Yes,No,No,No
-temporal_covariate_value_dist,median_value,float,Yes,No,No,Yes,No,No,No
-temporal_covariate_value_dist,p_10_value,float,Yes,No,No,Yes,No,No,No
-temporal_covariate_value_dist,p_25_value,float,Yes,No,No,Yes,No,No,No
-temporal_covariate_value_dist,p_75_value,float,Yes,No,No,Yes,No,No,No
-temporal_covariate_value_dist,p_90_value,float,Yes,No,No,Yes,No,No,No
-temporal_covariate_value_dist,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-temporal_time_ref,time_id,int,Yes,Yes,No,Yes,No,No,No
-temporal_time_ref,start_day,float,Yes,No,No,Yes,No,No,No
-temporal_time_ref,end_day,float,Yes,No,No,Yes,No,No,No
-time_series,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-time_series,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-time_series,period_begin,Date,Yes,Yes,No,Yes,No,No,No
-time_series,period_end,Date,Yes,Yes,No,Yes,No,No,No
-time_series,series_type,varchar,Yes,Yes,No,Yes,No,No,No
-time_series,calendar_interval,varchar,Yes,Yes,No,Yes,No,No,No
-time_series,gender,varchar,No,Yes,Yes,Yes,No,No,No
-time_series,age_group,varchar,No,Yes,Yes,Yes,No,No,No
-time_series,records,bigint,Yes,No,No,Yes,Yes,No,No
-time_series,subjects,bigint,Yes,No,No,Yes,Yes,No,No
-time_series,person_days,bigint,Yes,No,No,Yes,Yes,No,No
-time_series,person_days_in,bigint,Yes,No,No,Yes,Yes,No,No
-time_series,records_start,bigint,No,No,No,No,Yes,No,No
-time_series,subjects_start,bigint,No,No,No,No,Yes,No,No
-time_series,subjects_start_in,bigint,No,No,No,No,Yes,No,No
-time_series,records_end,bigint,No,No,No,No,Yes,No,No
-time_series,subjects_end,bigint,No,No,No,No,Yes,No,No
-time_series,subjects_end_in,bigint,No,No,No,No,Yes,No,No
-visit_context,cohort_id,bigint,Yes,Yes,No,Yes,No,No,No
-visit_context,visit_concept_id,bigint,Yes,Yes,No,Yes,No,No,No
-visit_context,visit_context,varchar,Yes,Yes,No,Yes,No,No,No
-visit_context,subjects,float,Yes,No,No,Yes,Yes,No,No
-visit_context,database_id,varchar,Yes,Yes,No,Yes,No,No,No
-vocabulary,vocabulary_id,varchar(50),Yes,No,No,Yes,No,Yes,No
-vocabulary,vocabulary_name,varchar(255),Yes,No,No,Yes,No,Yes,No
-vocabulary,vocabulary_reference,varchar,No,No,No,Yes,No,Yes,No
-vocabulary,vocabulary_version,varchar,No,No,No,Yes,No,Yes,No
-vocabulary,vocabulary_concept_id,bigint,Yes,No,No,Yes,No,Yes,No
diff --git a/inst/shiny/DiagnosticsExplorer/global.R b/inst/shiny/DiagnosticsExplorer/global.R
index baeaf411a..35322e5c4 100644
--- a/inst/shiny/DiagnosticsExplorer/global.R
+++ b/inst/shiny/DiagnosticsExplorer/global.R
@@ -1,23 +1,89 @@
-library(magrittr)
-diagExpEnv <- new.env()
-diagExpEnv$shinyConfigPath <- getOption("CD-shiny-config", default = "config.yml")
-# Source all app files in to isolated namespace
-lapply(file.path("R", list.files("R", pattern = "*.R")), source, local = diagExpEnv)
+loadShinySettings <- function(configPath) {
+ stopifnot(file.exists(configPath))
+ shinySettings <- yaml::read_yaml(configPath)
-diagExpEnv$appVersionNum <- "Version: 3.1.2"
+ defaultValues <- list(
+ resultsDatabaseSchema = c("main"),
+ vocabularyDatabaseSchemas = c("main"),
+ tablePrefix = "",
+ cohortTable = "cohort",
+ databaseTable = "database",
+ connectionEnvironmentVariables = NULL
+ )
-if (exists("shinySettings")) {
- diagExpEnv$shinySettings <- shinySettings
- diagExpEnv$activeUser <- Sys.info()[['user']]
-} else {
- writeLines("Using settings provided by user")
- diagExpEnv$shinySettings <- diagExpEnv$loadShinySettings(diagExpEnv$shinyConfigPath)
- diagExpEnv$activeUser <- NULL
+ for (key in names(defaultValues)) {
+ if (is.null(shinySettings[[key]])) {
+ shinySettings[[key]] <- defaultValues[[key]]
+ }
+ }
+
+ if (shinySettings$cohortTableName == "cohort") {
+ shinySettings$cohortTableName <- paste0(shinySettings$tablePrefix, shinySettings$cohortTableName)
+ }
+
+ if (shinySettings$databaseTableName == "database") {
+ shinySettings$databaseTableName <- paste0(shinySettings$tablePrefix, shinySettings$databaseTableName)
+ }
+
+ if (!is.null(shinySettings$connectionDetailsSecureKey)) {
+ shinySettings$connectionDetails <- jsonlite::fromJSON(keyring::key_get(shinySettings$connectionDetailsSecureKey))
+ } else if(!is.null(shinySettings$connectionEnvironmentVariables$server)) {
+
+ defaultValues <- list(
+ dbms = "",
+ user = "",
+ password = "",
+ port = "",
+ extraSettings = ""
+ )
+
+ for (key in names(defaultValues)) {
+ if (is.null(shinySettings$connectionEnvironmentVariables[[key]])) {
+ shinySettings$connectionEnvironmentVariables[[key]] <- defaultValues[[key]]
+ }
+ }
+
+ serverStr <- Sys.getenv(shinySettings$connectionEnvironmentVariables$server)
+ if (!is.null(shinySettings$connectionEnvironmentVariables$database)) {
+ serverStr <- paste0(serverStr, "/", Sys.getenv(shinySettings$connectionEnvironmentVariables$database))
+ }
+
+ shinySettings$connectionDetails <- list(
+ dbms = Sys.getenv(shinySettings$connectionEnvironmentVariables$dbms, unset = shinySettings$connectionDetails$dbms),
+ server = serverStr,
+ user = Sys.getenv(shinySettings$connectionEnvironmentVariables$user),
+ password = Sys.getenv(shinySettings$connectionEnvironmentVariables$password),
+ port = Sys.getenv(shinySettings$connectionEnvironmentVariables$port, unset = shinySettings$connectionDetails$port),
+ extraSettings = Sys.getenv(shinySettings$connectionEnvironmentVariables$extraSettings)
+ )
+ }
+ shinySettings$connectionDetails <- do.call(DatabaseConnector::createConnectionDetails,
+ shinySettings$connectionDetails)
+
+ return(shinySettings)
}
-# Init tables and other parameters in global session
-diagExpEnv$initializeEnvironment(diagExpEnv$shinySettings, envir = diagExpEnv)
+if (!exists("shinySettings")) {
+ writeLines("Using settings provided by user")
+ shinyConfigPath <- getOption("CD-shiny-config", default = "config.yml")
+ shinySettings <- loadShinySettings(shinyConfigPath)
+}
+
+# Added to support publishing to posit connect and shinyapps.io (looks for a library or reauire)
+if (FALSE) {
+ require(RSQLite)
+}
+connectionHandler <- ResultModelManager::PooledConnectionHandler$new(shinySettings$connectionDetails)
+dataSource <-
+ OhdsiShinyModules::createCdDatabaseDataSource(
+ connectionHandler = connectionHandler,
+ schema = shinySettings$resultsDatabaseSchema,
+ vocabularyDatabaseSchema = shinySettings$vocabularyDatabaseSchema,
+ tablePrefix = shinySettings$tablePrefix,
+ cohortTableName = shinySettings$cohortTableName,
+ databaseTableName = shinySettings$databaseTableName
+ )
diff --git a/inst/shiny/DiagnosticsExplorer/html/cohortAsFeatures.html b/inst/shiny/DiagnosticsExplorer/html/cohortAsFeatures.html
deleted file mode 100644
index e56c69500..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/cohortAsFeatures.html
+++ /dev/null
@@ -1,4 +0,0 @@
-Description (beta)
-This is summary of the distribution of the days between cohort_start/cohort_end of target cohort and all feature cohorts.
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/cohortCharacterization.html b/inst/shiny/DiagnosticsExplorer/html/cohortCharacterization.html
deleted file mode 100644
index 57d7c25e8..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/cohortCharacterization.html
+++ /dev/null
@@ -1,16 +0,0 @@
-Description
-A table showing cohort characteristics (covariates). These characteristics are captured on or before the cohort start date. There is a Pretty and a Raw version of this table.
-The Pretty table shows the standard OHDSI characteristics table, which includes only covariates that were manually selected to provide a general overview of the comorbidities and medications of the cohort. These are all binary covariates, and the table shows the proportion (%) of the cohort entries having the covariate.
-
The Raw table shows all captured covariates. These include binary and continuous covariates (e.g. the Charlson comorbidity index). For each covariate the table lists the mean, which for binary covariates is equal to the proportion, and the standard deviation (SD).
-
-Options
-You can select multiple databases in the side bar to see cohort characteristics from different databases side-by-side in the same table.
-Select the cohort to explore in the side bar.
-Select either the Pretty or the Raw table at the top of the table.
-
-What to look for
-
-- Are the characteristics of the cohort as expected? For example, do people have the expected comorbidities?
-- Do the characteristics of the cohort differ much per database?
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/cohortCounts.html b/inst/shiny/DiagnosticsExplorer/html/cohortCounts.html
deleted file mode 100644
index 057a37939..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/cohortCounts.html
+++ /dev/null
@@ -1,12 +0,0 @@
-Description
-A table showing the number of cohort entries and unique subjects per cohort per data source. Because one person can have more than one cohort entry, the number of entries can be higher than the number of persons.
-
-Options
-You may select multiple data sources in the side bar to see counts from different data sources side-by-side.
-
-What to look for
-
-- Are there cohorts that are empty in some data sources?
-- Are the relative counts (relative to the other cohorts in the same data source) comparable across data sources? Note that the color bars show the relative counts.
-- Are the cohorts of expected and sufficient size? For example, if we want to study the effect of an exposure, a rule-of-thumb is that we require at least 2,500 in the exposure cohort.
-
\ No newline at end of file
diff --git a/inst/shiny/DiagnosticsExplorer/html/cohortOverlap.html b/inst/shiny/DiagnosticsExplorer/html/cohortOverlap.html
deleted file mode 100644
index 6e8c97180..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/cohortOverlap.html
+++ /dev/null
@@ -1,27 +0,0 @@
-Description
-Stacked bar graph showing the overlap between two cohorts, and a table listing several overlap statistics.
-
-The stacked bar shows the overlap in terms of subjects. It shows the number of subjects that belong to each cohort and to both. The diagram does not consider whether the subjects were in the different cohorts at the same time.
-The table show the same information and more:
-
-- Subject in either cohort: The number of subjects that enter one or both cohorts. (The union)
-- Subject in both cohort: The number of subjects that enter both cohorts, although not necessarily at the same time. (The intersection)
-- Subject in target not in comparator: The number of subjects that enter the target cohort, but not the comparator cohort. (Subtracting the comparator from the target)
-- Subject in comparator not in target: The number of subjects that enter the comparator cohort, but not the target cohort. (Subtracting the comparator from the target)
-- Subject in target before comparator: The number of subjects that enter both cohorts, but enter the target cohort before entering the comparator cohort. This number considers only the first entry per cohort per person.
-- Subject in comparator before target: The number of subjects that enter both cohorts, but enter the comparator cohort before entering the target cohort. This number considers only the first entry per cohort per person.
-- Subject in target and comparator on same day: The number of subjects that enter both cohorts on the same date. This number considers only the first entry per cohort per person.
-- Subject having target start during comparator: The number of subjects that enter the target cohort during the comparator cohort, meaning comparator cohort start date <= target cohort start date <= comparator cohort end date. This number considers only the first entry per cohort per person.
-- Subject having comparator start during target: The number of subjects that enter the comparator cohort during the target cohort, meaning target cohort start date <= comparator cohort start date <= target cohort end date. This number considers only the first entry per cohort per person.
-
-
-Options
-You can select one or more database in the side bar.
-You can select the (target) cohort(s) and comparator cohort(s) in the side bar.
-
-What to look for
-
-- Are there many people in both cohorts? For example, if we want to compare two exposures, are there many people that receive both?
-- Is the overlap of sufficient size for a specific research question? For example, if we wish to study the effect of an exposure on an outcome, we may require a minimum number of outcomes during exposure.
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/compareCohortCharacterization.html b/inst/shiny/DiagnosticsExplorer/html/compareCohortCharacterization.html
deleted file mode 100644
index 312effe9c..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/compareCohortCharacterization.html
+++ /dev/null
@@ -1,15 +0,0 @@
-Description
-A table or plot showing cohort characteristics (covariates) for two cohorts side-by-side. These characteristics are captured at different time windows that can be selected
-The Raw table shows all captured covariates. These include binary and continuous covariates (e.g. the Charlson comorbidity index). For each covariate the table lists the mean, which for binary covariates is equal to the proportion, the standard deviation (SD), and the standardized difference of the mean (StdDiff).
-The plot shows all covariates, include binary and continuous covariates. The x-axis represents the mean value in the target cohort, the y-axis the mean value in the comparator cohort. Each dot represents a covariate, and the color indicates the domain of the covariate being plotted. In the plot, domains are fixed (even though additional domains may exist in data) to ensure the color of the domains are consistently applied.
-Filters maybe used to limit the number of covariates being visualized/tabulated. Filters are available for analysis names and domain names.
-
- You can either select different cohorts in the same database, the same cohort in different database or different cohorts in different databases
-
-
-What to look for
-
-- Are there major differences between the two cohorts? For example, if we wish to compute a propensity score between two cohorts, concepts that have very high proportion in one cohort and a very low proportion in the other may lead to a perfectly predictive model.
-- In general, how comparable are two cohorts? If we wish to compare two exposures, but the cohorts differ over many characteristics, we may be able to fit a propensity model and compute an estimate, but we may have concerns over the generalizability of the results.
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/conceptSetDiagnostics.html b/inst/shiny/DiagnosticsExplorer/html/conceptSetDiagnostics.html
deleted file mode 100644
index 0e9c710a0..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/conceptSetDiagnostics.html
+++ /dev/null
@@ -1,24 +0,0 @@
-Description
- A table showing the concepts included in a concept set of a cohort along with concepts recommended for review.
- Record and database counts represent counts collected across participating ConceptPrevalence datasources and do not represent your datasource counts. Concept counts and database counts with descendants reflect the total counts of a concept with its descendants.
-
- Recommended concepts include (Concept in Set):
-
-- Not included - parent: a list of all immediate ancestors of the concepts in a concept set;
-- Not included - descendant: a list of all descendants of the concepts in a concept set, which were not included in this concept set;
-- Not included - recommended via standard: a list of recommendations of standard concepts not included in a concept set;
-- Not included - recommended via source: a list of recommendations of concepts not included in a concept set, which were found through not included source concepts (e.g. ICD-10 CM);
-
-
- Source concepts are identified in the _source_concept_id fields of the Common Data Model, (e.g. drug_source_concept_id) and are used to identify the specific source codes used in a database. Standard concepts are found using the _concept_id fields (e.g. drug_concept_id), and use the same coding system across all databases.
-
-Options
-Select the cohort and the specific concept set within that cohort to explore in the side bar.
-You can switch between Source Concepts and Standard Concepts at the top of the table.
-
-What to look for
-
-- Are there included codes that should not be? For example, in a concept set for hypertensive disorder, are hypotension codes included by accident?
-- Are there parent or descendant concepts that should be included? For example, in a concept set for hypertensive disorder, Chronic kidney disease due to hypertension is a suggested parent that may be included.
-- Are there recommended concepts that should be included in the concept set?
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/conceptsInDataSource.html b/inst/shiny/DiagnosticsExplorer/html/conceptsInDataSource.html
deleted file mode 100644
index 6c2c0fd26..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/conceptsInDataSource.html
+++ /dev/null
@@ -1,14 +0,0 @@
-Description
-A table showing the concept ids observed in the database that are included in a concept set(s) of the selected cohort. The Subjects column contains the number of subjects in the entire database that have the specific concept. This count is not restricted to people in the cohort - but represents a database level characterization. Source concepts are identified in the _source_concept_id fields of the Common Data Model, (e.g. drug_source_concept_id) and are used to identify the specific source codes used in a database. Standard concepts are found using the _concept_id fields (e.g. drug_concept_id), and use the same coding system across all databases. Note: Per CDM conventions standard concept ids, may be used to populate _source_concept_id fields in domain tables, but non-standard concept ids may not be used to populate the standard fields in those domain tables.
-
-Options
-You can select a database in the side bar to see the concepts and counts observed in that database.
-Select the cohort and the specific concept set within that cohort to explore in the side bar.
-You can switch between Source Concepts and Standard Concepts at the top of the table.
-
-What to look for
-
-- Are there source codes included that should not be? For example, in a concept set for hypertensive disorder, are hypotension codes included by accident?
-- Are all expected codes present? For example, if we have a list of ICD-10 codes that have been used in literature to identify a cohort, are all those codes present?
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/incidenceRate.html b/inst/shiny/DiagnosticsExplorer/html/incidenceRate.html
deleted file mode 100644
index 31178bf2d..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/incidenceRate.html
+++ /dev/null
@@ -1,25 +0,0 @@
-Description
-A graph showing the incidence rate, optionally stratified by age (in 10-year bins), gender, and calendar year.
-
-The incidence rate is computed as 1000 * the number of people first entering the cohort / the number of years people were eligible to enter the cohort for the first time. The eligible person time is defined as the time when
-
- - A person was observed in the data source (based on the observation_period table).
- - Had the required amount of prior observation time as specified in the cohort entry event criteria. For example, if the cohort definition requires 365 days of observation prior to cohort entry, patients are not eligible to enter the cohort in the first 365 days of their observation period, and this time is not counted in the eligible time.
- - If the person enters the cohort, then only the time up to cohort entry. Because we only consider the first cohort entry, persons are no longer eligible to enter to cohort after their first entry.
-
-
- Note: If your cohort definition has an inclusion rule that restricts persons based on prior observation time, then this might lead to underestimation of incidence rate as the same prior observation time restriction would not be applied to the denominator. We recommend that you revise the cohort definition to make prior observation time rule part of entry event criteria.
-
-Options
-You can select multiple data sources in the side bar to see graphs from different data sources in the same plot.
-Select the cohort to explore in the side bar.
-At the top left of the plot, you can choose whether to stratify the data by age, gender, or calendar year.
-At the top right of the plot, you can choose whether to use the same y-axis for all data sources.
-If you move the mouse over the plot, you can see the precise value.
-
-What to look for
-
-- Are the observed incidence rates in line with expectations? For example, if we have an estimate of the population incidence based on an external source, is the incidence rate comparable to that estimate?
-- Are the age and gender distributions in line with expectations? For example, are contraceptives only prescribed in women?
-- Is the incidence rate stable over time? If there are sudden peaks or drops, this may indicate coding issues.
-
\ No newline at end of file
diff --git a/inst/shiny/DiagnosticsExplorer/html/inclusionRuleStats.html b/inst/shiny/DiagnosticsExplorer/html/inclusionRuleStats.html
deleted file mode 100644
index 6b72543c6..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/inclusionRuleStats.html
+++ /dev/null
@@ -1,25 +0,0 @@
-Description
-A table showing the number of subject that match specific inclusion rules in the cohort definition. Note that this table will be empty if no inclusion rules have been specified.
-
-The table contains the following columns:
-
-- Sequence: The order in which the inclusion rules are applied to the cohort.
-- Name: The name of the inclusion rule.
-- Meet: The number of cohort entries (records) that meet the entry event definition and the specific inclusion rule indicated in the row.
-- Gain: The number of cohort entries (records) that would be gained if this inclusion rule was dropped.
-- Total: The number of cohort entries (records) meeting the entry event definition. In other words, the number of cohort entries before applying any of the inclusion rules.
-- Remain: The number of cohort entries (records) remaining after applying the specific inclusion rule, and all preceding rules.
-
-
-
-Options
-You can select a database in the side bar to see the inclusion rule statistics observed in that database.
-Select the cohort to explore in the side bar.
-
-What to look for
-
-- Are there inclusion rules that nobody meets in a database? For example, requiring a specialist visit that is not recorded in a specific database.
-- Are there inclusion rules that have no effect in a database? For example, requiring no occurrence of a prior disease code that is not recorded in a database.
-- Are there inclusion rules that drastically reduce the population? In this case we might worry about generalizability. For example, if we require a diagnostic procedure, and only a small fraction meets this criteria, we may wonder if this identifies a special population that differs from the overall population in significant ways.
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/indexEventBreakdown.html b/inst/shiny/DiagnosticsExplorer/html/indexEventBreakdown.html
deleted file mode 100644
index 65d06942c..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/indexEventBreakdown.html
+++ /dev/null
@@ -1,13 +0,0 @@
-Description
-A table showing the concepts belonging to the concept sets in the entry event definition that are observed on the index date. In other words, the table lists the concepts that likely triggered the cohort entry. The counts indicate number of cohort entries where the concepts was observed on the index date. Note that multiple concepts can be present on the index date, so the sum of counts might be greater than the cohort entry count.
-
-Options
-You can select multiple databases in the side bar to see counts from different databases side-by-side.
-Select the cohort to explore in the side bar.
-
-What to look for
-
-- Is one concept unexpectedly dominating? For example, if our cohort identifies exposure to drugs in a class, but we notice almost everyone enters the cohort based on a single drug, we may wonder whether our results will generalize to the class.
-- Are the highest ranking concepts different across databases? For example, is everyone in one database initiating high-dose prescriptions, and everyone in another database low-dose prescriptions?
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/orphanConcepts.html b/inst/shiny/DiagnosticsExplorer/html/orphanConcepts.html
deleted file mode 100644
index 687b132d3..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/orphanConcepts.html
+++ /dev/null
@@ -1,21 +0,0 @@
-Description
-A table showing the concept(s) observed in the datasource that are not included in a concept set of a cohort, but maybe considered. The following logic is used to identify concepts that might be relevant:
-
-- Given a concept set expression, find all included concepts.
-
- Find all names of those concepts, including synonyms, and the names of source concepts that map to them.
-- Search for concepts (standard and source) that contain any of those names as substring.
-- Filter those concepts to those that are not in the original set of concepts (i.e. orphans).
-- Restrict the set of orphan concepts to those that appear in the CDM data source as either source concept or standard concept.
-
-
-The Subjects column contains the number of subjects in the entire data source that have the specific concept, i.e. it is not restricted to people in the cohort. This is a data source level characterization. Source concepts are identified in the _source_concept_id fields of the Common Data Model, (e.g. drug_source_concept_id) and are used to identify the specific source codes used in a data source. Standard concepts are found using the _concept_id fields (e.g. drug_concept_id), and use the same coding system across all databases.
-
-Options
-You can select a data source in the side bar to see the concepts and counts observed in that data source.
-Select the cohort and the specific concept set within that cohort to explore in the side bar.
-
-What to look for
-
-- Are there concepts that are not included in the concept but should be? Note that the provided list likely contains many false positives.
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/timeDistribution.html b/inst/shiny/DiagnosticsExplorer/html/timeDistribution.html
deleted file mode 100644
index 7fb9e27dd..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/timeDistribution.html
+++ /dev/null
@@ -1,36 +0,0 @@
-Description
-Boxplot and a table showing the distribution of time (in days) before and after the cohort index date (cohort start date), and the time between cohort start and end date. The information is shown for all cohort entries, so not limiting to the first per person.
-
-The boxplot shows:
-
-- Whiskers: The minimum and maximum observed number of days.
-- Box: The 25th to 75th percentile.
-- Line: The median
-
-
-
-The table show the same information and more:
-
-- Average: the mean of the distribution
-- SD: Standard Deviation
-- Min: The minimum
-- P10: The 10th percentile
-- P25: The 25th percentile
-- Median: The median (50th percentile)
-- P75: The 75th percentile
-- P90: The 90th percentile
-- Max: The maximum
-
-
-
-Options
-You can select multiple data sources in the side bar to see time distributions from different data sources in the same plot and table.
-Select the cohort to explore in the side bar.
-
-What to look for
-
-- For exposure cohorts: is there sufficient time after index (either within the cohort for on-treatment analyses, or until the end of observation for intent-to-treat type analyses) to observe the outcome of interest?
-- Are there many cohorts with length = 0 when this is not expected?
-- Are the distributions comparable across data sources?
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/html/visitContext.html b/inst/shiny/DiagnosticsExplorer/html/visitContext.html
deleted file mode 100644
index e12223413..000000000
--- a/inst/shiny/DiagnosticsExplorer/html/visitContext.html
+++ /dev/null
@@ -1,18 +0,0 @@
-Description
-A table showing the relationship between the cohort start date and visits recorded in the database. For each database, the table shows:
-
-- Visits Before: the number of visits recorded before the cohort start date. Note that if a person is in the same cohort twice, visits may be counted twice.
-- Visits Ongoing: the number of visits that were ongoing (excluding the visit start date) when the cohort started. Note that if a person is in the same cohort twice, visits may be counted twice.
-- Starting Simultaneous: the number of visits that started on the same day the cohort started.
-- Visits After: the number of visits recorded after the cohort start date. Note that if a person is in the same cohort twice, visits may be counted twice.
-
-
-Options
-You can select multiple databases in the side bar to see counts from different databases side-by-side.
-Select the cohort to explore in the side bar.
-
-What to look for
-
-- Are cohorts starting in the right context? E.g. some cohorts may be expected to start predominantly in an inpatient setting.
-
-
diff --git a/inst/shiny/DiagnosticsExplorer/renv.lock b/inst/shiny/DiagnosticsExplorer/renv.lock
index c7ddd6eea..04b92b855 100644
--- a/inst/shiny/DiagnosticsExplorer/renv.lock
+++ b/inst/shiny/DiagnosticsExplorer/renv.lock
@@ -1,60 +1,91 @@
{
"R": {
- "Version": "4.0.3",
+ "Version": "4.2.2",
"Repositories": [
{
"Name": "CRAN",
- "URL": "https://cloud.r-project.org"
+ "URL": "https://rstudiopm.jnj.com/CRAN/__linux__/centos7/latest"
+ },
+ {
+ "Name": "JNJ-Internal",
+ "URL": "https://rstudiopm.jnj.com/JNJ/__linux__/centos7/latest"
+ },
+ {
+ "Name": "GitHub",
+ "URL": "https://rstudiopm.jnj.com/GitHub/__linux__/centos7/latest"
+ },
+ {
+ "Name": "JNJ-External",
+ "URL": "https://rstudiopm.jnj.com/JNJ-External/__linux__/centos7/latest"
}
]
},
"Packages": {
"BH": {
"Package": "BH",
- "Version": "1.72.0-3",
+ "Version": "1.81.0-1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [],
- "Hash": "8f9ce74c6417d61f0782cbae5fd2b7b0"
+ "Hash": "68122010f01c4dcfbe58ce7112f2433d"
},
"CirceR": {
"Package": "CirceR",
- "Version": "1.2.0",
+ "Version": "1.3.0",
"Source": "GitHub",
"RemoteType": "github",
"RemoteHost": "api.github.com",
"RemoteRepo": "CirceR",
- "RemoteUsername": "OHDSI",
+ "RemoteUsername": "ohdsi",
"RemoteRef": "HEAD",
- "RemoteSha": "38bf8b44d87f759dd4ba36835ce30627b3c24e6b",
+ "RemoteSha": "f5a0824e403ce0180b69f214b7e8801629f10692",
"Requirements": [
"R",
"RJSONIO",
"rJava"
],
- "Hash": "b8480aa484ebcee5551cfa77fac4b25c"
+ "Hash": "c402139ecd2b15b6895649374d7e526b"
},
"DBI": {
"Package": "DBI",
"Version": "1.1.3",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"methods"
],
"Hash": "b2866e62bab9378c3cc9476a1954226b"
},
+ "DT": {
+ "Package": "DT",
+ "Version": "0.27",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "crosstalk",
+ "htmltools",
+ "htmlwidgets",
+ "jquerylib",
+ "jsonlite",
+ "magrittr",
+ "promises"
+ ],
+ "Hash": "3444e6ed78763f9f13aaa39f2481eb34"
+ },
"DatabaseConnector": {
"Package": "DatabaseConnector",
- "Version": "5.1.0",
+ "Version": "6.0.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"DBI",
"R",
"SqlRender",
"bit64",
+ "checkmate",
+ "dbplyr",
+ "digest",
"methods",
"rJava",
"readr",
@@ -63,11 +94,11 @@
"urltools",
"utils"
],
- "Hash": "7efe1532a5256de9dd7f2f8d90b4e6da"
+ "Hash": "6510b8da97ce041473c0d356fd28d859"
},
"MASS": {
"Package": "MASS",
- "Version": "7.3-53",
+ "Version": "7.3-58.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@@ -78,11 +109,11 @@
"stats",
"utils"
],
- "Hash": "d1bc1c8e9c0ace57ec9ffea01021d45f"
+ "Hash": "762e1804143a332333c054759f89a706"
},
"Matrix": {
"Package": "Matrix",
- "Version": "1.4-0",
+ "Version": "1.5-1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@@ -94,13 +125,75 @@
"stats",
"utils"
],
- "Hash": "130c0caba175739d98f2963c6a407cf6"
+ "Hash": "539dc0c0c05636812f1080f473d2c177"
+ },
+ "OhdsiShinyModules": {
+ "Package": "OhdsiShinyModules",
+ "Version": "1.0.3",
+ "Source": "GitHub",
+ "Remotes": "ohdsi/CirceR, ohdsi/ResultModelManager",
+ "RemoteType": "github",
+ "RemoteHost": "api.github.com",
+ "RemoteRepo": "OhdsiShinyModules",
+ "RemoteUsername": "OHDSI",
+ "RemoteRef": "HEAD",
+ "RemoteSha": "57bd4634871c44f7eee39679fdb1ea112433e89e",
+ "Requirements": [
+ "CirceR",
+ "DT",
+ "DatabaseConnector",
+ "ParallelLogger",
+ "R",
+ "RJSONIO",
+ "SqlRender",
+ "checkmate",
+ "dplyr",
+ "ggh4x",
+ "ggiraph",
+ "ggplot2",
+ "gridExtra",
+ "htmltools",
+ "lubridate",
+ "methods",
+ "plotly",
+ "purrr",
+ "reactable",
+ "readr",
+ "rlang",
+ "rmarkdown",
+ "scales",
+ "shiny",
+ "shinyWidgets",
+ "shinycssloaders",
+ "shinydashboard",
+ "stringr",
+ "tibble",
+ "tidyr",
+ "tidyselect",
+ "tippy"
+ ],
+ "Hash": "dc66658802ef45184e46259c3e04c563"
+ },
+ "ParallelLogger": {
+ "Package": "ParallelLogger",
+ "Version": "3.1.0",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R",
+ "jsonlite",
+ "methods",
+ "snow",
+ "utils",
+ "xml2"
+ ],
+ "Hash": "8d893bed8c8bfe21217464dd3f9ec3e9"
},
"R6": {
"Package": "R6",
"Version": "2.5.1",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R"
],
@@ -108,52 +201,91 @@
},
"RColorBrewer": {
"Package": "RColorBrewer",
- "Version": "1.1-2",
+ "Version": "1.1-3",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R"
],
- "Hash": "e031418365a7f7a766181ab5a41a5716"
+ "Hash": "45f0398006e83a5b10b72a90663d8d8c"
},
"RJSONIO": {
"Package": "RJSONIO",
- "Version": "1.3-1.6",
+ "Version": "1.3-1.8",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"methods"
],
- "Hash": "0c7658433758cea5bcae50edd02b55b7"
+ "Hash": "cd79d1874fb20217463451f8c310c526"
},
"Rcpp": {
"Package": "Rcpp",
- "Version": "1.0.9",
+ "Version": "1.0.10",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"methods",
"utils"
],
- "Hash": "e9c08b94391e9f3f97355841229124f2"
+ "Hash": "e749cae40fa9ef469b6050959517453c"
+ },
+ "ResultModelManager": {
+ "Package": "ResultModelManager",
+ "Version": "0.3.0",
+ "Source": "GitHub",
+ "RemoteType": "github",
+ "RemoteHost": "api.github.com",
+ "RemoteRepo": "ResultModelManager",
+ "RemoteUsername": "OHDSI",
+ "RemoteRef": "HEAD",
+ "RemoteSha": "cb066fcd44393b4608a3cfa6a8f46d14b20a9daa",
+ "Requirements": [
+ "DBI",
+ "DatabaseConnector",
+ "ParallelLogger",
+ "R",
+ "R6",
+ "SqlRender",
+ "checkmate",
+ "dplyr",
+ "lubridate",
+ "pool",
+ "readr",
+ "rlang",
+ "zip"
+ ],
+ "Hash": "668c6c12be5114e94bd733d3a421d94a"
},
"SqlRender": {
"Package": "SqlRender",
- "Version": "1.11.0",
+ "Version": "1.12.1",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"checkmate",
"rJava",
"rlang"
],
- "Hash": "9c67a0caeab9c6340bf51e3d1aea81ea"
+ "Hash": "526b30b711da9f75e81f0a0a50a83260"
+ },
+ "anytime": {
+ "Package": "anytime",
+ "Version": "0.3.9",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "BH",
+ "R",
+ "Rcpp"
+ ],
+ "Hash": "74a64813f17b492da9c6afda6b128e3d"
},
"askpass": {
"Package": "askpass",
"Version": "1.1",
"Source": "Repository",
- "Repository": "RSPM",
+ "Repository": "CRAN",
"Requirements": [
"sys"
],
@@ -173,7 +305,7 @@
"Package": "backports",
"Version": "1.4.1",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R"
],
@@ -193,7 +325,7 @@
"Package": "bit",
"Version": "4.0.5",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R"
],
@@ -203,7 +335,7 @@
"Package": "bit64",
"Version": "4.0.5",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"bit",
@@ -213,60 +345,54 @@
],
"Hash": "9fe98599ca456d6552421db0d6772d8f"
},
- "brio": {
- "Package": "brio",
- "Version": "1.1.0",
+ "blob": {
+ "Package": "blob",
+ "Version": "1.2.3",
"Source": "Repository",
"Repository": "RSPM",
- "Requirements": [],
- "Hash": "570a24963009b9cce0869a0463c83580"
+ "Requirements": [
+ "methods",
+ "rlang",
+ "vctrs"
+ ],
+ "Hash": "10d231579bc9c06ab1c320618808d4ff"
},
"bslib": {
"Package": "bslib",
- "Version": "0.4.1",
+ "Version": "0.4.2",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
+ "base64enc",
"cachem",
"grDevices",
"htmltools",
"jquerylib",
"jsonlite",
"memoise",
+ "mime",
"rlang",
"sass"
],
- "Hash": "89a0cd0c45161e3bd1c1e74a2d65e516"
+ "Hash": "a7fbf03946ad741129dc81098722fca1"
},
"cachem": {
"Package": "cachem",
- "Version": "1.0.6",
+ "Version": "1.0.7",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"fastmap",
"rlang"
],
- "Hash": "648c5b3d71e6a37e3043617489a0a0e9"
- },
- "callr": {
- "Package": "callr",
- "Version": "3.5.1",
- "Source": "Repository",
- "Repository": "RSPM",
- "Requirements": [
- "R6",
- "processx",
- "utils"
- ],
- "Hash": "b7d7f1e926dfcd57c74ce93f5c048e80"
+ "Hash": "cda74447c42f529de601fe4d4050daef"
},
"checkmate": {
"Package": "checkmate",
"Version": "2.1.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"backports",
@@ -276,20 +402,20 @@
},
"cli": {
"Package": "cli",
- "Version": "3.4.1",
+ "Version": "3.6.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"utils"
],
- "Hash": "0d297d01734d2bcea40197bd4971a764"
+ "Hash": "3177a5a16c243adc199ba33117bd9657"
},
"clipr": {
"Package": "clipr",
"Version": "0.8.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"utils"
],
@@ -297,7 +423,7 @@
},
"colorspace": {
"Package": "colorspace",
- "Version": "2.0-0",
+ "Version": "2.1-0",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
@@ -307,15 +433,15 @@
"methods",
"stats"
],
- "Hash": "abea3384649ef37f60ef51ce002f3547"
+ "Hash": "f20c47fd52fae58b4e377c37bb8c335b"
},
"commonmark": {
"Package": "commonmark",
- "Version": "1.7",
+ "Version": "1.8.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [],
- "Hash": "0f22be39ec1d141fd03683c06f3a6e67"
+ "Hash": "b6e3e947d1d7ebf3d2bdcea1bde63fe7"
},
"cpp11": {
"Package": "cpp11",
@@ -329,7 +455,7 @@
"Package": "crayon",
"Version": "1.5.2",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"grDevices",
"methods",
@@ -337,74 +463,107 @@
],
"Hash": "e8a1e41acf02548751f45c718d55aa6a"
},
- "desc": {
- "Package": "desc",
+ "crosstalk": {
+ "Package": "crosstalk",
"Version": "1.2.0",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
- "R",
"R6",
- "assertthat",
- "crayon",
- "rprojroot",
- "utils"
+ "htmltools",
+ "jsonlite",
+ "lazyeval"
],
- "Hash": "6c8fe8fa26a23b79949375d372c7b395"
+ "Hash": "6aa54f69598c32177e920eb3402e8293"
},
- "diffobj": {
- "Package": "diffobj",
- "Version": "0.3.2",
+ "curl": {
+ "Package": "curl",
+ "Version": "5.0.0",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R"
+ ],
+ "Hash": "e4f97056611e8e6b8b852d13b7400cf1"
+ },
+ "data.table": {
+ "Package": "data.table",
+ "Version": "1.14.8",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R",
- "crayon",
+ "methods"
+ ],
+ "Hash": "b4c06e554f33344e044ccd7fdca750a9"
+ },
+ "dbplyr": {
+ "Package": "dbplyr",
+ "Version": "2.3.1",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "DBI",
+ "R",
+ "R6",
+ "blob",
+ "cli",
+ "dplyr",
+ "glue",
+ "lifecycle",
+ "magrittr",
"methods",
- "stats",
- "tools",
- "utils"
+ "pillar",
+ "purrr",
+ "rlang",
+ "tibble",
+ "tidyr",
+ "tidyselect",
+ "utils",
+ "vctrs",
+ "withr"
],
- "Hash": "16533929cf545f3c9b796780cccf5eff"
+ "Hash": "6e432b1a334fc06786e2ee8627e8cbea"
},
"digest": {
"Package": "digest",
- "Version": "0.6.27",
+ "Version": "0.6.31",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R",
"utils"
],
- "Hash": "a0cbe758a531d054b537d16dff4d58a1"
+ "Hash": "8b708f296afd9ae69f450f9640be8990"
},
"dplyr": {
"Package": "dplyr",
- "Version": "1.0.2",
+ "Version": "1.1.0",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R",
"R6",
- "ellipsis",
+ "cli",
"generics",
"glue",
"lifecycle",
"magrittr",
"methods",
+ "pillar",
"rlang",
"tibble",
"tidyselect",
"utils",
"vctrs"
],
- "Hash": "d0509913b27ea898189ee664b6030dc2"
+ "Hash": "d3c34618017e7ae252d46d79a1b9ec32"
},
"ellipsis": {
"Package": "ellipsis",
"Version": "0.3.2",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"rlang"
@@ -413,42 +572,42 @@
},
"evaluate": {
"Package": "evaluate",
- "Version": "0.14",
+ "Version": "0.20",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"methods"
],
- "Hash": "ec8ca05cffcc70569eaaad8469d2a3a7"
+ "Hash": "4b68aa51edd89a0e044a66e75ae3cc6c"
},
"fansi": {
"Package": "fansi",
- "Version": "1.0.3",
+ "Version": "1.0.4",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"grDevices",
"utils"
],
- "Hash": "83a8afdbe71839506baa9f90eebad7ec"
+ "Hash": "1d9e7ad3c8312a192dea7d3db0274fde"
},
"farver": {
"Package": "farver",
- "Version": "2.0.3",
+ "Version": "2.1.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [],
- "Hash": "dad6793a5a1f73c8e91f1a1e3e834b05"
+ "Hash": "8106d78941f34855c440ddb946b8f7a5"
},
"fastmap": {
"Package": "fastmap",
- "Version": "1.1.0",
+ "Version": "1.1.1",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [],
- "Hash": "77bd60a6157420d4ffa93b27cf6a58b8"
+ "Hash": "f7736a18de97dea803bde0a2daaafb27"
},
"filelock": {
"Package": "filelock",
@@ -460,55 +619,43 @@
},
"fontawesome": {
"Package": "fontawesome",
- "Version": "0.4.0",
+ "Version": "0.5.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"htmltools",
"rlang"
],
- "Hash": "c5a628c2570aa86a96cc6ef739d8bfda"
+ "Hash": "e80750aec5717dedc019ad7ee40e4a7c"
},
"fs": {
"Package": "fs",
- "Version": "1.5.0",
+ "Version": "1.6.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R",
"methods"
],
- "Hash": "44594a07a42e5f91fac9f93fda6d0109"
+ "Hash": "f4dcd23b67e33d851d2079f703e8b985"
},
"generics": {
"Package": "generics",
- "Version": "0.1.2",
+ "Version": "0.1.3",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"methods"
],
- "Hash": "177475892cf4a55865868527654a7741"
- },
- "getPass": {
- "Package": "getPass",
- "Version": "0.2-2",
- "Source": "Repository",
- "Repository": "CRAN",
- "Requirements": [
- "R",
- "rstudioapi",
- "utils"
- ],
- "Hash": "07a91f99e56951818ab911366db77700"
+ "Hash": "15e9634c0fcd294799e9b2e929ed1b86"
},
"ggh4x": {
"Package": "ggh4x",
"Version": "0.2.3",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"cli",
"ggplot2",
@@ -524,7 +671,7 @@
},
"ggiraph": {
"Package": "ggiraph",
- "Version": "0.8.3",
+ "Version": "0.8.6",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
@@ -537,15 +684,16 @@
"rlang",
"stats",
"systemfonts",
- "uuid"
+ "uuid",
+ "vctrs"
],
- "Hash": "f584bc4dd1ab1c65e40437fce876578e"
+ "Hash": "8b505f525831a54fa0149f457048f7a0"
},
"ggplot2": {
"Package": "ggplot2",
- "Version": "3.4.0",
+ "Version": "3.4.1",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"MASS",
"R",
@@ -564,19 +712,33 @@
"vctrs",
"withr"
],
- "Hash": "fd2aab12f54400c6bca43687231e246b"
+ "Hash": "d494daf77c4aa7f084dbbe6ca5dcaca7"
},
"glue": {
"Package": "glue",
"Version": "1.6.2",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"methods"
],
"Hash": "4f2596dfb05dac67b9dc558e5c6fba2e"
},
+ "gridExtra": {
+ "Package": "gridExtra",
+ "Version": "2.3",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "grDevices",
+ "graphics",
+ "grid",
+ "gtable",
+ "utils"
+ ],
+ "Hash": "7d7f283939f563670a697165b2cf5560"
+ },
"gtable": {
"Package": "gtable",
"Version": "0.3.1",
@@ -588,11 +750,22 @@
],
"Hash": "36b4265fb818f6a342bed217549cd896"
},
+ "highr": {
+ "Package": "highr",
+ "Version": "0.10",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R",
+ "xfun"
+ ],
+ "Hash": "06230136b2d2b9ba5805e1963fa6e890"
+ },
"hms": {
"Package": "hms",
"Version": "1.1.2",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"ellipsis",
"lifecycle",
@@ -605,40 +778,42 @@
},
"htmltools": {
"Package": "htmltools",
- "Version": "0.5.3",
+ "Version": "0.5.4",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"base64enc",
"digest",
+ "ellipsis",
"fastmap",
"grDevices",
"rlang",
"utils"
],
- "Hash": "6496090a9e00f8354b811d1a2d47b566"
+ "Hash": "9d27e99cc90bd701c0a7a63e5923f9b7"
},
"htmlwidgets": {
"Package": "htmlwidgets",
- "Version": "1.5.3",
+ "Version": "1.6.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"grDevices",
"htmltools",
"jsonlite",
+ "knitr",
+ "rmarkdown",
"yaml"
],
- "Hash": "6fdaa86d0700f8b3e92ee3c445a5a10d"
+ "Hash": "b677ee5954471eaa974c0d099a343a1a"
},
"httpuv": {
"Package": "httpuv",
- "Version": "1.5.4",
+ "Version": "1.6.9",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
- "BH",
"R",
"R6",
"Rcpp",
@@ -646,50 +821,64 @@
"promises",
"utils"
],
- "Hash": "4e6dabb220b006ccdc3b3b5ff993b205"
+ "Hash": "1046aa31a57eae8b357267a56a0b6d8b"
+ },
+ "httr": {
+ "Package": "httr",
+ "Version": "1.4.5",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R",
+ "R6",
+ "curl",
+ "jsonlite",
+ "mime",
+ "openssl"
+ ],
+ "Hash": "f6844033201269bec3ca0097bc6c97b3"
},
"isoband": {
"Package": "isoband",
- "Version": "0.2.3",
+ "Version": "0.2.7",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"grid",
- "testthat",
"utils"
],
- "Hash": "53647fb507373700028b2ce6cd30751a"
+ "Hash": "0080607b4a1a7b28979aecef976d8bc2"
},
"jquerylib": {
"Package": "jquerylib",
- "Version": "0.1.3",
+ "Version": "0.1.4",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"htmltools"
],
- "Hash": "5ff50b36f7f0832f8421745af333e73c"
+ "Hash": "5aab57a3bd297eee1c1d862735972182"
},
"jsonlite": {
"Package": "jsonlite",
- "Version": "1.8.0",
+ "Version": "1.8.4",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"methods"
],
- "Hash": "d07e729b27b372429d42d24d503613a0"
+ "Hash": "a4269a09a9b865579b2635c77e572374"
},
"keyring": {
"Package": "keyring",
- "Version": "1.1.0",
+ "Version": "1.3.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R6",
+ "askpass",
"assertthat",
"filelock",
- "getPass",
"openssl",
"rappdirs",
"sodium",
@@ -697,7 +886,23 @@
"utils",
"yaml"
],
- "Hash": "67879ff7bee13ebec7fc9244fabf4be9"
+ "Hash": "f97832aee679462739f7146fead53b11"
+ },
+ "knitr": {
+ "Package": "knitr",
+ "Version": "1.42",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R",
+ "evaluate",
+ "highr",
+ "methods",
+ "tools",
+ "xfun",
+ "yaml"
+ ],
+ "Hash": "8329a9bcc82943c8069104d4be3ee22d"
},
"labeling": {
"Package": "labeling",
@@ -712,19 +917,18 @@
},
"later": {
"Package": "later",
- "Version": "1.1.0.1",
+ "Version": "1.3.0",
"Source": "Repository",
- "Repository": "RSPM",
+ "Repository": "CRAN",
"Requirements": [
- "BH",
"Rcpp",
"rlang"
],
- "Hash": "d0a62b247165aabf397fded504660d8a"
+ "Hash": "7e7b457d7766bc47f2a5f21cc2984f8e"
},
"lattice": {
"Package": "lattice",
- "Version": "0.20-41",
+ "Version": "0.20-45",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@@ -735,13 +939,23 @@
"stats",
"utils"
],
- "Hash": "fbd9285028b0263d76d18c95ae51a53d"
+ "Hash": "b64cdbb2b340437c4ee047a1f4c4377b"
+ },
+ "lazyeval": {
+ "Package": "lazyeval",
+ "Version": "0.2.2",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R"
+ ],
+ "Hash": "d908914ae53b04d4c0c0fd72ecc35370"
},
"lifecycle": {
"Package": "lifecycle",
"Version": "1.0.3",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"cli",
@@ -752,51 +966,26 @@
},
"lubridate": {
"Package": "lubridate",
- "Version": "1.8.0",
- "Source": "Repository",
- "Repository": "CRAN",
- "Requirements": [
- "R",
- "cpp11",
- "generics",
- "methods"
- ],
- "Hash": "2ff5eedb6ee38fb1b81205c73be1be5a"
- },
- "magrittr": {
- "Package": "magrittr",
- "Version": "2.0.3",
- "Source": "Repository",
- "Repository": "CRAN",
- "Requirements": [
- "R"
- ],
- "Hash": "7ce2733a9826b3aeb1775d56fd305472"
- },
- "markdown": {
- "Package": "markdown",
- "Version": "1.1",
+ "Version": "1.9.2",
"Source": "Repository",
"Repository": "RSPM",
- "Requirements": [
- "R",
- "mime",
- "utils",
- "xfun"
+ "Requirements": [
+ "R",
+ "generics",
+ "methods",
+ "timechange"
],
- "Hash": "61e4a10781dd00d7d81dd06ca9b94e95"
+ "Hash": "e25f18436e3efd42c7c590a1c4c15390"
},
- "markdownInput": {
- "Package": "markdownInput",
- "Version": "0.1.2",
+ "magrittr": {
+ "Package": "magrittr",
+ "Version": "2.0.3",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
- "markdown",
- "shiny",
- "shinyAce"
+ "R"
],
- "Hash": "0fc45179b8fda69e2a62a093640916d4"
+ "Hash": "7ce2733a9826b3aeb1775d56fd305472"
},
"memoise": {
"Package": "memoise",
@@ -811,7 +1000,7 @@
},
"mgcv": {
"Package": "mgcv",
- "Version": "1.8-33",
+ "Version": "1.8-41",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@@ -824,17 +1013,17 @@
"stats",
"utils"
],
- "Hash": "eb7b6439bc6d812eed2cddba5edc6be3"
+ "Hash": "6b3904f13346742caa3e82dd0303d4ad"
},
"mime": {
"Package": "mime",
- "Version": "0.9",
+ "Version": "0.12",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"tools"
],
- "Hash": "e87a35ec73b157552814869f45a63aa3"
+ "Hash": "18e9c28c1d3ca1560ce30658b22ce104"
},
"munsell": {
"Package": "munsell",
@@ -849,7 +1038,7 @@
},
"nlme": {
"Package": "nlme",
- "Version": "3.1-149",
+ "Version": "3.1-160",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@@ -859,23 +1048,23 @@
"stats",
"utils"
],
- "Hash": "7c24ab3a1e3afe50388eb2d893aab255"
+ "Hash": "02e3c6e7df163aafa8477225e6827bc5"
},
"openssl": {
"Package": "openssl",
- "Version": "1.4.3",
+ "Version": "2.0.6",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"askpass"
],
- "Hash": "a399e4773075fc2375b71f45fca186c4"
+ "Hash": "0f7cd2962e3044bb940cca4f4b5cecbe"
},
"pillar": {
"Package": "pillar",
"Version": "1.8.1",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"cli",
"fansi",
@@ -888,24 +1077,6 @@
],
"Hash": "f2316df30902c81729ae9de95ad5a608"
},
- "pkgbuild": {
- "Package": "pkgbuild",
- "Version": "1.1.0",
- "Source": "Repository",
- "Repository": "RSPM",
- "Requirements": [
- "R",
- "R6",
- "callr",
- "cli",
- "crayon",
- "desc",
- "prettyunits",
- "rprojroot",
- "withr"
- ],
- "Hash": "404684bc4e3685007f9720adf13b06c1"
- },
"pkgconfig": {
"Package": "pkgconfig",
"Version": "2.0.3",
@@ -916,46 +1087,53 @@
],
"Hash": "01f28d4278f15c76cddbea05899c5d6f"
},
- "pkgload": {
- "Package": "pkgload",
- "Version": "1.1.0",
+ "plotly": {
+ "Package": "plotly",
+ "Version": "4.10.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
- "cli",
- "crayon",
- "desc",
- "methods",
- "pkgbuild",
+ "R",
+ "RColorBrewer",
+ "base64enc",
+ "crosstalk",
+ "data.table",
+ "digest",
+ "dplyr",
+ "ggplot2",
+ "htmltools",
+ "htmlwidgets",
+ "httr",
+ "jsonlite",
+ "lazyeval",
+ "magrittr",
+ "promises",
+ "purrr",
"rlang",
- "rprojroot",
- "rstudioapi",
- "utils",
- "withr"
+ "scales",
+ "tibble",
+ "tidyr",
+ "tools",
+ "vctrs",
+ "viridisLite"
],
- "Hash": "b6b150cd4709e0c0c9b5d51ac4376282"
+ "Hash": "3781cf6971c6467fa842a63725bbee9e"
},
"pool": {
"Package": "pool",
- "Version": "0.1.5",
+ "Version": "1.0.1",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"DBI",
"R",
"R6",
"later",
- "methods"
+ "methods",
+ "rlang",
+ "withr"
],
- "Hash": "73805281d4775a4849b83b5796457f17"
- },
- "praise": {
- "Package": "praise",
- "Version": "1.0.0",
- "Source": "Repository",
- "Repository": "CRAN",
- "Requirements": [],
- "Hash": "a555924add98c99d2f411e37e7d25e9f"
+ "Hash": "52d086ff1a2ccccbae6d462cb0773835"
},
"prettyunits": {
"Package": "prettyunits",
@@ -965,18 +1143,6 @@
"Requirements": [],
"Hash": "95ef9167b75dde9d2ccc3c7528393e7e"
},
- "processx": {
- "Package": "processx",
- "Version": "3.4.5",
- "Source": "Repository",
- "Repository": "RSPM",
- "Requirements": [
- "R6",
- "ps",
- "utils"
- ],
- "Hash": "22aab6098cb14edd0a5973a8438b569b"
- },
"progress": {
"Package": "progress",
"Version": "1.2.2",
@@ -992,7 +1158,7 @@
},
"promises": {
"Package": "promises",
- "Version": "1.1.1",
+ "Version": "1.2.0.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
@@ -1003,36 +1169,28 @@
"rlang",
"stats"
],
- "Hash": "a8730dcbdd19f9047774909f0ec214a4"
- },
- "ps": {
- "Package": "ps",
- "Version": "1.5.0",
- "Source": "Repository",
- "Repository": "RSPM",
- "Requirements": [
- "R",
- "utils"
- ],
- "Hash": "ebaed51a03411fd5cfc1e12d9079b353"
+ "Hash": "4ab2c43adb4d4699cf3690acd378d75d"
},
"purrr": {
"Package": "purrr",
- "Version": "0.3.4",
+ "Version": "1.0.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R",
+ "cli",
+ "lifecycle",
"magrittr",
- "rlang"
+ "rlang",
+ "vctrs"
],
- "Hash": "97def703420c8ab10d8f0e6c72101e02"
+ "Hash": "d71c815267c640f17ddbf7f16144b4bb"
},
"rJava": {
"Package": "rJava",
"Version": "1.0-6",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"methods"
@@ -1041,20 +1199,19 @@
},
"rappdirs": {
"Package": "rappdirs",
- "Version": "0.3.1",
+ "Version": "0.3.3",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
- "R",
- "methods"
+ "R"
],
- "Hash": "8c8298583adbbe76f3c2220eef71bebc"
+ "Hash": "5e3c5dc0b071b21fa128676560dbe94d"
},
"reactR": {
"Package": "reactR",
"Version": "0.4.4",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"htmltools"
],
@@ -1062,9 +1219,9 @@
},
"reactable": {
"Package": "reactable",
- "Version": "0.3.0",
+ "Version": "0.4.4",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"digest",
@@ -1073,13 +1230,13 @@
"jsonlite",
"reactR"
],
- "Hash": "377c52754f3e6c17673c79740e9296d7"
+ "Hash": "6069eb2a6597963eae0605c1875ff14c"
},
"readr": {
"Package": "readr",
- "Version": "2.1.3",
+ "Version": "2.1.4",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"R6",
@@ -1096,63 +1253,58 @@
"utils",
"vroom"
],
- "Hash": "2dfbfc673ccb3de3d8836b4b3bd23d14"
- },
- "rematch2": {
- "Package": "rematch2",
- "Version": "2.1.2",
- "Source": "Repository",
- "Repository": "CRAN",
- "Requirements": [
- "tibble"
- ],
- "Hash": "76c9e04c712a05848ae7a23d2f170a40"
+ "Hash": "b5047343b3825f37ad9d3b5d89aa1078"
},
"renv": {
"Package": "renv",
- "Version": "0.16.0-38.0.0.0.1669947056",
+ "Version": "0.16.0-40.0.0.0.1670152163",
"Source": "Repository",
"Repository": "RSPM",
- "RemoteSha": "21f7cba4d28d62d4fe711e7f229acdba02a1f7ac",
+ "RemoteSha": "66f339c71915ef4641e66f530051bc118a96cf96",
"Requirements": [
"utils"
],
- "Hash": "d7904288deb5d0f2544baa5001790e01"
+ "Hash": "d3e927b06afdecd9ea433b3f8882b572"
},
"rlang": {
"Package": "rlang",
"Version": "1.0.6",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"utils"
],
"Hash": "4ed1f8336c8d52c3e750adcdc57228a7"
},
- "rprojroot": {
- "Package": "rprojroot",
- "Version": "2.0.2",
+ "rmarkdown": {
+ "Package": "rmarkdown",
+ "Version": "2.20",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
- "R"
+ "R",
+ "bslib",
+ "evaluate",
+ "htmltools",
+ "jquerylib",
+ "jsonlite",
+ "knitr",
+ "methods",
+ "stringr",
+ "tinytex",
+ "tools",
+ "utils",
+ "xfun",
+ "yaml"
],
- "Hash": "249d8cd1e74a8f6a26194a91b47f21d1"
- },
- "rstudioapi": {
- "Package": "rstudioapi",
- "Version": "0.13",
- "Source": "Repository",
- "Repository": "CRAN",
- "Requirements": [],
- "Hash": "06c85365a03fdaf699966cc1d3cf53ea"
+ "Hash": "716fde5382293cc94a71f68c85b78d19"
},
"sass": {
"Package": "sass",
- "Version": "0.4.4",
+ "Version": "0.4.5",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R6",
"fs",
@@ -1160,7 +1312,7 @@
"rappdirs",
"rlang"
],
- "Hash": "c76cbac7ca04ce82d8c38e29729987a3"
+ "Hash": "2bb4371a4c80115518261866eab6ab11"
},
"scales": {
"Package": "scales",
@@ -1182,9 +1334,9 @@
},
"shiny": {
"Package": "shiny",
- "Version": "1.7.3",
+ "Version": "1.7.4",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"R6",
@@ -1212,43 +1364,31 @@
"withr",
"xtable"
],
- "Hash": "fe12df67fdb3b1142325cc54f100cc06"
- },
- "shinyAce": {
- "Package": "shinyAce",
- "Version": "0.4.1",
- "Source": "Repository",
- "Repository": "RSPM",
- "Requirements": [
- "R",
- "jsonlite",
- "shiny",
- "tools",
- "utils"
- ],
- "Hash": "402073a8a045c9f5ea096ed94e01d9ce"
+ "Hash": "c2eae3d8c670fa9dfa35a12066f4a1d5"
},
"shinyWidgets": {
"Package": "shinyWidgets",
- "Version": "0.6.0",
+ "Version": "0.7.6",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
+ "anytime",
"bslib",
"grDevices",
"htmltools",
"jsonlite",
+ "rlang",
"sass",
"shiny"
],
- "Hash": "7dd5f3ee96c64a47fdbc6e437ff1c7e1"
+ "Hash": "fd889b32caa37b8ed9b1e9e7ef1564bc"
},
"shinycssloaders": {
"Package": "shinycssloaders",
"Version": "1.0.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"digest",
@@ -1260,9 +1400,9 @@
},
"shinydashboard": {
"Package": "shinydashboard",
- "Version": "0.7.1",
+ "Version": "0.7.2",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"htmltools",
@@ -1270,44 +1410,55 @@
"shiny",
"utils"
],
- "Hash": "133639dc106955eee4ffb8ec73edac37"
+ "Hash": "e418b532e9bb4eb22a714b9a9f1acee7"
+ },
+ "snow": {
+ "Package": "snow",
+ "Version": "0.4-4",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R",
+ "utils"
+ ],
+ "Hash": "40b74690debd20c57d93d8c246b305d4"
},
"sodium": {
"Package": "sodium",
- "Version": "1.1",
+ "Version": "1.2.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [],
- "Hash": "9f07fda8802e9a2ed7e91f20f2d814ce"
+ "Hash": "3606bb09e0914edd4fc8313b500dcd5e"
},
"sourcetools": {
"Package": "sourcetools",
- "Version": "0.1.7",
+ "Version": "0.1.7-1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R"
],
- "Hash": "947e4e02a79effa5d512473e10f41797"
+ "Hash": "5f5a7629f956619d519205ec475fe647"
},
"stringi": {
"Package": "stringi",
- "Version": "1.7.8",
+ "Version": "1.7.12",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"stats",
"tools",
"utils"
],
- "Hash": "a68b980681bcbc84c7a67003fa796bfb"
+ "Hash": "ca8bd84263c77310739d2cf64d84d7c9"
},
"stringr": {
"Package": "stringr",
"Version": "1.5.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"cli",
@@ -1322,59 +1473,28 @@
},
"sys": {
"Package": "sys",
- "Version": "3.4",
+ "Version": "3.4.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [],
- "Hash": "b227d13e29222b4574486cfcbde077fa"
+ "Hash": "34c16f1ef796057bfa06d3f4ff818a5d"
},
"systemfonts": {
"Package": "systemfonts",
"Version": "1.0.4",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"cpp11"
],
"Hash": "90b28393209827327de889f49935140a"
},
- "testthat": {
- "Package": "testthat",
- "Version": "3.0.0",
- "Source": "Repository",
- "Repository": "RSPM",
- "Requirements": [
- "R",
- "R6",
- "brio",
- "callr",
- "cli",
- "crayon",
- "desc",
- "digest",
- "ellipsis",
- "evaluate",
- "jsonlite",
- "lifecycle",
- "magrittr",
- "methods",
- "pkgload",
- "praise",
- "processx",
- "ps",
- "rlang",
- "utils",
- "waldo",
- "withr"
- ],
- "Hash": "13298cedd051cb7b8a8972d380b559a6"
- },
"tibble": {
"Package": "tibble",
- "Version": "3.1.8",
+ "Version": "3.2.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"fansi",
@@ -1387,35 +1507,36 @@
"utils",
"vctrs"
],
- "Hash": "56b6934ef0f8c68225949a8672fe1a8f"
+ "Hash": "37695ff125982007d42a59ad10982ff2"
},
"tidyr": {
"Package": "tidyr",
- "Version": "1.2.0",
+ "Version": "1.3.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
+ "cli",
"cpp11",
"dplyr",
- "ellipsis",
"glue",
"lifecycle",
"magrittr",
"purrr",
"rlang",
+ "stringr",
"tibble",
"tidyselect",
"utils",
"vctrs"
],
- "Hash": "d8b95b7fee945d7da6888cf7eb71a49c"
+ "Hash": "e47debdc7ce599b070c8e78e8ac0cfcf"
},
"tidyselect": {
"Package": "tidyselect",
"Version": "1.2.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"cli",
@@ -1427,21 +1548,56 @@
],
"Hash": "79540e5fcd9e0435af547d885f184fd5"
},
+ "timechange": {
+ "Package": "timechange",
+ "Version": "0.2.0",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R",
+ "cpp11"
+ ],
+ "Hash": "8548b44f79a35ba1791308b61e6012d7"
+ },
+ "tinytex": {
+ "Package": "tinytex",
+ "Version": "0.44",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "xfun"
+ ],
+ "Hash": "c0f007e2eeed7722ce13d42b84a22e07"
+ },
+ "tippy": {
+ "Package": "tippy",
+ "Version": "0.1.0",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R",
+ "htmltools",
+ "htmlwidgets",
+ "jsonlite",
+ "shiny"
+ ],
+ "Hash": "39b1d69229e30314e7cba023c777f52d"
+ },
"triebeard": {
"Package": "triebeard",
- "Version": "0.3.0",
+ "Version": "0.4.1",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"Rcpp"
],
- "Hash": "847a9d113b78baca4a9a8639609ea228"
+ "Hash": "642507a148b0dd9b5620177e0a044413"
},
"tzdb": {
"Package": "tzdb",
"Version": "0.3.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"cpp11"
@@ -1452,7 +1608,7 @@
"Package": "urltools",
"Version": "1.7.3",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"Rcpp",
@@ -1463,29 +1619,29 @@
},
"utf8": {
"Package": "utf8",
- "Version": "1.2.2",
+ "Version": "1.2.3",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R"
],
- "Hash": "c9c462b759a5cc844ae25b5942654d13"
+ "Hash": "1fe17157424bb09c48a8b3b550c753bc"
},
"uuid": {
"Package": "uuid",
- "Version": "1.0-3",
+ "Version": "1.1-0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R"
],
- "Hash": "2097822ba5e4440b81a0c7525d0315ce"
+ "Hash": "f1cb46c157d080b729159d407be83496"
},
"vctrs": {
"Package": "vctrs",
- "Version": "0.5.1",
+ "Version": "0.5.2",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"cli",
@@ -1493,23 +1649,23 @@
"lifecycle",
"rlang"
],
- "Hash": "970324f6572b4fd81db507b5d4062cb0"
+ "Hash": "e4ffa94ceed5f124d429a5a5f0f5b378"
},
"viridisLite": {
"Package": "viridisLite",
- "Version": "0.3.0",
+ "Version": "0.4.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R"
],
- "Hash": "ce4f6271baa94776db692f1cb2055bee"
+ "Hash": "62f4b5da3e08d8e5bcba6cac15603f70"
},
"vroom": {
"Package": "vroom",
- "Version": "1.6.0",
+ "Version": "1.6.1",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"bit64",
@@ -1529,30 +1685,13 @@
"vctrs",
"withr"
],
- "Hash": "64f81fdead6e0d250fb041e175d123ab"
- },
- "waldo": {
- "Package": "waldo",
- "Version": "0.2.3",
- "Source": "Repository",
- "Repository": "RSPM",
- "Requirements": [
- "cli",
- "diffobj",
- "fansi",
- "glue",
- "methods",
- "rematch2",
- "rlang",
- "tibble"
- ],
- "Hash": "181d1a31b1ba2009ef20926f2ee0570c"
+ "Hash": "7015a74373b83ffaef64023f4a0f5033"
},
"withr": {
"Package": "withr",
"Version": "2.5.0",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
"Requirements": [
"R",
"grDevices",
@@ -1563,14 +1702,25 @@
},
"xfun": {
"Package": "xfun",
- "Version": "0.19",
+ "Version": "0.37",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"stats",
"tools"
],
- "Hash": "a42372606cb76f34da9d090326e9f955"
+ "Hash": "a6860e1400a8fd1ddb6d9b4230cc34ab"
+ },
+ "xml2": {
+ "Package": "xml2",
+ "Version": "1.3.3",
+ "Source": "Repository",
+ "Repository": "RSPM",
+ "Requirements": [
+ "R",
+ "methods"
+ ],
+ "Hash": "40682ed6a969ea5abfd351eb67833adc"
},
"xtable": {
"Package": "xtable",
@@ -1586,11 +1736,19 @@
},
"yaml": {
"Package": "yaml",
- "Version": "2.3.5",
+ "Version": "2.3.7",
"Source": "Repository",
- "Repository": "CRAN",
+ "Repository": "RSPM",
+ "Requirements": [],
+ "Hash": "0d0056cc5383fbc240ccd0cb584bf436"
+ },
+ "zip": {
+ "Package": "zip",
+ "Version": "2.2.2",
+ "Source": "Repository",
+ "Repository": "RSPM",
"Requirements": [],
- "Hash": "458bb38374d73bf83b1bb85e353da200"
+ "Hash": "c42bfcec3fa6a0cce17ce1f8bc684f88"
}
}
}
diff --git a/inst/shiny/DiagnosticsExplorer/server.R b/inst/shiny/DiagnosticsExplorer/server.R
index 99442e2d5..b943ae821 100644
--- a/inst/shiny/DiagnosticsExplorer/server.R
+++ b/inst/shiny/DiagnosticsExplorer/server.R
@@ -1,4 +1,7 @@
shiny::shinyServer(function(input, output, session) {
- diagExpEnv$diagnosticsExplorerModule(id = "DiagnosticsExplorer",
- envir = diagExpEnv)
+ cdModule <- OhdsiShinyModules::cohortDiagnosticsSever(id = "DiagnosticsExplorer",
+ dataSource = dataSource,
+ resultDatabaseSettings = shinySettings)
+
+
})
diff --git a/inst/shiny/DiagnosticsExplorer/tests/README.md b/inst/shiny/DiagnosticsExplorer/tests/README.md
deleted file mode 100644
index fe7f97ab4..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/README.md
+++ /dev/null
@@ -1,14 +0,0 @@
-# Testing diagnostics explorer
-
-To run tests on the shiny apps use `testthat::test_dir` as follows.
-From the context of a working directory at the package root:
-
-``` {r}
-testthat::test_dir("inst/shiny/DiagnosticsExplorer/tests")
-```
-
-From the context of a standalone DiagnosticsExplorer instance
-
-``` {r}
-testthat::test_dir("tests")
-```
\ No newline at end of file
diff --git a/inst/shiny/DiagnosticsExplorer/tests/helpers.R b/inst/shiny/DiagnosticsExplorer/tests/helpers.R
deleted file mode 100644
index e1dcd5c03..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/helpers.R
+++ /dev/null
@@ -1,10 +0,0 @@
-getTestDataSource <- function(connectionDetails) {
- connectionPool <- getConnectionPool(connectionDetails)
-
- createDatabaseDataSource(
- connection = connectionPool,
- resultsDatabaseSchema = "main",
- vocabularyDatabaseSchema = "main",
- dbms = "sqlite"
- )
-}
diff --git a/inst/shiny/DiagnosticsExplorer/tests/setup.R b/inst/shiny/DiagnosticsExplorer/tests/setup.R
deleted file mode 100644
index 68118e5bc..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/setup.R
+++ /dev/null
@@ -1,33 +0,0 @@
-library(testthat)
-
-lapply(file.path("../R", list.files("../R", pattern = "*.R")), source)
-
-dataModelSpecificationsPath <- "../data/resultsDataModelSpecification.csv"
-table1SpecPath <- normalizePath("../data/Table1SpecsLong.csv")
-options("CD-spec-1-path" = table1SpecPath)
-withr::defer({
- options("CD-spec-1-path" = NULL)
-}, testthat::teardown_env())
-
-
-activeUser <- Sys.info()[['user']]
-
-connectionDetails <- DatabaseConnector::createConnectionDetails("sqlite",
- server = "testDb.sqlite")
-
-shinySettings <- list(
- connectionDetails = connectionDetails,
- resultsDatabaseSchema = c("main"),
- vocabularyDatabaseSchemas = c("main"),
- enableAnnotation = TRUE,
- enableAuthorization = TRUE,
- userCredentialsFile = "../UserCredentials.csv",
- tablePrefix = "",
- cohortTableName = "cohort",
- databaseTableName = "database"
-)
-
-withr::defer({
- # objects from local env to avoid issues with development
- rm("shinySettings", envir = .GlobalEnv)
-}, testthat::teardown_env())
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-Annotation.R b/inst/shiny/DiagnosticsExplorer/tests/test-Annotation.R
deleted file mode 100644
index 1304d4a07..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-Annotation.R
+++ /dev/null
@@ -1,88 +0,0 @@
-## Tests for annotation module
-test_that("Post annotation functions", {
- connectionPool <- getConnectionPool(connectionDetails)
- on.exit({
- pool::poolClose(pool = connectionPool)
- })
-
- testDataSource <- createDatabaseDataSource(
- connection = connectionPool,
- resultsDatabaseSchema = "main",
- vocabularyDatabaseSchema = "main",
- dbms = "sqlite"
- )
-
- renderTranslateExecuteSql(testDataSource, "DELETE FROM ANNOTATION_LINK;")
- renderTranslateExecuteSql(testDataSource, "DELETE FROM ANNOTATION;")
-
- # Check the retreval functions work outside of shiny
- result <- getAnnotationResult(testDataSource,
- "testAnnotationServer",
- c(17492, 18342, 17720),
- c("Eunomia"))
- checkmate::assert_null(x = result)
-
- # Post test annotation
- postAnnotationResult(dataSource = testDataSource,
- diagnosticsId = "testAnnotationServer",
- cohortIds = c(17492),
- databaseIds = c("Eunomia"),
- annotation = "TEST annotation",
- createdBy = "Test user")
-
- result <- getAnnotationResult(testDataSource,
- "testAnnotationServer",
- c(17492),
- c("Eunomia"))
-
- # Make sure result matches the input
- checkmate::expect_data_frame(result$annotation, nrows = 1)
- checkmate::expect_data_frame(result$annotationLink, nrows = 1)
- expect_equal(result$annotationLink$cohortId[[1]], 17492)
- expect_equal(result$annotationLink$databaseId[[1]], "Eunomia")
- expect_equal(result$annotation$annotation[[1]], "TEST annotation")
- expect_equal(result$annotation$createdBy[[1]], "Test user")
-
- renderTranslateExecuteSql(testDataSource, "DELETE FROM ANNOTATION_LINK")
- renderTranslateExecuteSql(testDataSource, "DELETE FROM ANNOTATION")
-})
-
-test_that("Annotation shiny server functions", {
- initializeEnvironment(shinySettings,
- dataModelSpecificationsPath = dataModelSpecificationsPath)
- id <-"testAnnotationServer"
- shiny::testServer(annotationModule, args = list(
- id = id,
- dataSource = dataSource,
- activeLoggedInUser = shiny::reactiveVal("test-user"),
- selectedDatabaseIds = shiny::reactive(c("Eunomia")),
- selectedCohortIds = shiny::reactive(c(17492, 18342, 17720)),
- cohortTable = cohort,
- databaseTable = database,
- postAnnotaionEnabled = shiny::reactive(TRUE)
- ), {
-
- session$setInputs(
- targetCohort = NULL,
- database = "Eunomia"
- )
- params <- getParametersToPostAnnotation()
- expect_equal(params$database, "Eunomia")
-
- # post an entry
- postAnnotationResult(dataSource,
- id,
- selectedCohortIds(),
- selectedDatabaseIds(),
- "TEST annotation",
- "Test user")
- # check results are valid
- results <- getAnnotationResult(dataSource,
- "testAnnotationServer",
- selectedCohortIds(),
- selectedDatabaseIds())
- # Make sure result matches the input
- checkmate::expect_data_frame(results$annotation, nrows = 1)
- checkmate::expect_data_frame(results$annotationLink, nrows = 3)
- })
-})
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-CharacterizationResults.R b/inst/shiny/DiagnosticsExplorer/tests/test-CharacterizationResults.R
deleted file mode 100644
index 72db181f1..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-CharacterizationResults.R
+++ /dev/null
@@ -1,32 +0,0 @@
-test_that("getCharacterizationOutput", {
- testDataSource <- getTestDataSource(connectionDetails)
-
- on.exit(on.exit({
- pool::poolClose(pool = testDataSource$connection)
- }))
-
- # Very slow function currently
- queryRes <- queryResultCovariateValue(testDataSource,
- cohortIds = c(17492),
- analysisIds = NULL,
- databaseIds = c("Eunomia"),
- startDay = NULL,
- endDay = NULL,
- temporalCovariateValue = TRUE,
- temporalCovariateValueDist = TRUE)
-
-
- # Check full results
- results <- getCharacterizationOutput(testDataSource,
- cohortIds = c(17492),
- analysisIds = NULL,
- databaseIds = c("Eunomia"),
- startDay = NULL,
- endDay = NULL,
- temporalCovariateValue = TRUE,
- temporalCovariateValueDist = TRUE)
-
- expect_true(is.list(results))
- expect_true("covariateValue" %in% names(results))
- expect_true("covariateValueDist" %in% names(results))
-})
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-CohortCounts.R b/inst/shiny/DiagnosticsExplorer/tests/test-CohortCounts.R
deleted file mode 100644
index ede903edb..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-CohortCounts.R
+++ /dev/null
@@ -1,36 +0,0 @@
-test_that("Cohort counts page", {
- initializeEnvironment(shinySettings,
- dataModelSpecificationsPath = dataModelSpecificationsPath)
-
- # Environment should have initialized
- expect_true(exists("dataSource"))
-
- shiny::testServer(cohortCountsModule, args = list(
- id = "testcohortcounts", #Any string is ok?
- dataSource = dataSource,
- cohortTable = cohort,
- databaseTable = database,
- selectedCohorts = shiny::reactive("Any String"),
- selectedDatabaseIds = shiny::reactive("Eunomia"),
- cohortIds = shiny::reactive({c(14906, 14907)})
- ), {
- ## input tests will go here
- # session$setInputs(
- # irStratification = c("Age", "Calendar Year", "Sex"),
- # minPersonYear = 0,
- # minSubjetCount = 0 #spelling error in the module
- # )
-
- # Checking to see if a dataframe is returned and all the elements are of the
- # correct datatype
- checkmate::expect_data_frame(getResults())
- checkmate::expect_numeric(getResults()$cohortId)
- checkmate::expect_numeric(getResults()$cohortEntries)
- checkmate::expect_numeric(getResults()$cohortSubjects)
- checkmate::expect_character(getResults()$databaseId)
- checkmate::expect_character(getResults()$cohortName)
-
- #print(str(output$cohortCountsTable)) #Not sure why this isnt running
- })
-})
-
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-CohortOverlapModule.R b/inst/shiny/DiagnosticsExplorer/tests/test-CohortOverlapModule.R
deleted file mode 100644
index 028bde5e8..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-CohortOverlapModule.R
+++ /dev/null
@@ -1,42 +0,0 @@
-test_that("Cohort Overlap Page", {
- initializeEnvironment(shinySettings,
- dataModelSpecificationsPath = dataModelSpecificationsPath)
-
- # Environment should have initialized
- expect_true(exists("dataSource"))
-
- shiny::testServer(cohortOverlapModule, args = list(
- id = "testCohortOverlap", #Any string is ok?
- dataSource = dataSource,
- selectedCohorts = shiny::reactive("Any String"),
- selectedDatabaseIds = shiny::reactive("Eunomia"),
- targetCohortId = shiny::reactive({c(14906)}),
- cohortIds = shiny::reactive({c(14906, 14907)}),
- cohortTable = cohort
- ), {
- ## input tests will go here
- session$setInputs(
-
- )
-
- # Just checking to make sure all the input data is following the correct variable types
- checkmate::expect_character(cohortOverlapData()$databaseId)
- checkmate::expect_numeric(cohortOverlapData()$comparatorCohortId)
- checkmate::expect_numeric(cohortOverlapData()$eitherSubjects)
- checkmate::expect_numeric(cohortOverlapData()$tOnlySubjects)
- checkmate::expect_numeric(cohortOverlapData()$cOnlySubjects)
- checkmate::expect_numeric(cohortOverlapData()$bothSubjects)
- checkmate::expect_numeric(cohortOverlapData()$targetCohortId)
- checkmate::expect_numeric(cohortOverlapData()$cInTSubjects)
- checkmate::expect_numeric(cohortOverlapData()$cStartAfterTStart)
- checkmate::expect_numeric(cohortOverlapData()$cStartAfterTEnd)
- checkmate::expect_numeric(cohortOverlapData()$cStartBeforeTStart)
- checkmate::expect_numeric(cohortOverlapData()$cStartBeforeTEnd)
- checkmate::expect_numeric(cohortOverlapData()$cStartOnTStart)
- checkmate::expect_numeric(cohortOverlapData()$cStartOnTEnd)
-
-
-
- })
-})
-
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-DiagnosticsExplorer.R b/inst/shiny/DiagnosticsExplorer/tests/test-DiagnosticsExplorer.R
deleted file mode 100644
index e21f86a19..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-DiagnosticsExplorer.R
+++ /dev/null
@@ -1,21 +0,0 @@
-test_that("DiagnosticsExplorer loads", {
- envir <- new.env()
- initializeEnvironment(shinySettings,
- dataModelSpecificationsPath = dataModelSpecificationsPath,
- envir = envir)
-
- # Environment should have initialized
- expect_true(exists("dataSource"))
-
- shiny::testServer(diagnosticsExplorerModule, args = list(
- id = "testAnnotationServer",
- envir = envir
- ), {
- ## input tests will go here
- session$setInputs(
- tabs = "cohortCounts",
- database = "Eunomia"
- )
- expect_null(inputCohortIds())
- })
-})
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-IncidenceRate.R b/inst/shiny/DiagnosticsExplorer/tests/test-IncidenceRate.R
deleted file mode 100644
index 3a34eb834..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-IncidenceRate.R
+++ /dev/null
@@ -1,26 +0,0 @@
-test_that("Incidence Rate Page", {
- initializeEnvironment(shinySettings,
- dataModelSpecificationsPath = dataModelSpecificationsPath)
-
- # Environment should have initialized
- expect_true(exists("dataSource"))
-
- shiny::testServer(incidenceRatesModule, args = list(
- id = "testIncidenceRates", #Any string is ok?
- dataSource = dataSource,
- cohortTable = cohort,
- selectedCohorts = shiny::reactive("Any String"),
- selectedDatabaseIds = shiny::reactive("Eunomia"),
- cohortIds = shiny::reactive({c(14906, 14907)})
- ), {
- ## input tests will go here
- session$setInputs(
- irStratification = c("Age", "Calendar Year", "Sex"),
- minPersonYear = 0,
- minSubjetCount = 0 #spelling error in the module
- )
-
- checkmate::expect_data_frame(incidenceRateData())
-
- })
-})
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-IndexEventModule.R b/inst/shiny/DiagnosticsExplorer/tests/test-IndexEventModule.R
deleted file mode 100644
index faf74c56c..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-IndexEventModule.R
+++ /dev/null
@@ -1,30 +0,0 @@
-test_that("Index Event Breakdown Page", {
- initializeEnvironment(shinySettings,
- dataModelSpecificationsPath = dataModelSpecificationsPath)
-
- # Environment should have initialized
- expect_true(exists("dataSource"))
-
- shiny::testServer(indexEventBreakdownModule, args = list(
- id = "testindexeventbreakdown", #Any string is ok?
- dataSource = dataSource,
- cohortTable = cohort,
- databaseTable = database,
- selectedCohort = shiny::reactive("Any String"),
- selectedDatabaseIds = shiny::reactive("Eunomia"),
- targetCohortId = shiny::reactive({c(14906)})
- ), {
- ## input tests will go here
- session$setInputs(
- indexEventBreakdownTableRadioButton = "All"
- )
-
- checkmate::expect_numeric(indexEventBreakDownDataFilteredByRadioButton()$conceptId)
- checkmate::expect_character(indexEventBreakDownDataFilteredByRadioButton()$conceptName)
- checkmate::expect_character(indexEventBreakDownDataFilteredByRadioButton()$domainField)
- checkmate::expect_character(indexEventBreakDownDataFilteredByRadioButton()$vocabularyId)
- #Unsure if the next two are the exact translation of output columns to the ones in data
- checkmate::expect_numeric(indexEventBreakDownDataFilteredByRadioButton()$cohortSubjects) #persons?
- checkmate::expect_numeric(indexEventBreakDownDataFilteredByRadioButton()$cohortEntries) #records?
- })
-})
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-OrphanConceptsModule.R b/inst/shiny/DiagnosticsExplorer/tests/test-OrphanConceptsModule.R
deleted file mode 100644
index 47d9521c4..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-OrphanConceptsModule.R
+++ /dev/null
@@ -1,56 +0,0 @@
-test_that("Orphan Concepts Page", {
- initializeEnvironment(shinySettings,
- dataModelSpecificationsPath = dataModelSpecificationsPath)
-
- # Environment should have initialized
- expect_true(exists("dataSource"))
-
- shiny::testServer(orphanConceptsModule, args = list(
- id = "testOrphanConcepts", #Any string is ok?
- dataSource = dataSource,
- selectedCohorts = shiny::reactive("Any String"),
- selectedDatabaseIds = shiny::reactive("Eunomia"),
- targetCohortId = shiny::reactive({c(14906)}),
- selectedConceptSets = shiny::reactiveVal(NULL),
- conceptSetIds = shiny::reactive({c(0)})
- ), {
- ## input tests will go here
- session$setInputs(
- orphanConceptsType = "Non Standard Only"
- )
-
- # Checking to see if all of the data types outputted are as expected
- checkmate::expect_numeric(orphanConceptsDataReactive()$cohortId)
- checkmate::expect_numeric(orphanConceptsDataReactive()$conceptSetId)
- checkmate::expect_character(orphanConceptsDataReactive()$databaseId)
- checkmate::expect_numeric(orphanConceptsDataReactive()$conceptId)
- checkmate::expect_numeric(orphanConceptsDataReactive()$conceptCount)
- checkmate::expect_numeric(orphanConceptsDataReactive()$conceptSubjects)
- checkmate::expect_character(orphanConceptsDataReactive()$conceptSetName)
- checkmate::expect_character(orphanConceptsDataReactive()$conceptName)
- checkmate::expect_character(orphanConceptsDataReactive()$vocabularyId)
- checkmate::expect_character(orphanConceptsDataReactive()$conceptCode)
- checkmate::expect_character(orphanConceptsDataReactive()$standardConcept)
-
-
-
- # Creating my own testing function to see if standard concepts are only present when called upon
- checkForConceptType <- function(checkTable) {
- if (input$orphanConceptsType == "Standard Only") {
- return (sum(checkTable$standardConcept == "S") == length(checkTable$standardConcept))
- } else if (input$orphanConceptsType == "Non Standard Only") {
- return (sum(checkTable$standardConcept != "S" | is.na(checkTable$standardConcept)) == length(checkTable$standardConcept))
- }
- }
-
-
- # Converting the previous function to a checkmate package expectation test
- expectConceptType = function(checkTable, info = NULL, label = NULL) {
- res = checkForConceptType(checkTable)
- checkmate::makeExpectation(checkTable, res, info = info, label = label)
- }
-
- # running the test
- expectConceptType(filteringStandardConceptsReactive())
- })
-})
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-TimeDistributionsModule.R b/inst/shiny/DiagnosticsExplorer/tests/test-TimeDistributionsModule.R
deleted file mode 100644
index 23c95e641..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-TimeDistributionsModule.R
+++ /dev/null
@@ -1,40 +0,0 @@
-test_that("Time Distribution Page", {
- initializeEnvironment(shinySettings,
- dataModelSpecificationsPath = dataModelSpecificationsPath)
-
- # Environment should have initialized
- expect_true(exists("dataSource"))
-
- shiny::testServer(timeDistributionsModule, args = list(
- id = "testTimeDistributions", #Any string is ok?
- dataSource = dataSource,
- cohortTable = cohort,
- selectedCohorts = shiny::reactive("Any String"),
- selectedDatabaseIds = shiny::reactive("Eunomia"),
- cohortIds = shiny::reactive({c(14906, 14907)}),
- databaseTable = database
- ), {
- ## input tests will go here
- session$setInputs(
-
- )
-
-
- # Checking data type of each column of output matches what it should be
- checkmate::expect_numeric(timeDistributionData()$cohortId)
- checkmate::expect_character(timeDistributionData()$databaseId)
- checkmate::expect_character(timeDistributionData()$timeMetric)
- checkmate::expect_numeric(timeDistributionData()$averageValue)
- checkmate::expect_numeric(timeDistributionData()$standardDeviation)
- checkmate::expect_numeric(timeDistributionData()$minValue)
- checkmate::expect_numeric(timeDistributionData()$p10Value)
- checkmate::expect_numeric(timeDistributionData()$p25Value)
- checkmate::expect_numeric(timeDistributionData()$medianValue)
- checkmate::expect_numeric(timeDistributionData()$p75Value)
- checkmate::expect_numeric(timeDistributionData()$p90Value)
- checkmate::expect_numeric(timeDistributionData()$maxValue)
-
-
-
- })
-})
diff --git a/inst/shiny/DiagnosticsExplorer/tests/test-VisitContextModule.R b/inst/shiny/DiagnosticsExplorer/tests/test-VisitContextModule.R
deleted file mode 100644
index 949d4bea6..000000000
--- a/inst/shiny/DiagnosticsExplorer/tests/test-VisitContextModule.R
+++ /dev/null
@@ -1,62 +0,0 @@
-test_that("Visit context page", {
- initializeEnvironment(shinySettings,
- dataModelSpecificationsPath = dataModelSpecificationsPath)
-
- # Environment should have initialized
- expect_true(exists("dataSource"))
-
- shiny::testServer(visitContextModule, args = list(
- id = "testvisitcontext", #Any string is ok?
- dataSource = dataSource,
- cohortTable = cohort,
- databaseTable = database,
- selectedCohort = shiny::reactive("Any String"),
- selectedDatabaseIds = shiny::reactive("Eunomia"),
- targetCohortId = shiny::reactive({c(14906)})
- ), {
- ## input tests will go here
- session$setInputs(
- # Change this to the appropriate table filter selection
- visitContextTableFilters = "All"
- )
-
- # Checking to see if a dataframe is returned and all the elements are of the
- # correct datatype
- checkmate::expect_data_frame(getVisitContextData())
- checkmate::expect_data_frame(getVisitContexDataEnhanced())
- checkmate::expect_character(getVisitContexDataEnhanced()$databaseId)
- checkmate::expect_character(getVisitContexDataEnhanced()$visitConceptName)
-
-
- # Initializing vectors with column names
-
- beforeSelection <- c("databaseId", "visitConceptName", "Before")
- duringSelection <- c("databaseId", "visitConceptName", "During")
- simulSelection <- c("databaseId", "visitConceptName", "Simultaneous")
- afterSelection <- c("databaseId", "visitConceptName", "After")
- allSelection <- c("databaseId", "visitConceptName","Before", "During", "Simultaneous", "After")
-
- # Checking to see if the appropriate columns are represented in the data table
- # depending on what filtering selection is utilized
- if (input$visitContextTableFilters == "Before") {
- checkmate::expect_numeric(getVisitContexDataEnhanced()$Before)
- testthat::expect_equal(colnames(getVisitContexDataEnhanced()), beforeSelection)
- } else if (input$visitContextTableFilters == "During") {
- checkmate::expect_numeric(getVisitContexDataEnhanced()$During)
- testthat::expect_equal(colnames(getVisitContexDataEnhanced()), duringSelection)
- } else if (input$visitContextTableFilters == "Simultaneous") {
- checkmate::expect_numeric(getVisitContexDataEnhanced()$Simultaneous)
- testthat::expect_equal(colnames(getVisitContexDataEnhanced()), simulSelection)
- } else if (input$visitContextTableFilters == "After") {
- checkmate::expect_numeric(getVisitContexDataEnhanced()$After)
- testthat::expect_equal(colnames(getVisitContexDataEnhanced()), afterSelection)
- } else if (input$visitContextTableFilters == "All") {
- checkmate::expect_numeric(getVisitContexDataEnhanced()$Before)
- checkmate::expect_numeric(getVisitContexDataEnhanced()$During)
- checkmate::expect_numeric(getVisitContexDataEnhanced()$Simultaneous)
- checkmate::expect_numeric(getVisitContexDataEnhanced()$After)
- testthat::expect_equal(colnames(getVisitContexDataEnhanced()), allSelection)
- }
-
- })
-})
diff --git a/inst/shiny/DiagnosticsExplorer/tests/testDb.sqlite b/inst/shiny/DiagnosticsExplorer/tests/testDb.sqlite
deleted file mode 100644
index 4485a8665..000000000
Binary files a/inst/shiny/DiagnosticsExplorer/tests/testDb.sqlite and /dev/null differ
diff --git a/inst/shiny/DiagnosticsExplorer/ui.R b/inst/shiny/DiagnosticsExplorer/ui.R
index 0e5ecc287..1ea8c51a0 100644
--- a/inst/shiny/DiagnosticsExplorer/ui.R
+++ b/inst/shiny/DiagnosticsExplorer/ui.R
@@ -1,5 +1,272 @@
-diagExpEnv$dashboardUi(diagExpEnv$enabledTabs,
- diagExpEnv$enableAnnotation,
- diagExpEnv$showAnnotation,
- diagExpEnv$enableAuthorization,
- diagExpEnv$appVersionNum)
+cdUiControls <- function(ns) {
+ panels <- shiny::tagList(
+ shiny::conditionalPanel(
+ condition = "input.tabs!='incidenceRate' &
+ input.tabs != 'timeDistribution' &
+ input.tabs != 'cohortCharacterization' &
+ input.tabs != 'cohortCounts' &
+ input.tabs != 'indexEventBreakdown' &
+ input.tabs != 'cohortDefinition' &
+ input.tabs != 'conceptsInDataSource' &
+ input.tabs != 'orphanConcepts' &
+ input.tabs != 'inclusionRuleStats' &
+ input.tabs != 'visitContext' &
+ input.tabs != 'compareCohortCharacterization' &
+ input.tabs != 'cohortCharacterization' &
+ input.tabs != 'cohortOverlap'",
+ ns = ns,
+ shinyWidgets::pickerInput(
+ inputId = ns("database"),
+ label = "Database",
+ choices = NULL,
+ multiple = FALSE,
+ choicesOpt = list(style = rep_len("color: black;", 999)),
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+ shiny::conditionalPanel(
+ condition = "input.tabs=='incidenceRate' |
+ input.tabs == 'timeDistribution' |
+ input.tabs == 'cohortCounts' |
+ input.tabs == 'indexEventBreakdown' |
+ input.tabs == 'conceptsInDataSource' |
+ input.tabs == 'orphanConcepts' |
+ input.tabs == 'inclusionRuleStats' |
+ input.tabs == 'visitContext' |
+ input.tabs == 'cohortOverlap'",
+ ns = ns,
+ shinyWidgets::pickerInput(
+ inputId = ns("databases"),
+ label = "Database(s)",
+ choices = NULL,
+ multiple = TRUE,
+ choicesOpt = list(style = rep_len("color: black;", 999)),
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+ shiny::conditionalPanel(
+ condition = "input.tabs != 'databaseInformation' &
+ input.tabs != 'cohortDefinition' &
+ input.tabs != 'cohortCounts' &
+ input.tabs != 'cohortOverlap'&
+ input.tabs != 'incidenceRate' &
+ input.tabs != 'compareCohortCharacterization' &
+ input.tabs != 'cohortCharacterization' &
+ input.tabs != 'timeDistribution'",
+ ns = ns,
+ shinyWidgets::pickerInput(
+ inputId = ns("targetCohort"),
+ label = "Cohort",
+ choices = c(""),
+ multiple = FALSE,
+ choicesOpt = list(style = rep_len("color: black;", 999)),
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ liveSearchStyle = "contains",
+ size = 10,
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+ shiny::conditionalPanel(
+ condition = "input.tabs == 'cohortCounts' |
+ input.tabs == 'cohortOverlap' |
+ input.tabs == 'incidenceRate' |
+ input.tabs == 'timeDistribution'",
+ ns = ns,
+ shinyWidgets::pickerInput(
+ inputId = ns("cohorts"),
+ label = "Cohorts",
+ choices = c(""),
+ selected = c(""),
+ multiple = TRUE,
+ choicesOpt = list(style = rep_len("color: black;", 999)),
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ liveSearchStyle = "contains",
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+ shiny::conditionalPanel(
+ condition = "input.tabs == 'temporalCharacterization' |
+ input.tabs == 'conceptsInDataSource' |
+ input.tabs == 'orphanConcepts'",
+ ns = ns,
+ shinyWidgets::pickerInput(
+ inputId = ns("conceptSetsSelected"),
+ label = "Concept sets",
+ choices = c(""),
+ selected = c(""),
+ multiple = TRUE,
+ choicesOpt = list(style = rep_len("color: black;", 999)),
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ )
+ )
+
+ return(panels)
+}
+
+#' Cohort Diagnostics UI
+#' @param id Namespace id "DiagnosticsExplorer"
+#' @param enabledReports enabled reports
+cohortDiagnosticsUi <- function(id = "DiagnosticsExplorer",
+ enabledReports) {
+ ns <- shiny::NS(id)
+ headerContent <- tags$li(
+ class = "dropdown",
+ style = "margin-top: 8px !important; margin-right : 5px !important"
+ )
+
+ header <-
+ shinydashboard::dashboardHeader(title = "Cohort Diagnostics", headerContent)
+
+ sidebarMenu <-
+ shinydashboard::sidebarMenu(
+ id = ns("tabs"),
+ shinydashboard::menuItem(text = "Cohort Definition", tabName = "cohortDefinition", icon = shiny::icon("code")),
+ shinydashboard::menuItem(text = "Concepts in Data Source", tabName = "conceptsInDataSource", icon = shiny::icon("table")),
+ shinydashboard::menuItem(text = "Orphan Concepts", tabName = "orphanConcepts", icon = shiny::icon("notes-medical")),
+ shinydashboard::menuItem(text = "Cohort Counts", tabName = "cohortCounts", icon = shiny::icon("bars")),
+ shinydashboard::menuItem(text = "Incidence Rate", tabName = "incidenceRate", icon = shiny::icon("plus")),
+ if ("temporalCovariateValue" %in% enabledReports) {
+ shinydashboard::menuItem(text = "Time Distributions", tabName = "timeDistribution", icon = shiny::icon("clock"))
+ },
+ if ("indexEventBreakdown" %in% enabledReports) {
+ shinydashboard::menuItem(text = "Index Event Breakdown", tabName = "indexEventBreakdown", icon = shiny::icon("hospital"))
+ },
+ if ("visitContext" %in% enabledReports) {
+ shinydashboard::menuItem(text = "Visit Context", tabName = "visitContext", icon = shiny::icon("building"))
+ },
+ if ("relationship" %in% enabledReports) {
+ shinydashboard::menuItem(text = "Cohort Overlap", tabName = "cohortOverlap", icon = shiny::icon("circle"))
+ },
+ if ("temporalCovariateValue" %in% enabledReports) {
+ shinydashboard::menuItem(text = "Cohort Characterization", tabName = "cohortCharacterization", icon = shiny::icon("user"))
+ },
+ if ("temporalCovariateValue" %in% enabledReports) {
+ shinydashboard::menuItem(text = "Compare Characterization", tabName = "compareCohortCharacterization", icon = shiny::icon("users"))
+ },
+ shinydashboard::menuItem(text = "Meta data", tabName = "databaseInformation", icon = shiny::icon("gear", verify_fa = FALSE)),
+ # Conditional dropdown boxes in the side bar ------------------------------------------------------
+ cdUiControls(ns)
+ )
+
+ # Side bar code
+ sidebar <-
+ shinydashboard::dashboardSidebar(sidebarMenu,
+ width = NULL,
+ collapsed = FALSE
+ )
+
+ # Body - items in tabs --------------------------------------------------
+ bodyTabItems <- shinydashboard::tabItems(
+ shinydashboard::tabItem(
+ tabName = "about",
+ if ("aboutText" %in% enabledReports) {
+ HTML(aboutText)
+ }
+ ),
+ shinydashboard::tabItem(
+ tabName = "cohortDefinition",
+ OhdsiShinyModules::cohortDefinitionsView(ns("cohortDefinitions"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "cohortCounts",
+ OhdsiShinyModules::cohortCountsView(ns("cohortCounts"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "incidenceRate",
+ OhdsiShinyModules::incidenceRatesView(ns("incidenceRates"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "timeDistribution",
+ OhdsiShinyModules::timeDistributionsView(ns("timeDistributions"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "conceptsInDataSource",
+ OhdsiShinyModules::conceptsInDataSourceView(ns("conceptsInDataSource"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "orphanConcepts",
+ OhdsiShinyModules::orpahanConceptsView(ns("orphanConcepts"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "indexEventBreakdown",
+ OhdsiShinyModules::indexEventBreakdownView(ns("indexEvents"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "visitContext",
+ OhdsiShinyModules::visitContextView(ns("visitContext"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "cohortOverlap",
+ OhdsiShinyModules::cohortOverlapView(ns("cohortOverlap"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "cohortCharacterization",
+ OhdsiShinyModules::characterizationView(ns("characterization"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "compareCohortCharacterization",
+ OhdsiShinyModules::compareCohortCharacterizationView(ns("compareCohortCharacterization"))
+ ),
+ shinydashboard::tabItem(
+ tabName = "databaseInformation",
+ OhdsiShinyModules::databaseInformationView(ns("databaseInformation")),
+ )
+ )
+
+ # body
+ body <- shinydashboard::dashboardBody(
+ bodyTabItems
+ )
+
+ # main
+ ui <- shinydashboard::dashboardPage(
+ tags$head(tags$style(HTML(
+ "
+ th, td {
+ padding-right: 10px;
+ }
+
+ "
+ ))),
+ header = header,
+ sidebar = sidebar,
+ body = body
+ )
+
+ return(ui)
+}
+
+#OhdsiShinyModules::cohortDiagnosticsExplorerUi(id = "DiagnosticsExplorer")
+cohortDiagnosticsUi(id = "DiagnosticsExplorer", dataSource$enabledReports)
diff --git a/inst/shiny/DiagnosticsExplorer/www/Add-Cohort-Definition.png b/inst/shiny/DiagnosticsExplorer/www/Add-Cohort-Definition.png
deleted file mode 100644
index 8841efee2..000000000
Binary files a/inst/shiny/DiagnosticsExplorer/www/Add-Cohort-Definition.png and /dev/null differ
diff --git a/inst/shiny/DiagnosticsExplorer/www/Add-Diagnostics.png b/inst/shiny/DiagnosticsExplorer/www/Add-Diagnostics.png
deleted file mode 100644
index a101f11dc..000000000
Binary files a/inst/shiny/DiagnosticsExplorer/www/Add-Diagnostics.png and /dev/null differ
diff --git a/inst/shiny/DiagnosticsExplorer/www/Add-Insights.png b/inst/shiny/DiagnosticsExplorer/www/Add-Insights.png
deleted file mode 100644
index 4ceea988b..000000000
Binary files a/inst/shiny/DiagnosticsExplorer/www/Add-Insights.png and /dev/null differ
diff --git a/inst/shiny/DiagnosticsExplorer/www/Add-Phenotype.png b/inst/shiny/DiagnosticsExplorer/www/Add-Phenotype.png
deleted file mode 100644
index fa83bc3a7..000000000
Binary files a/inst/shiny/DiagnosticsExplorer/www/Add-Phenotype.png and /dev/null differ
diff --git a/inst/sql/sql_server/CohortRelationship.sql b/inst/sql/sql_server/CohortRelationship.sql
index b7920b9c4..f0f21c752 100644
--- a/inst/sql/sql_server/CohortRelationship.sql
+++ b/inst/sql/sql_server/CohortRelationship.sql
@@ -16,7 +16,7 @@ GROUP BY cohort_definition_id,
-- target cohort: always one subject per cohort (first time)
SELECT t.cohort_definition_id cohort_id,
c.cohort_definition_id comparator_cohort_id,
- @time_id time_id,
+ CAST(@time_id AS INT) time_id,
COUNT_BIG(DISTINCT c.subject_id) subjects,
-- present in both target and comparator
COUNT_BIG(DISTINCT CASE
diff --git a/inst/sql/sql_server/ComputeTimeSeries1.sql b/inst/sql/sql_server/ComputeTimeSeries1.sql
index 07701e6fc..f3a0c68f1 100644
--- a/inst/sql/sql_server/ComputeTimeSeries1.sql
+++ b/inst/sql/sql_server/ComputeTimeSeries1.sql
@@ -7,7 +7,7 @@
SELECT cohort_definition_id cohort_id,
time_id,
- {@stratify_by_gender} ? {gender,} : {CAST(NULL AS VARCHAR) gender, }
+ {@stratify_by_gender} ? { CASE WHEN gender IS NULL THEN 'NULL' ELSE gender END} : {'NULL'} gender,
{@stratify_by_age_group} ? {FLOOR((YEAR(period_begin) - year_of_birth) / 10) age_group,} : {CAST(NULL AS INT) age_group, }
COUNT_BIG(DISTINCT CONCAT(cast(subject_id AS VARCHAR(30)), '_', cast(cohort_start_date AS VARCHAR(30)))) records,
-- records in calendar period
diff --git a/inst/sql/sql_server/ComputeTimeSeries2.sql b/inst/sql/sql_server/ComputeTimeSeries2.sql
index ac06840cd..470d05d79 100644
--- a/inst/sql/sql_server/ComputeTimeSeries2.sql
+++ b/inst/sql/sql_server/ComputeTimeSeries2.sql
@@ -8,7 +8,7 @@
SELECT cohort_definition_id cohort_id,
time_id,
- {@stratify_by_gender} ? {gender,} : {CAST(NULL AS VARCHAR) gender, }
+ {@stratify_by_gender} ? {CASE WHEN gender IS NULL THEN 'NULL' ELSE gender END} : {'NULL'} gender,
{@stratify_by_age_group} ? {FLOOR((YEAR(period_begin) - year_of_birth) / 10) AS age_group,} : {CAST(NULL AS INT) age_group, }
COUNT_BIG(DISTINCT CONCAT(cast(subject_id AS VARCHAR(30)), '_', cast(observation_period_start_date AS VARCHAR(30)))) records, -- records in calendar month
COUNT_BIG(DISTINCT subject_id) subjects, -- unique subjects
diff --git a/inst/sql/sql_server/ComputeTimeSeries3.sql b/inst/sql/sql_server/ComputeTimeSeries3.sql
index abf33b33e..d054e0ba9 100644
--- a/inst/sql/sql_server/ComputeTimeSeries3.sql
+++ b/inst/sql/sql_server/ComputeTimeSeries3.sql
@@ -7,7 +7,7 @@
SELECT -44819062 cohort_id,
time_id,
- {@stratify_by_gender} ? {p.gender,} : {CAST(NULL AS VARCHAR) gender, }
+ {@stratify_by_gender} ? { CASE WHEN p.gender IS NULL THEN 'NULL' ELSE p.gender END} : {'NULL'} gender,
{@stratify_by_age_group} ? {FLOOR((YEAR(period_begin) - year_of_birth) / 10) AS age_group,} : {CAST(NULL AS INT) age_group, }
COUNT_BIG(DISTINCT CONCAT(cast(o.person_id AS VARCHAR(30)), '_', cast(observation_period_start_date AS VARCHAR(30)))) records, -- records in calendar month
COUNT_BIG(DISTINCT o.person_id) subjects, -- unique subjects
diff --git a/inst/sql/sql_server/CreateResultsDataModel.sql b/inst/sql/sql_server/CreateResultsDataModel.sql
index cdc9e3c65..f738f778b 100644
--- a/inst/sql/sql_server/CreateResultsDataModel.sql
+++ b/inst/sql/sql_server/CreateResultsDataModel.sql
@@ -32,6 +32,7 @@
{DEFAULT @visit_context = visit_context}
{DEFAULT @vocabulary = vocabulary}
{DEFAULT @cd_version = cd_version}
+{DEFAULT @subset_definition = subset_definition}
-- Drop old tables if exist
DROP TABLE IF EXISTS @results_schema.@annotation;
diff --git a/inst/sql/sql_server/migrations/Migration_3-v3_2_0_suport_cohort_subsets.sql b/inst/sql/sql_server/migrations/Migration_3-v3_2_0_suport_cohort_subsets.sql
new file mode 100644
index 000000000..13bda1916
--- /dev/null
+++ b/inst/sql/sql_server/migrations/Migration_3-v3_2_0_suport_cohort_subsets.sql
@@ -0,0 +1,16 @@
+-- changes incidence_rate.person_years from bigint to float
+{DEFAULT @migration = migration}
+{DEFAULT @cohort = cohort}
+{DEFAULT @subset_definition = subset_definition}
+{DEFAULT @table_prefix = ''}
+
+CREATE TABLE @database_schema.@table_prefix@subset_definition (
+ subset_definition_id BIGINT,
+ json varchar,
+ PRIMARY KEY(subset_definition_id)
+);
+
+
+ALTER TABLE @database_schema.@table_prefix@cohort ADD COLUMN subset_definition_id BIGINT;
+ALTER TABLE @database_schema.@table_prefix@cohort ADD COLUMN subset_parent BIGINT;
+ALTER TABLE @database_schema.@table_prefix@cohort ADD COLUMN is_subset INT;
diff --git a/man/executeDiagnostics.Rd b/man/executeDiagnostics.Rd
index 7219d68b2..836c50549 100644
--- a/man/executeDiagnostics.Rd
+++ b/man/executeDiagnostics.Rd
@@ -32,6 +32,7 @@ executeDiagnostics(
temporalCovariateSettings = getDefaultCovariateSettings(),
minCellCount = 5,
minCharacterizationMean = 0.01,
+ irWashoutPeriod = 0,
incremental = FALSE,
incrementalFolder = file.path(exportFolder, "incremental")
)
@@ -114,6 +115,8 @@ of such objects.}
will help reduce the file size of the characterization output, but will remove information
on covariates that have very low values. The default is 0.001 (i.e. 0.1 percent)}
+\item{irWashoutPeriod}{Number of days washout to include in calculation of incidence rates - default is 0}
+
\item{incremental}{Create only cohort diagnostics that haven't been created before?}
\item{incrementalFolder}{If \code{incremental = TRUE}, specify a folder where records are kept
diff --git a/man/launchDiagnosticsExplorer.Rd b/man/launchDiagnosticsExplorer.Rd
index 0e509e3ff..33eeb8fb3 100644
--- a/man/launchDiagnosticsExplorer.Rd
+++ b/man/launchDiagnosticsExplorer.Rd
@@ -17,6 +17,9 @@ launchDiagnosticsExplorer(
aboutText = NULL,
runOverNetwork = FALSE,
port = 80,
+ makePublishable = FALSE,
+ publishDir = file.path(getwd(), "DiagnosticsExplorer"),
+ overwritePublishDir = FALSE,
launch.browser = FALSE,
enableAnnotation = TRUE
)
@@ -55,6 +58,12 @@ If not provided, no About tab will be shown.}
\item{port}{(optional) Only used if \code{runOverNetwork} = TRUE.}
+\item{makePublishable}{(Optional) copy data files to make app publishable to posit connect/shinyapp.io}
+
+\item{publishDir}{If make publishable is true - the directory that the shiny app is copied to}
+
+\item{overwritePublishDir}{(Optional) If make publishable is true - overwrite the directory for publishing}
+
\item{launch.browser}{Should the app be launched in your default browser, or in a Shiny window.
Note: copying to clipboard will not work in a Shiny window.}
diff --git a/man/uploadResults.Rd b/man/uploadResults.Rd
index 59e5cbd16..6145d77c8 100644
--- a/man/uploadResults.Rd
+++ b/man/uploadResults.Rd
@@ -11,7 +11,8 @@ uploadResults(
forceOverWriteOfSpecifications = FALSE,
purgeSiteDataBeforeUploading = TRUE,
tempFolder = tempdir(),
- tablePrefix = ""
+ tablePrefix = "",
+ ...
)
}
\arguments{
@@ -36,6 +37,8 @@ up when the function is finished. Can be used to specify a temp folder on a driv
has sufficient space if the default system temp space is too limited.}
\item{tablePrefix}{(Optional) string to insert before table names (e.g. "cd_") for database table names}
+
+\item{...}{See ResultModelManager::uploadResults}
}
\description{
Requires the results data model tables have been created using the \code{\link{createResultsDataModel}} function.
diff --git a/tests/testthat/cohorts/CohortsToCreate.csv b/tests/testthat/cohorts/CohortsToCreate.csv
index d8e2e91f8..fd2dbc045 100644
--- a/tests/testthat/cohorts/CohortsToCreate.csv
+++ b/tests/testthat/cohorts/CohortsToCreate.csv
@@ -1,14 +1,14 @@
-atlas_id,referent_concept_id,web_api_cohort_id,cohort_id,name,cohort_name,logic_description
-17492,192671,17492,17492,17492,[PL 192671002] Gastrointestinal hemorrhage referent concept prevalent cohort: First occurrence of referent concept + descendants,[PL 192671002] Gastrointestinal hemorrhage referent concept prevalent cohort: First occurrence of referent concept + descendants
-17493,192671,17493,17493,17493,[PL 192671001] Gastrointestinal hemorrhage referent concept incident cohort: First occurrence of referent concept + descendants with >=365d prior observation,[PL 192671001] Gastrointestinal hemorrhage referent concept incident cohort: First occurrence of referent concept + descendants with >=365d prior observation
-17720,201826,17720,17720,17720,[PL 201826003] Type 2 diabetes mellitus prevalent cohort: First condition occurrence of 'Type 2 diabetes mellitus' conceptset or observation of 'History of diabetes',[PL 201826003] Type 2 diabetes mellitus prevalent cohort: First condition occurrence of 'Type 2 diabetes mellitus' conceptset or observation of 'History of diabetes'
-14909,192671,14909,14909,14909,[Cohort Diagnostics] Gastrointestinal hemorrhage for Eunomia,[Cohort Diagnostics] Gastrointestinal hemorrhage for Eunomia
-18342,192671,18342,18342,18342,"[Cohort Diagnostics] Gastrointestinal hemorrhage for Eunomia, first time in persons history","[Cohort Diagnostics] Gastrointestinal hemorrhage for Eunomia, first time in persons history"
-18345,1118084,18345,18345,18345,[1118084001] Celecoxib referent concept incident cohort: First occurrence of referent concept + descendants with >=365d prior observation,[1118084001] Celecoxib referent concept incident cohort: First occurrence of referent concept + descendants with >=365d prior observation
-18346,1118084,18346,18346,18346,[1118084002] Celecoxib referent concept incident cohort: First occurrence of referent concept + descendants,[1118084002] Celecoxib referent concept incident cohort: First occurrence of referent concept + descendants
-18347,1124300,18347,18347,18347,[1124300002] Diclofenac referent concept incident cohort: First occurrence of referent concept + descendants,[1124300002] Diclofenac referent concept incident cohort: First occurrence of referent concept + descendants
-18348,1124300,18348,18348,18348,[1124300001] Diclofenac referent concept incident cohort: First occurrence of referent concept + descendants with >=365d prior observation,[1124300001] Diclofenac referent concept incident cohort: First occurrence of referent concept + descendants with >=365d prior observation
-18349,1124300,18349,18349,18349,[1124300004] Male Diclofenac,[1124300004] Male Diclofenac
-18350,1124300,18350,18350,18350,[1124300005] Male Diclofenac with some disorder or body system,[1124300005] Male Diclofenac with some disorder or body system
-14906,1118084,14906,14906,14906,"[1118084003] All users of Celecoxis, till end of drug continuous coverage","[1118084003] All users of Celecoxis, till end of drug continuous coverage"
-14907,0,14907,14907,14907,[1124300003] Users of diclofenac with no history of gastrointestinal hemorrhage,[1124300003] Users of diclofenac with no history of gastrointestinal hemorrhage
+cohort_id,cohort_name
+17492,[PL 192671002] Gastrointestinal hemorrhage referent concept prevalent cohort: First occurrence of referent concept + descendants
+17493,[PL 192671001] Gastrointestinal hemorrhage referent concept incident cohort: First occurrence of referent concept + descendants with >=365d prior observation
+17720,[PL 201826003] Type 2 diabetes mellitus prevalent cohort: First condition occurrence of 'Type 2 diabetes mellitus' conceptset or observation of 'History of diabetes'
+14909,[Cohort Diagnostics] Gastrointestinal hemorrhage for Eunomia
+18342,"[Cohort Diagnostics] Gastrointestinal hemorrhage for Eunomia, first time in persons history"
+18345,[1118084001] Celecoxib referent concept incident cohort: First occurrence of referent concept + descendants with >=365d prior observation
+18346,[1118084002] Celecoxib referent concept incident cohort: First occurrence of referent concept + descendants
+18347,[1124300002] Diclofenac referent concept incident cohort: First occurrence of referent concept + descendants
+18348,[1124300001] Diclofenac referent concept incident cohort: First occurrence of referent concept + descendants with >=365d prior observation
+18349,[1124300004] Male Diclofenac
+18350,[1124300005] Male Diclofenac with some disorder or body system
+14906,"[1118084003] All users of Celecoxis, till end of drug continuous coverage"
+14907,[1124300003] Users of diclofenac with no history of gastrointestinal hemorrhage
diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R
index d3c3a5832..75ba366cf 100644
--- a/tests/testthat/helper.R
+++ b/tests/testthat/helper.R
@@ -18,8 +18,41 @@ with_dbc_connection <- function(connection, code) {
)[[1]])
}
+getDefaultSubsetDefinition <- function() {
+ CohortGenerator::createCohortSubsetDefinition(
+ name = "subsequent GI bleed with 365 days prior observation",
+ definitionId = 1,
+ subsetOperators = list(
+ # here we are saying 'first subset to only those patients in cohort 1778213'
+ CohortGenerator::createCohortSubset(
+ name = "with GI bleed within 30 days of cohort start",
+ cohortIds = 14909,
+ cohortCombinationOperator = "any",
+ negate = FALSE,
+ startWindow = CohortGenerator::createSubsetCohortWindow(
+ startDay = 0,
+ endDay = 30,
+ targetAnchor = "cohortStart"
+ ),
+ endWindow = CohortGenerator::createSubsetCohortWindow(
+ startDay = 0,
+ endDay = 9999999,
+ targetAnchor = "cohortStart"
+ )
+ ),
+ # Next, subset to only those with 365 days of prior observation
+ CohortGenerator::createLimitSubset(
+ name = "Observation of at least 365 days prior",
+ priorTime = 365,
+ followUpTime = 0,
+ limitTo = "firstEver"
+ )
+ )
+ )
+}
+
# Create a cohort definition set from test cohorts
-loadTestCohortDefinitionSet <- function(cohortIds = NULL) {
+loadTestCohortDefinitionSet <- function(cohortIds = NULL, useSubsets = TRUE) {
if (grepl("testthat", getwd())) {
cohortPath <- "cohorts"
} else {
@@ -37,6 +70,10 @@ loadTestCohortDefinitionSet <- function(cohortIds = NULL) {
cohortDefinitionSet <- cohortDefinitionSet %>% dplyr::filter(cohortId %in% cohortIds)
}
+ if (useSubsets) {
+ cohortDefinitionSet <- CohortGenerator::addCohortSubsetDefinition(cohortDefinitionSet, getDefaultSubsetDefinition(), targetCohortIds = c(18345))
+ }
+
cohortDefinitionSet$checksum <- computeChecksum(cohortDefinitionSet$sql)
return(cohortDefinitionSet)
diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R
index ca43ec520..22013f13f 100644
--- a/tests/testthat/setup.R
+++ b/tests/testthat/setup.R
@@ -31,10 +31,12 @@ minCellCountValue <- 5
skipCdmTests <- FALSE
if (dbms == "sqlite") {
- connectionDetails <- Eunomia::getEunomiaConnectionDetails(databaseFile = "testEunomia.sqlite")
+ databaseFile <- paste0(Sys.getpid(), "testEunomia.sqlite")
+
+ connectionDetails <- Eunomia::getEunomiaConnectionDetails(databaseFile = databaseFile)
withr::defer(
{
- unlink("testEunomia.sqlite", recursive = TRUE, force = TRUE)
+ unlink(databaseFile, recursive = TRUE, force = TRUE)
},
testthat::teardown_env()
)
@@ -62,7 +64,7 @@ if (dbms == "sqlite") {
} else {
# only test all cohorts in sqlite
cohortIds <- c(18345, 17720, 14907) # Celecoxib, Type 2 diabetes, diclofenac (no history of GIH)
- cohortTable <- paste0("ct_", gsub("[: -]", "", Sys.time(), perl = TRUE), sample(1:100, 1))
+ cohortTable <- paste0("ct_", Sys.getpid(), gsub("[: -]", "", Sys.time(), perl = TRUE), sample(1:100, 1))
if (getOption("useAllCovariates", default = FALSE)) {
temporalCovariateSettings <- getDefaultCovariateSettings()
} else {
diff --git a/tests/testthat/test-ResultsDataModel.R b/tests/testthat/test-1-ResultsDataModel.R
similarity index 79%
rename from tests/testthat/test-ResultsDataModel.R
rename to tests/testthat/test-1-ResultsDataModel.R
index afa790962..765af4263 100644
--- a/tests/testthat/test-ResultsDataModel.R
+++ b/tests/testthat/test-1-ResultsDataModel.R
@@ -10,7 +10,7 @@ if (Sys.getenv("CDM5_POSTGRESQL_SERVER") == "") {
pathToDriver = jdbcDriverFolder
)
- resultsDatabaseSchema <- paste0("r", gsub("[: -]", "", Sys.time(), perl = TRUE), sample(1:100, 1))
+ resultsDatabaseSchema <- paste0("r", Sys.getpid(), gsub("[: -]", "", Sys.time(), perl = TRUE), sample(1:100, 1))
# Always clean up
withr::defer(
@@ -229,79 +229,3 @@ test_that("Sqlite results data model", {
}
})
})
-
-
-
-
-test_that("Data removal works", {
- skip_if(
- skipResultsDm |
- skipCdmTests,
- "results data model test server not set"
- )
- specifications <- getResultsDataModelSpecifications()
-
- pgConnection <-
- DatabaseConnector::connect(connectionDetails = postgresConnectionDetails)
- with_dbc_connection(pgConnection, {
- for (tableName in unique(specifications$tableName)) {
- if (stringr::str_detect(
- string = tolower(tableName),
- pattern = "annotation",
- negate = TRUE
- )) {
- primaryKey <- specifications %>%
- dplyr::filter(tableName == !!tableName &
- primaryKey == "Yes") %>%
- dplyr::select(columnName) %>%
- dplyr::pull()
-
- if ("database_id" %in% primaryKey) {
- deleteAllRecordsForDatabaseId(
- connection = pgConnection,
- schema = resultsDatabaseSchema,
- tableName = tableName,
- databaseId = "cdmv5",
- tablePrefix = "cd_"
- )
-
- sql <-
- "SELECT COUNT(*) FROM @schema.@table_name WHERE database_id = '@database_id';"
- sql <- SqlRender::render(
- sql = sql,
- schema = resultsDatabaseSchema,
- table_name = paste0("cd_", tableName),
- database_id = "cdmv5"
- )
- databaseIdCount <-
- DatabaseConnector::querySql(pgConnection, sql)[, 1]
- expect_true(databaseIdCount == 0)
- }
- }
- }
- })
-})
-
-test_that("util functions", {
- expect_true(naToEmpty(NA) == "")
- expect_true(naToZero(NA) == 0)
-})
-
-
-test_that("No database file fails upload", {
- skip_if(skipResultsDm | skipCdmTests, "results data model test server not set")
- testZipFile <- "test.zip"
- on.exit(unlink(testZipFile, force = T))
- # Just a random file to test
- DatabaseConnector::createZipFile(testZipFile, "cohorts/CohortsToCreate.csv")
-
- expect_error(
- uploadResults(
- connectionDetails = connectionDetails,
- schema = "main",
- zipFileName = testZipFile,
- tablePrefix = "cd_"
- ),
- regexp = "database metadata file not found - cannot upload results"
- )
-})
diff --git a/tests/testthat/test-againstCdm.R b/tests/testthat/test-2-againstCdm.R
similarity index 100%
rename from tests/testthat/test-againstCdm.R
rename to tests/testthat/test-2-againstCdm.R
diff --git a/tests/testthat/test-Characterization.R b/tests/testthat/test-3-Characterization.R
similarity index 100%
rename from tests/testthat/test-Characterization.R
rename to tests/testthat/test-3-Characterization.R
diff --git a/tests/testthat/test-moduleCohortRelationship.R b/tests/testthat/test-4-moduleCohortRelationship.R
similarity index 97%
rename from tests/testthat/test-moduleCohortRelationship.R
rename to tests/testthat/test-4-moduleCohortRelationship.R
index 8b07d5636..bc442b0c2 100644
--- a/tests/testthat/test-moduleCohortRelationship.R
+++ b/tests/testthat/test-4-moduleCohortRelationship.R
@@ -67,7 +67,7 @@ test_that("Testing executeCohortRelationshipDiagnostics", {
cohort %>%
dplyr::select(cohortDefinitionId) %>%
dplyr::distinct() %>%
- dplyr::rename(cohortId = cohortDefinitionId) %>%
+ dplyr::rename("cohortId" = "cohortDefinitionId") %>%
dplyr::rowwise() %>%
dplyr::mutate(json = RJSONIO::toJSON(list(
cohortId = cohortId,
@@ -183,12 +183,13 @@ test_that("Testing executeCohortRelationshipDiagnostics", {
dplyr::inner_join(
recordKeepingFileData %>%
dplyr::select(
- cohortId,
- comparatorId
+ "cohortId",
+ "comparatorId"
) %>%
+ dplyr::distinct() %>%
dplyr::rename(
- targetCohortId = cohortId,
- comparatorCohortId = comparatorId
+ targetCohortId = "cohortId",
+ comparatorCohortId = "comparatorId"
),
by = c("targetCohortId", "comparatorCohortId")
)
@@ -282,8 +283,8 @@ test_that("Testing executeCohortRelationshipDiagnostics", {
dplyr::anti_join(
recordKeepingFileData2 %>%
dplyr::select(
- cohortId,
- comparatorId
+ "cohortId",
+ "comparatorId"
) %>%
dplyr::rename(
targetCohortId = cohortId,
diff --git a/tests/testthat/test-moduleTimeSeries.R b/tests/testthat/test-5-moduleTimeSeries.R
similarity index 99%
rename from tests/testthat/test-moduleTimeSeries.R
rename to tests/testthat/test-5-moduleTimeSeries.R
index e60d299a5..245c65f9e 100644
--- a/tests/testthat/test-moduleTimeSeries.R
+++ b/tests/testthat/test-5-moduleTimeSeries.R
@@ -33,7 +33,7 @@ test_that("Testing cohort time series execution", {
cohort %>%
dplyr::select(cohortDefinitionId) %>%
dplyr::distinct() %>%
- dplyr::rename(cohortId = cohortDefinitionId) %>%
+ dplyr::rename("cohortId" = "cohortDefinitionId") %>%
dplyr::rowwise() %>%
dplyr::mutate(json = RJSONIO::toJSON(list(
cohortId = cohortId,
diff --git a/tests/testthat/test-incremental.R b/tests/testthat/test-6-incremental.R
similarity index 98%
rename from tests/testthat/test-incremental.R
rename to tests/testthat/test-6-incremental.R
index e6d577259..7397b7494 100644
--- a/tests/testthat/test-incremental.R
+++ b/tests/testthat/test-6-incremental.R
@@ -307,13 +307,14 @@ test_that("Incremental save", {
)
- expect_equivalent(
+ expect_equal(
readr::read_csv(
tmpFile,
col_types = readr::cols(),
guess_max = min(1e7)
),
- goldStandard
+ goldStandard,
+ ignore_attr = TRUE
)
unlink(tmpFile)
})
@@ -330,13 +331,14 @@ test_that("Incremental save with empty key", {
CohortDiagnostics:::saveIncremental(newData, tmpFile, cohortId = c())
- expect_equivalent(
+ expect_equal(
readr::read_csv(
tmpFile,
col_types = readr::cols(),
guess_max = min(1e7)
),
- data
+ data,
+ ignore_attr = TRUE
)
unlink(tmpFile)
})
diff --git a/tests/testthat/test-DatabaseMigrations.R b/tests/testthat/test-7-DatabaseMigrations.R
similarity index 100%
rename from tests/testthat/test-DatabaseMigrations.R
rename to tests/testthat/test-7-DatabaseMigrations.R
diff --git a/vignettes/DatabaseModeInDiagnosticsExplorer.Rmd b/vignettes/DatabaseModeInDiagnosticsExplorer.Rmd
index f47afb438..78f795668 100644
--- a/vignettes/DatabaseModeInDiagnosticsExplorer.Rmd
+++ b/vignettes/DatabaseModeInDiagnosticsExplorer.Rmd
@@ -72,3 +72,18 @@ databaseTableName: "database"
enableAnnotation: FALSE
enableAuthorization: FALSE
```
+# Publishing
+
+To publish with a config you can use:
+
+```{r eval = FALSE}
+launchDiagnosticsExplorer(
+ shinyConfigPath = "path/to/config.yml",
+ makePublishable = TRUE,
+ publishDir = file.path(getwd(), "MyStudyDiagnosticsExplorer"),
+ overwritePublishDir = TRUE
+)
+```
+
+And press the publish button in the shiny app that loads.
+Note - that in this situation the use of secure keys with keyring is not possible.
diff --git a/vignettes/ViewingResultsUsingDiagnosticsExplorer.Rmd b/vignettes/ViewingResultsUsingDiagnosticsExplorer.Rmd
index ec2110c1e..b3e34eecc 100644
--- a/vignettes/ViewingResultsUsingDiagnosticsExplorer.Rmd
+++ b/vignettes/ViewingResultsUsingDiagnosticsExplorer.Rmd
@@ -53,6 +53,43 @@ launchDiagnosticsExplorer(sqliteDbPath = "MyCohortDiagnosticsResulst.sqlite")
```
If running the application from a R-studio environment, please make sure the sqlite file is in a folder called 'data'.
+# Publishing to Posit Connect or shinyapps.io
+
+Publishing the shiny app to a shared posit connect source can be achieved by first setting up credentials for [your server](https://docs.posit.co/connect/user/connecting/).
+You will need to contact your internal administrator for publishing and access rights.
+
+Alternatively, you can use the [shinyapps.io](https://www.shinyapps.io/admin/#/signup) service, which provides some limited free usage for hosting your applications.
+
+Firstly, it is advised that you update to the latest version of OHDSI shiny modules with:
+
+```
+remotes::install_packages('OHDSI/OhdsiShinyModules')
+```
+
+This will update the dependencies for your shiny app.
+
+Following this you will need a copyable resource for your shiny app.
+This can be achieved by launching the `DiagnosticsExplorer` with publishable options
+
+```{r tidy=FALSE,eval=FALSE}
+launchDiagnosticsExplorer(
+ sqliteDbPath = "MyCohortDiagnosticsResulst.sqlite",
+ makePublishable = TRUE,
+ publishDir = file.path(getwd(), "MyStudyDiagnosticsExplorer"),
+ overwritePublishDir = TRUE
+)
+```
+
+This will create a shiny app folder `"MyStudyDiagnosticsExplorer"` in your R working directory.
+The above will also overwrite the existing application folder and copy your sqlite file in to it.
+Following this, the shiny window should load and show a "publsh" button.
+
+
+
+After this you can follow the RStudio prompts to upload to your rsconnect/posit connect or shinyapps.io server.
+
+# Sharing a zipped copy of your shiny app
+
To automatically create a zip archive containing the `DiagnosticsExplorer` shiny application for deployment on shared environments, such as data.ohdsi.org, run the function `createDiagnosticsExplorerZip`:
```{r tidy=FALSE,eval=FALSE}
@@ -67,3 +104,5 @@ We recommend the use of a database system, when file size of the cohort diagnost
# Running over the network
If you want to run the application over the network then set `runOverNetwork = TRUE` while launching the application using 'launchDiagnosticsExplorer()'. This will make the shiny application available over your network (i.e. within your networks firewall).
+
+
diff --git a/vignettes/publish.png b/vignettes/publish.png
new file mode 100644
index 000000000..d1aea8372
Binary files /dev/null and b/vignettes/publish.png differ