From 937b1ec6410a7f6457c44d30da9157d7655c235b Mon Sep 17 00:00:00 2001 From: jreps Date: Mon, 13 Mar 2023 16:46:25 -0400 Subject: [PATCH 1/6] shiny app in package - adding shiny app --- NAMESPACE | 2 + R/ViewShiny.R | 199 ++++++++++++++++++++++++++++++++++++ inst/shinyConfig.json | 32 ++++++ man/viewCharacterization.Rd | 22 ++++ 4 files changed, 255 insertions(+) create mode 100644 R/ViewShiny.R create mode 100644 inst/shinyConfig.json create mode 100644 man/viewCharacterization.Rd diff --git a/NAMESPACE b/NAMESPACE index 91a8032..c0204a0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,5 +26,7 @@ export(saveCharacterizationSettings) export(saveDechallengeRechallengeAnalyses) export(saveRechallengeFailCaseSeriesAnalyses) export(saveTimeToEventAnalyses) +export(viewCharacterization) importFrom(dplyr,"%>%") +importFrom(methods,is) importFrom(rlang,.data) diff --git a/R/ViewShiny.R b/R/ViewShiny.R new file mode 100644 index 0000000..01676da --- /dev/null +++ b/R/ViewShiny.R @@ -0,0 +1,199 @@ +#' viewCharacterization - Interactively view the characterization results +#' +#' @description +#' This is a shiny app for viewing interactive plots and tables +#' @details +#' Input is the output of ... +#' @param resultLocation The location of the results +#' @param cohortDefinitionSet The cohortDefinitionSet extracted using webAPI +#' @return +#' Opens a shiny app for interactively viewing the results +#' +#' @export +viewCharacterization <- function( + resultLocation, + cohortDefinitionSet = NULL + ) { + + server <- file.path(resultLocation, 'sqliteCharacterization', 'sqlite.sqlite') + + connectionDetailsSettings <- list( + dbms = 'sqlite', + server = server + ) + + connectionDetails <- do.call( + what = DatabaseConnector::createConnectionDetails, + args = connectionDetailsSettings + ) + + con <- DatabaseConnector::connect(connectionDetails) + on.exit(DatabaseConnector::disconnect(con)) + + tables <- tolower(DatabaseConnector::getTableNames(con, 'main')) + + if(!'cg_cohort_definition' %in% tables){ + cohortIds <- unique( + c( + DatabaseConnector::querySql(con, 'select distinct TARGET_COHORT_ID from c_cohort_details where TARGET_COHORT_ID != 0;')$TARGET_COHORT_ID, + DatabaseConnector::querySql(con, 'select distinct OUTCOME_COHORT_ID from c_cohort_details where OUTCOME_COHORT_ID != 0;')$OUTCOME_COHORT_ID, + DatabaseConnector::querySql(con, 'select distinct TARGET_COHORT_DEFINITION_ID from c_time_to_event;')$TARGET_COHORT_DEFINITION_ID, + DatabaseConnector::querySql(con, 'select distinct OUTCOME_COHORT_DEFINITION_ID from c_time_to_event;')$OUTCOME_COHORT_DEFINITION_ID, + DatabaseConnector::querySql(con, 'select distinct TARGET_COHORT_DEFINITION_ID from c_rechallenge_fail_case_series;')$TARGET_COHORT_DEFINITION_ID, + DatabaseConnector::querySql(con, 'select distinct OUTCOME_COHORT_DEFINITION_ID from c_rechallenge_fail_case_series;')$OUTCOME_COHORT_DEFINITION_ID + ) + ) + + DatabaseConnector::insertTable( + connection = con, + databaseSchema = 'main', + tableName = 'cg_COHORT_DEFINITION', + data = data.frame( + cohortDefinitionId = cohortIds, + cohortName = getCohortNames(cohortIds, cohortDefinitionSet) + ), + camelCaseToSnakeCase = T + ) + } + + if(!'database_meta_data' %in% tables){ + dbIds <- unique( + c( + DatabaseConnector::querySql(con, 'select distinct DATABASE_ID from c_analysis_ref;')$DATABASE_ID, + DatabaseConnector::querySql(con, 'select distinct DATABASE_ID from c_dechallenge_rechallenge;')$DATABASE_ID, + DatabaseConnector::querySql(con, 'select distinct DATABASE_ID from c_time_to_event;')$DATABASE_ID + ) + ) + + DatabaseConnector::insertTable( + connection = con, + databaseSchema = 'main', + tableName = 'DATABASE_META_DATA', + data = data.frame( + databaseId = dbIds, + cdmSourceAbbreviation = paste0('database ', dbIds) + ), + camelCaseToSnakeCase = T + ) + } + + if(!'i_incidence_summary' %in% tables){ + + x <- c("refId", "databaseId", "sourceName", + "targetCohortDefinitionId", "targetName", "tarId", + "tarStartWith", "tarStartOffset", "tarEndWith", "tarEndOffset", + "subgroupId", 'subgroupName', + 'outcomeId','outcomeCohortDefinitionId', 'outcomeName', + 'clean_window', + 'ageId', 'ageGroupName', + 'genderId', 'genderName', + 'startYear', 'personsAtRiskPe', 'personsAtRisk', + 'personDaysPe', 'personDays', + 'personOutcomesPe', 'personOutcomes', + 'outcomesPe', 'outcomes', + 'incidenceProportionP100p', + 'incidenceRateP100py' + ) + df <- data.frame(matrix(ncol = length(x), nrow = 0)) + colnames(df) <- x + + DatabaseConnector::insertTable( + connection = con, + databaseSchema = 'main', + tableName = 'i_incidence_summary', + data = df, + camelCaseToSnakeCase = T + ) + } + + databaseSettings <- list( + connectionDetailSettings = connectionDetailSettings, + schema = 'main', + tablePrefix = 'c_', + cohortTablePrefix = 'cg_', + incidenceTablePrefix = 'i_', + databaseTable = 'DATABASE_META_DATA' + ) + + viewChars(databaseSettings) + +} + +viewChars <- function(databaseSettings){ + ensure_installed("ShinyAppBuilder") + ensure_installed("ResultModelManager") + + connectionDetails <- do.call( + DatabaseConnector::createConnectionDetails, + databaseSettings$connectionDetailSettings + ) + connection <- ResultModelManager::ConnectionHandler$new(connectionDetails) + databaseSettings$connectionDetailSettings <- NULL + + # set database settings into system variables + Sys.setenv("resultDatabaseDetails_characterization" = as.character(ParallelLogger::convertSettingsToJson(databaseSettings))) + + config <- ParallelLogger::loadSettingsFromJson( + fileName = system.file( + 'shinyConfig.json', + package = "Characterization" + ) + ) + + ShinyAppBuilder::viewShiny(config = config, connection = connection) +} + + + +getCohortNames <- function(cohortIds, cohortDefinitionSet){ + + if(!is.null(cohortDefinitionSet)){ + cohortNames <- sapply( + cohortIds, + function(x){ + cohortDefinitionSet$cohortName[cohortDefinitionSet$cohortId == x] + } + ) + } else{ + cohortNames <- paste0('cohort ', cohortIds) + } + + return(cohortNames) +} + + +# Borrowed from devtools: https://github.com/hadley/devtools/blob/ba7a5a4abd8258c52cb156e7b26bb4bf47a79f0b/R/utils.r#L44 +is_installed <- function (pkg, version = 0) { + installed_version <- tryCatch(utils::packageVersion(pkg), + error = function(e) NA) + !is.na(installed_version) && installed_version >= version +} + +# Borrowed and adapted from devtools: https://github.com/hadley/devtools/blob/ba7a5a4abd8258c52cb156e7b26bb4bf47a79f0b/R/utils.r#L74 +ensure_installed <- function(pkg) { + if (!is_installed(pkg)) { + msg <- paste0(sQuote(pkg), " must be installed for this functionality.") + if (interactive()) { + message(msg, "\nWould you like to install it?") + if (utils::menu(c("Yes", "No")) == 1) { + if(pkg%in%c("ShinyAppBuilder", "ResultModelManager")){ + + # add code to check for devtools... + dvtCheck <- tryCatch(utils::packageVersion('devtools'), + error = function(e) NA) + if(is.na(dvtCheck)){ + utils::install.packages('devtools') + } + + devtools::install_github(paste0('OHDSI/',pkg)) + }else{ + utils::install.packages(pkg) + } + } else { + stop(msg, call. = FALSE) + } + } else { + stop(msg, call. = FALSE) + } + } +} diff --git a/inst/shinyConfig.json b/inst/shinyConfig.json new file mode 100644 index 0000000..98114b2 --- /dev/null +++ b/inst/shinyConfig.json @@ -0,0 +1,32 @@ +{ + "shinyModules": [ + { + "id": "about", + "tabName": "About", + "tabText": "About", + "shinyModulePackage": "OhdsiShinyModules", + "uiFunction": "aboutViewer", + "serverFunction": "aboutServer", + "databaseConnectionKeyService": null, + "databaseConnectionKeyUsername": null, + "infoBoxFile": "aboutHelperFile()", + "icon": "info", + "keyring": true, + "order": 1 + }, + { + "id": "characterization", + "tabName": "Characterization", + "tabText": "Characterization", + "shinyModulePackage": "OhdsiShinyModules", + "uiFunction": "descriptionViewer", + "serverFunction": "descriptionServer", + "databaseConnectionKeyService": "resultDatabaseDetails", + "databaseConnectionKeyUsername": "characterization", + "infoBoxFile": "descriptionHelperFile()", + "icon": "chart-line", + "keyring": false, + "order": 2 + } + ] +} diff --git a/man/viewCharacterization.Rd b/man/viewCharacterization.Rd new file mode 100644 index 0000000..712066a --- /dev/null +++ b/man/viewCharacterization.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ViewShiny.R +\name{viewCharacterization} +\alias{viewCharacterization} +\title{viewCharacterization - Interactively view the characterization results} +\usage{ +viewCharacterization(resultLocation, cohortDefinitionSet = NULL) +} +\arguments{ +\item{resultLocation}{The location of the results} + +\item{cohortDefinitionSet}{The cohortDefinitionSet extracted using webAPI} +} +\value{ +Opens a shiny app for interactively viewing the results +} +\description{ +This is a shiny app for viewing interactive plots and tables +} +\details{ +Input is the output of ... +} From 79cba46099fe49082a59e434e22dc583150a4bc8 Mon Sep 17 00:00:00 2001 From: jreps Date: Mon, 13 Mar 2023 16:48:59 -0400 Subject: [PATCH 2/6] Update DESCRIPTION adding shiny packages to description --- DESCRIPTION | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6e7ab62..9a3eb9c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,10 +30,14 @@ Suggests: kableExtra, knitr, markdown, + ResultModelManager, + ShinyAppBuilder, withr Remotes: ohdsi/FeatureExtraction, - ohdsi/Eunomia + ohdsi/Eunomia, + ohdsi/ResultModelManager, + ohdsi/ShinyAppBuilder NeedsCompilation: no RoxygenNote: 7.2.3 Encoding: UTF-8 From 41a438403046f73ceb3737bcf4eceb111329220a Mon Sep 17 00:00:00 2001 From: jreps Date: Tue, 14 Mar 2023 08:48:15 -0400 Subject: [PATCH 3/6] Update ViewShiny.R fixed missing s typo in connectionDetailsSettings --- R/ViewShiny.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/ViewShiny.R b/R/ViewShiny.R index 01676da..0a3b5b6 100644 --- a/R/ViewShiny.R +++ b/R/ViewShiny.R @@ -107,7 +107,7 @@ viewCharacterization <- function( } databaseSettings <- list( - connectionDetailSettings = connectionDetailSettings, + connectionDetailsSettings = connectionDetailsSettings, schema = 'main', tablePrefix = 'c_', cohortTablePrefix = 'cg_', @@ -125,10 +125,10 @@ viewChars <- function(databaseSettings){ connectionDetails <- do.call( DatabaseConnector::createConnectionDetails, - databaseSettings$connectionDetailSettings + databaseSettings$connectionDetailsSettings ) connection <- ResultModelManager::ConnectionHandler$new(connectionDetails) - databaseSettings$connectionDetailSettings <- NULL + databaseSettings$connectionDetailsSettings <- NULL # set database settings into system variables Sys.setenv("resultDatabaseDetails_characterization" = as.character(ParallelLogger::convertSettingsToJson(databaseSettings))) From 1c081acf5f0107ce1d6b21500abac0e05c3fdb67 Mon Sep 17 00:00:00 2001 From: jreps Date: Tue, 14 Mar 2023 08:56:23 -0400 Subject: [PATCH 4/6] fixing R check fixing R check --- DESCRIPTION | 1 + NAMESPACE | 1 - R/Characterization.R | 1 - R/HelperFunctions.R | 6 +++--- 4 files changed, 4 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9a3eb9c..ef9569c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,6 +25,7 @@ Imports: readr, rlang Suggests: + devtools, testthat, Eunomia, kableExtra, diff --git a/NAMESPACE b/NAMESPACE index c0204a0..dfa7bce 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,5 +28,4 @@ export(saveRechallengeFailCaseSeriesAnalyses) export(saveTimeToEventAnalyses) export(viewCharacterization) importFrom(dplyr,"%>%") -importFrom(methods,is) importFrom(rlang,.data) diff --git a/R/Characterization.R b/R/Characterization.R index 20b810e..3885f20 100644 --- a/R/Characterization.R +++ b/R/Characterization.R @@ -18,6 +18,5 @@ "_PACKAGE" #' @importFrom rlang .data -#' @importFrom methods is #' @importFrom dplyr %>% NULL diff --git a/R/HelperFunctions.R b/R/HelperFunctions.R index eb98ea6..98b40d5 100644 --- a/R/HelperFunctions.R +++ b/R/HelperFunctions.R @@ -29,7 +29,7 @@ connectionDetails, errorMessages ) { - if (is(connectionDetails, "connectionDetails")) { + if (inherits(connectionDetails, "connectionDetails")) { checkmate::assertClass( x = connectionDetails, classes = "connectionDetails", @@ -99,7 +99,7 @@ return() } - if(class(settings) == 'timeToEventSettings'){ + if(inherits(settings,'timeToEventSettings')){ settings <- list(settings) } @@ -133,7 +133,7 @@ return() } - if(class(settings) == 'aggregateCovariateSettings'){ + if(inherits(settings,'aggregateCovariateSettings')){ settings <- list(settings) } From a217d88b6be87f14080007437d4fc992944ce485 Mon Sep 17 00:00:00 2001 From: jreps Date: Tue, 14 Mar 2023 12:44:39 -0400 Subject: [PATCH 5/6] shiny app test code - added tests to shiny app - restructured shiny app code to help code coverage --- R/ViewShiny.R | 28 ++++-- tests/testthat/test-viewShiny.R | 149 ++++++++++++++++++++++++++++++++ 2 files changed, 172 insertions(+), 5 deletions(-) create mode 100644 tests/testthat/test-viewShiny.R diff --git a/R/ViewShiny.R b/R/ViewShiny.R index 0a3b5b6..9215598 100644 --- a/R/ViewShiny.R +++ b/R/ViewShiny.R @@ -15,6 +15,18 @@ viewCharacterization <- function( cohortDefinitionSet = NULL ) { + databaseSettings <- prepareCharacterizationShiny( + resultLocation = resultLocation, + cohortDefinitionSet = cohortDefinitionSet + ) + + viewChars(databaseSettings) +} + +prepareCharacterizationShiny <- function( + resultLocation, + cohortDefinitionSet + ){ server <- file.path(resultLocation, 'sqliteCharacterization', 'sqlite.sqlite') connectionDetailsSettings <- list( @@ -93,7 +105,7 @@ viewCharacterization <- function( 'outcomesPe', 'outcomes', 'incidenceProportionP100p', 'incidenceRateP100py' - ) + ) df <- data.frame(matrix(ncol = length(x), nrow = 0)) colnames(df) <- x @@ -115,11 +127,13 @@ viewCharacterization <- function( databaseTable = 'DATABASE_META_DATA' ) - viewChars(databaseSettings) - + return(databaseSettings) } -viewChars <- function(databaseSettings){ +viewChars <- function( + databaseSettings, + testApp = F + ){ ensure_installed("ShinyAppBuilder") ensure_installed("ResultModelManager") @@ -140,7 +154,11 @@ viewChars <- function(databaseSettings){ ) ) - ShinyAppBuilder::viewShiny(config = config, connection = connection) + if(!testApp){ + ShinyAppBuilder::viewShiny(config = config, connection = connection) + } else{ + ShinyAppBuilder::createShinyApp(config = config, connection = connection) + } } diff --git a/tests/testthat/test-viewShiny.R b/tests/testthat/test-viewShiny.R new file mode 100644 index 0000000..93599ad --- /dev/null +++ b/tests/testthat/test-viewShiny.R @@ -0,0 +1,149 @@ +context("ViewShiny") + +# create a folder with results for the shiny app +resultLocation <- file.path(tempdir(), 'shinyResults') +if(!dir.exists(resultLocation)){ + dir.create(resultLocation, recursive = T) +} + +test_that("is_installed", { + testthat::expect_equal(is_installed('FeatureExtraction'), T) + testthat::expect_equal(is_installed('MadeUp4u834t3f'), F) +}) + +test_that("ensure_installed", { + testthat::expect_equal(ensure_installed('FeatureExtraction'), NULL) +}) + +test_that("prepareCharacterizationShiny works", { + + targetIds <- c(1, 2, 4) + outcomeIds <- c(3) + + timeToEventSettings1 <- createTimeToEventSettings( + targetIds = 1, + outcomeIds = c(3, 4) + ) + timeToEventSettings2 <- createTimeToEventSettings( + targetIds = 2, + outcomeIds = c(3, 4) + ) + + dechallengeRechallengeSettings <- createDechallengeRechallengeSettings( + targetIds = targetIds, + outcomeIds = outcomeIds, + dechallengeStopInterval = 30, + dechallengeEvaluationWindow = 31 + ) + + aggregateCovariateSettings1 <- createAggregateCovariateSettings( + targetIds = targetIds, + outcomeIds = outcomeIds, + riskWindowStart = 1, + startAnchor = "cohort start", + riskWindowEnd = 365, + endAnchor = "cohort start", + covariateSettings = FeatureExtraction::createCovariateSettings( + useDemographicsGender = T, + useDemographicsAge = T, + useDemographicsRace = T + ) + ) + + aggregateCovariateSettings2 <- createAggregateCovariateSettings( + targetIds = targetIds, + outcomeIds = outcomeIds, + riskWindowStart = 1, + startAnchor = "cohort start", + riskWindowEnd = 365, + endAnchor = "cohort start", + covariateSettings = FeatureExtraction::createCovariateSettings( + useConditionOccurrenceLongTerm = T + ) + ) + + characterizationSettings <- createCharacterizationSettings( + timeToEventSettings = list( + timeToEventSettings1, + timeToEventSettings2 + ), + dechallengeRechallengeSettings = list( + dechallengeRechallengeSettings + ), + aggregateCovariateSettings = list( + aggregateCovariateSettings1, + aggregateCovariateSettings2 + ) + ) + + runCharacterizationAnalyses( + connectionDetails = connectionDetails, + cdmDatabaseSchema = "main", + targetDatabaseSchema = "main", + targetTable = "cohort", + outcomeDatabaseSchema = "main", + outcomeTable = "cohort", + characterizationSettings = characterizationSettings, + saveDirectory = resultLocation, + tablePrefix = "c_", + databaseId = "1" + ) + +settings <- prepareCharacterizationShiny( + resultLocation = resultLocation, + cohortDefinitionSet = NULL +) + +testthat::expect_true(settings$schema == 'main') +testthat::expect_true(settings$tablePrefix == 'c_') +testthat::expect_true(settings$cohortTablePrefix == 'cg_') +testthat::expect_true(settings$incidenceTablePrefix == 'i_') +testthat::expect_true(settings$databaseTable == 'DATABASE_META_DATA') + +connectionDetailsTest <- do.call( + what = DatabaseConnector::createConnectionDetails, + args = list( + dbms = 'sqlite', + server = file.path(resultLocation, 'sqliteCharacterization', 'sqlite.sqlite') + ) +) +conTest <- DatabaseConnector::connect(connectionDetailsTest) +tables <- tolower( + DatabaseConnector::getTableNames( + connection = conTest, + databaseSchema = 'main' + ) +) + +# make sure the extra tables are added +testthat::expect_true('cg_cohort_definition' %in% tables) +testthat::expect_true('database_meta_data' %in% tables) +testthat::expect_true('i_incidence_summary' %in% tables) + +}) + +test_that("shiny app works", { + + settings <- prepareCharacterizationShiny( + resultLocation = resultLocation, + cohortDefinitionSet = NULL + ) + + app <- viewChars( + databaseSettings = settings, + testApp = T + ) + +shiny::testServer( + app = app, + args = list( + ), + expr = { + + testthat::expect_equal(runServer[['About']],0) + session$setInputs(menu = 'About') + testthat::expect_equal(runServer[['About']],1) + + }) + +}) From e848a05a0288f6c2c9ad45587c86de1b2a94de1e Mon Sep 17 00:00:00 2001 From: jreps Date: Tue, 14 Mar 2023 13:04:48 -0400 Subject: [PATCH 6/6] fixing warnings/notes - removing class() and adding inherits() - adding shiny to depends for tests --- DESCRIPTION | 1 + R/HelperFunctions.R | 2 +- R/RunCharacterization.R | 6 +++--- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ef9569c..40270bb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,6 +33,7 @@ Suggests: markdown, ResultModelManager, ShinyAppBuilder, + shiny, withr Remotes: ohdsi/FeatureExtraction, diff --git a/R/HelperFunctions.R b/R/HelperFunctions.R index 98b40d5..a13eb9d 100644 --- a/R/HelperFunctions.R +++ b/R/HelperFunctions.R @@ -65,7 +65,7 @@ return() } - if(class(settings) == 'dechallengeRechallengeSettings'){ + if(inherits(settings, 'dechallengeRechallengeSettings')){ settings <- list(settings) } diff --git a/R/RunCharacterization.R b/R/RunCharacterization.R index df98e3c..0a03bb0 100644 --- a/R/RunCharacterization.R +++ b/R/RunCharacterization.R @@ -33,13 +33,13 @@ createCharacterizationSettings <- function( errorMessages = errorMessages ) - if (class(timeToEventSettings) == "timeToEventSettings") { + if (inherits(timeToEventSettings, "timeToEventSettings")) { timeToEventSettings <- list(timeToEventSettings) } - if (class(dechallengeRechallengeSettings) == "dechallengeRechallengeSettings") { + if (inherits(dechallengeRechallengeSettings, "dechallengeRechallengeSettings")) { dechallengeRechallengeSettings <- list(dechallengeRechallengeSettings) } - if (class(aggregateCovariateSettings) == "aggregateCovariateSettings") { + if (inherits(aggregateCovariateSettings, "aggregateCovariateSettings")) { aggregateCovariateSettings <- list(aggregateCovariateSettings) }