From 949af28677193eae199a9eeba41da07fc72f3319 Mon Sep 17 00:00:00 2001 From: edward-burn <9583964+edward-burn@users.noreply.github.com> Date: Sun, 17 Nov 2024 15:19:54 +0000 Subject: [PATCH 1/6] v0.1.0 --- DESCRIPTION | 9 +- R/shinyDiagnostics.R | 5 + inst/example_cohorts/GIBleed_male.json | 120 ++++++++++++++++++++ inst/example_cohorts/GiBleed_default.json | 57 ++++++++++ inst/shiny/scripts/preprocess.R | 53 +++++---- inst/shiny/server.R | 124 +++++++++++++-------- inst/shiny/ui.R | 4 +- tests/testthat/test-addCodelistAttribute.R | 37 ++++++ tests/testthat/test-shinyDiagnostics.R | 8 +- 9 files changed, 339 insertions(+), 78 deletions(-) create mode 100644 inst/example_cohorts/GIBleed_male.json create mode 100644 inst/example_cohorts/GiBleed_default.json diff --git a/DESCRIPTION b/DESCRIPTION index 0511e76..2595b06 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,14 +1,16 @@ Package: PhenotypeR Type: Package Title: Assess Study Cohorts Using a Common Data Model -Version: 0.0.900 +Version: 0.1.0 Authors@R: c( person("Edward", "Burn", , "edward.burn@ndorms.ox.ac.uk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-9286-1128")), person("Marti", "Catala", , "marti.catalasabate@ndorms.ox.ac.uk", role = c("aut"), comment = c(ORCID = "0000-0003-3308-9905")), person("Xihang", "Chen", , "xihang.chen@ndorms.ox.ac.uk", - role = c("aut"), comment = c(ORCID = "0009-0001-8112-8959")), + role = c("aut"), comment = c(ORCID = "0009-0001-8112-8959")), + person("Marta", "Alcalde-Herraiz", , "marta.alcaldeherraiz@ndorms.ox.ac.uk", + role = c("aut"), comment = c(ORCID = "0009-0002-4405-1814")), person("Albert", "Prats-Uribe", , "albert.prats-uribe@ndorms.ox.ac.uk", role = "aut", comment = c(ORCID = "0000-0003-1202-9153"))) Description: Phenotype study cohorts in data mapped to the @@ -22,7 +24,6 @@ Suggests: DBI, gt, omock, - OmopSketch, testthat (>= 3.0.0), knitr, visOmopResults, @@ -52,10 +53,10 @@ Imports: dplyr, IncidencePrevalence (>= 0.8.0), omopgenerics, + OmopSketch, magrittr, purrr, rlang, - usethis, vctrs URL: https://ohdsi.github.io/PhenotypeR/ VignetteBuilder: knitr diff --git a/R/shinyDiagnostics.R b/R/shinyDiagnostics.R index ab19c41..853da09 100644 --- a/R/shinyDiagnostics.R +++ b/R/shinyDiagnostics.R @@ -55,6 +55,11 @@ shinyDiagnostics <- function(result, directory, open = rlang::is_interactive()){ + if(file.exists(file.path(directory, "shiny"))){ + cli::cli_inform(c("i" = "Existing {.strong shiny} folder in {.arg directory} will be overwritten.")) + unlink(file.path(directory, "shiny"), recursive = TRUE) + } + file.copy(from = system.file("shiny", package = "PhenotypeR"), to = directory, diff --git a/inst/example_cohorts/GIBleed_male.json b/inst/example_cohorts/GIBleed_male.json new file mode 100644 index 0000000..10faebf --- /dev/null +++ b/inst/example_cohorts/GIBleed_male.json @@ -0,0 +1,120 @@ +{ + "ConceptSets": [ + { + "id": 0, + "name": "Gastrointestinal hemorrhage", + "expression": { + "items": [ + { + "concept": { + "CONCEPT_CLASS_ID": "Clinical Finding", + "CONCEPT_CODE": "74474003", + "CONCEPT_ID": 192671, + "CONCEPT_NAME": "Gastrointestinal hemorrhage", + "DOMAIN_ID": "Condition", + "INVALID_REASON": "V", + "INVALID_REASON_CAPTION": "Valid", + "STANDARD_CONCEPT": "S", + "STANDARD_CONCEPT_CAPTION": "Standard", + "VOCABULARY_ID": "SNOMED" + }, + "includeDescendants": true + } + ] + } + } + ], + "PrimaryCriteria": { + "CriteriaList": [ + { + "ConditionOccurrence": { + "CodesetId": 0 + } + } + ], + "ObservationWindow": { + "PriorDays": 0, + "PostDays": 0 + }, + "PrimaryCriteriaLimit": { + "Type": "All" + } + }, + "QualifiedLimit": { + "Type": "First" + }, + "ExpressionLimit": { + "Type": "First" + }, + "InclusionRules": [ + { + "name": "Male", + "expression": { + "Type": "ALL", + "CriteriaList": [], + "DemographicCriteriaList": [ + { + "Gender": [ + { + "CONCEPT_CODE": "M", + "CONCEPT_ID": 8507, + "CONCEPT_NAME": "MALE", + "DOMAIN_ID": "Gender", + "INVALID_REASON_CAPTION": "Unknown", + "STANDARD_CONCEPT_CAPTION": "Unknown", + "VOCABULARY_ID": "Gender" + } + ] + } + ], + "Groups": [] + } + }, + { + "name": "30 days prior observation", + "expression": { + "Type": "ALL", + "CriteriaList": [ + { + "Criteria": { + "ObservationPeriod": {} + }, + "StartWindow": { + "Start": { + "Coeff": -1 + }, + "End": { + "Days": 30, + "Coeff": -1 + }, + "UseEventEnd": false + }, + "EndWindow": { + "Start": { + "Days": 0, + "Coeff": 1 + }, + "End": { + "Coeff": 1 + }, + "UseEventEnd": true + }, + "Occurrence": { + "Type": 2, + "Count": 1 + } + } + ], + "DemographicCriteriaList": [], + "Groups": [] + } + } + ], + "CensoringCriteria": [], + "CollapseSettings": { + "CollapseType": "ERA", + "EraPad": 0 + }, + "CensorWindow": {}, + "cdmVersionRange": ">=5.0.0" +} diff --git a/inst/example_cohorts/GiBleed_default.json b/inst/example_cohorts/GiBleed_default.json new file mode 100644 index 0000000..e308e52 --- /dev/null +++ b/inst/example_cohorts/GiBleed_default.json @@ -0,0 +1,57 @@ +{ + "ConceptSets": [ + { + "id": 0, + "name": "gibleed", + "expression": { + "items": [ + { + "concept": { + "CONCEPT_CLASS_ID": "Clinical Finding", + "CONCEPT_CODE": "74474003", + "CONCEPT_ID": 192671, + "CONCEPT_NAME": "Gastrointestinal hemorrhage", + "DOMAIN_ID": "Condition", + "INVALID_REASON": "V", + "INVALID_REASON_CAPTION": "Valid", + "STANDARD_CONCEPT": "S", + "STANDARD_CONCEPT_CAPTION": "Standard", + "VOCABULARY_ID": "SNOMED" + }, + "includeDescendants": false + } + ] + } + } + ], + "PrimaryCriteria": { + "CriteriaList": [ + { + "ConditionOccurrence": { + "CodesetId": 0 + } + } + ], + "ObservationWindow": { + "PriorDays": 0, + "PostDays": 0 + }, + "PrimaryCriteriaLimit": { + "Type": "First" + } + }, + "QualifiedLimit": { + "Type": "First" + }, + "ExpressionLimit": { + "Type": "First" + }, + "InclusionRules": [], + "CensoringCriteria": [], + "CollapseSettings": { + "CollapseType": "ERA", + "EraPad": 0 + }, + "CensorWindow": {}, + "cdmVersionRange": ">=5.0.0" +} diff --git a/inst/shiny/scripts/preprocess.R b/inst/shiny/scripts/preprocess.R index 2dca423..9b17931 100644 --- a/inst/shiny/scripts/preprocess.R +++ b/inst/shiny/scripts/preprocess.R @@ -15,9 +15,12 @@ library(sortable) library(visOmopResults) library(shinycssloaders) -data <- omopgenerics::importSummarisedResult(file.path(getwd(),"data", "raw")) +data <- omopgenerics::importSummarisedResult(file.path(getwd(),"data", "raw")) if(nrow(data) == 0){ - cli::cli_abort("No data found in data/raw") + cli::cli_warn("No data found in data/raw") + choices <- list() +} else{ + choices <- getChoices(data, flatten = TRUE) } data <- data |> correctSettings() @@ -33,7 +36,6 @@ data <- data |> # ) # } # -choices <- getChoices(data, flatten = TRUE) # # remove matched cohorts from choices choices$summarise_characteristics_grouping_cohort_name <- choices$summarise_characteristics_grouping_cohort_name[ @@ -47,18 +49,21 @@ for(i in seq_along(settingsUsed)){ workingSetting) } -codeUseCohorts <- unique(dataFiltered$cohort_code_use |> - visOmopResults::splitAll() |> pull("cohort_name")) -codeUseCodelist <- unique(dataFiltered$cohort_code_use |> - visOmopResults::splitAll() |> pull("codelist_name")) +if(!is.null(dataFiltered$cohort_code_use)){ + codeUseCohorts <- unique(dataFiltered$cohort_code_use |> + visOmopResults::splitAll() |> pull("cohort_name")) + codeUseCodelist <- unique(dataFiltered$cohort_code_use |> + visOmopResults::splitAll() |> pull("codelist_name")) + choices$cohort_code_use_grouping_cohort_name <- codeUseCohorts + selected$cohort_code_use_grouping_cohort_name <- codeUseCohorts[1] + +} selected <- choices selected$summarise_characteristics_grouping_cohort_name <- selected$summarise_characteristics_grouping_cohort_name[1] selected$summarise_large_scale_characteristics_grouping_cohort_name <- selected$summarise_large_scale_characteristics_grouping_cohort_name[1] -choices$cohort_code_use_grouping_cohort_name <- codeUseCohorts -selected$cohort_code_use_grouping_cohort_name <- codeUseCohorts[1] choices$compare_large_scale_characteristics_grouping_cdm_name <- choices$summarise_large_scale_characteristics_grouping_cdm_name choices$compare_large_scale_characteristics_grouping_cohort_1 <- choices$summarise_large_scale_characteristics_grouping_cohort_name @@ -67,12 +72,13 @@ selected$compare_large_scale_characteristics_grouping_cdm_name <- choices$compar selected$compare_large_scale_characteristics_grouping_cohort_1 <- choices$compare_large_scale_characteristics_grouping_cohort_1[1] selected$compare_large_scale_characteristics_grouping_cohort_2 <- choices$compare_large_scale_characteristics_grouping_cohort_1[2] +if(!is.null(dataFiltered$summarise_large_scale_characteristics)){ choices$summarise_large_scale_characteristics_grouping_domain <- settings(dataFiltered$summarise_large_scale_characteristics) |> pull("table_name") -selected$summarise_large_scale_characteristics_grouping_domain <- choices$summarise_large_scale_characteristics_grouping_domain - choices$summarise_large_scale_characteristics_grouping_time_window <- unique(dataFiltered$summarise_large_scale_characteristics |> - pull("variable_level")) + pull("variable_level")) +} +selected$summarise_large_scale_characteristics_grouping_domain <- choices$summarise_large_scale_characteristics_grouping_domain selected$summarise_large_scale_characteristics_grouping_time_window <-choices$summarise_large_scale_characteristics_grouping_time_window choices$compare_large_scale_characteristics_grouping_time_window <- choices$summarise_large_scale_characteristics_grouping_time_window @@ -80,15 +86,17 @@ choices$compare_large_scale_characteristics_grouping_table <- choices$summarise_ selected$compare_large_scale_characteristics_grouping_time_window <- selected$summarise_large_scale_characteristics_grouping_time_window selected$compare_large_scale_characteristics_grouping_table <- selected$summarise_large_scale_characteristics_grouping_domain +if(!is.null(dataFiltered$orphan_code_use)){ + orphanCodelist <- unique(dataFiltered$orphan_code_use |> + visOmopResults::splitAll() |> pull("codelist_name")) + orphanCdm <- unique(dataFiltered$orphan_code_use |> + visOmopResults::addSettings() |> pull("cdm_name")) + choices$orphan_grouping_cdm_name <- orphanCdm + choices$orphan_grouping_codelist_name <- orphanCodelist + selected$orphan_grouping_cdm_name <- orphanCdm + selected$orphan_grouping_cohort_name <- orphanCodelist[1] +} -orphanCodelist <- unique(dataFiltered$orphan_code_use |> - visOmopResults::splitAll() |> pull("codelist_name")) -orphanCdm <- unique(dataFiltered$orphan_code_use |> - visOmopResults::addSettings() |> pull("cdm_name")) -choices$orphan_grouping_cdm_name <- orphanCdm -choices$orphan_grouping_codelist_name <- orphanCodelist -selected$orphan_grouping_cdm_name <- orphanCdm -selected$orphan_grouping_cohort_name <- orphanCodelist[1] # # unmappedCodelist <- unique(dataFiltered$unmapped_codes |> # visOmopResults::splitAll() |> pull("codelist_name")) @@ -111,16 +119,15 @@ selected$incidence_grouping_incidence_start_date # # min_incidence_start <- min(as.Date(selected$incidence_grouping_incidence_start_date)) # max_incidence_end <- max(as.Date(selected$incidence_grouping_incidence_end_date)) - +if(!is.null(dataFiltered$prevalence)){ prevalence_cohorts <- unique(dataFiltered$prevalence |> pull("variable_level")) choices$prevalence_settings_outcome_cohort_name <- prevalence_cohorts selected$prevalence_settings_outcome_cohort_name <- prevalence_cohorts[1] +} selected$prevalence_settings_analysis_interval <- selected$prevalence_settings_analysis_interval[1] selected$prevalence_settings_denominator_age_group <- selected$prevalence_settings_denominator_age_group[1] selected$prevalence_settings_denominator_sex <- selected$prevalence_settings_denominator_sex[1] -selected$prevalence_grouping_prevalence_start_date - save(data, dataFiltered, selected, choices, file = here::here("data", "appData.RData")) diff --git a/inst/shiny/server.R b/inst/shiny/server.R index b2daa52..44a4322 100644 --- a/inst/shiny/server.R +++ b/inst/shiny/server.R @@ -27,50 +27,13 @@ server <- function(input, output, session) { } }) # summarise_omop_snapshot ----- - ## tidy summarise_omop_snapshot ----- - getTidyDataSummariseOmopSnapshot <- shiny::reactive({ - res <- dataFiltered$summarise_omop_snapshot |> - filterData("summarise_omop_snapshot", input) |> - tidyData() - - # columns to eliminate - colsEliminate <- colnames(res) - colsEliminate <- colsEliminate[!colsEliminate %in% c( - input$summarise_omop_snapshot_tidy_columns, "variable_name", "variable_level", - "estimate_name", "estimate_type", "estimate_value" - )] - - # pivot - pivot <- input$summarise_omop_snapshot_tidy_pivot - if (pivot != "none") { - vars <- switch(pivot, - "estimates" = "estimate_name", - "estimates and variables" = c("variable_name", "variable_level", "estimate_name") - ) - res <- res |> - visOmopResults::pivotEstimates(pivotEstimatesBy = vars) - } - - res |> - dplyr::select(!dplyr::all_of(colsEliminate)) - }) - output$summarise_omop_snapshot_tidy <- DT::renderDT({ - DT::datatable( - getTidyDataSummariseOmopSnapshot(), - options = list(scrollX = TRUE), - rownames = FALSE - ) - }) - output$summarise_omop_snapshot_tidy_download <- shiny::downloadHandler( - filename = "tidy_summarise_omop_snapshot.csv", - content = function(file) { - getTidyDataSummariseOmopSnapshot() |> - readr::write_csv(file = file) - } - ) ## output summarise_omop_snapshot ----- ## output 17 ----- createOutput17 <- shiny::reactive({ + if (is.null(dataFiltered$summarise_omop_snapshot)) { + validate("No snapshot in results") + } + OmopSketch::tableOmopSnapshot( dataFiltered$summarise_omop_snapshot ) %>% @@ -97,6 +60,9 @@ server <- function(input, output, session) { # achilles_code_use ----- createOutputAchillesCodeUse <- shiny::reactive({ + if (is.null(dataFiltered$achilles_code_use)) { + validate("No achilles code use in results") + } achillesFiltered <- dataFiltered$achilles_code_use |> filterData("achilles_code_use", input) CodelistGenerator::tableAchillesCodeUse(achillesFiltered, @@ -154,6 +120,9 @@ server <- function(input, output, session) { ## output summarise_observation_period ----- ## output 15 ----- createOutput15 <- shiny::reactive({ + if (is.null(dataFiltered$summarise_observation_period)) { + validate("No observation period summary in results") + } OmopSketch::tableObservationPeriod( dataFiltered$summarise_observation_period )%>% @@ -243,6 +212,9 @@ server <- function(input, output, session) { ## output cohort_code_use ----- ## output 12 ----- createOutput12 <- shiny::reactive({ + if (is.null(dataFiltered$cohort_code_use)) { + validate("No cohort code use in results") + } result <- dataFiltered$cohort_code_use |> filterData("cohort_code_use", input) CodelistGenerator::tableCohortCodeUse( @@ -414,6 +386,10 @@ server <- function(input, output, session) { ## output summarise_cohort_overlap ----- ## output 1 ----- createOutput1 <- shiny::reactive({ + if (is.null(dataFiltered$summarise_cohort_overlap)) { + validate("No cohort overlap in results") + } + result <- dataFiltered$summarise_cohort_overlap |> filterData("summarise_cohort_overlap", input) CohortCharacteristics::tableCohortOverlap( @@ -444,6 +420,10 @@ server <- function(input, output, session) { ## output 2 ----- createOutput2 <- shiny::reactive({ + if (is.null(dataFiltered$summarise_cohort_overlap)) { + validate("No cohort overlap in results") + } + result <- dataFiltered$summarise_cohort_overlap |> filterData("summarise_cohort_overlap", input) CohortCharacteristics::plotCohortOverlap( @@ -516,7 +496,11 @@ server <- function(input, output, session) { ## output summarise_characteristics ----- ## output 7 ----- createOutput7 <- shiny::reactive({ - + + if (is.null(dataFiltered$summarise_characteristics)) { + validate("No summarised characteristics in results") + } + if(isTRUE(input$summarise_characteristics_include_matched)){ selectedCohorts <- c( input$summarise_characteristics_grouping_cohort_name, @@ -526,8 +510,7 @@ server <- function(input, output, session) { } else { selectedCohorts <- input$summarise_characteristics_grouping_cohort_name } - - + result <- dataFiltered$summarise_characteristics |> dplyr::filter(cdm_name %in% input$summarise_characteristics_grouping_cdm_name, group_level %in% selectedCohorts) @@ -591,7 +574,12 @@ server <- function(input, output, session) { # summarise_large_scale_characteristics ----- ## tidy summarise_large_scale_characteristics ----- getTidyDataSummariseLargeScaleCharacteristics <- shiny::reactive({ + if (is.null(dataFiltered$summarise_large_scale_characteristics)) { + validate("No large scale characteristics in results") + } + lsc_data <- dataFiltered$summarise_large_scale_characteristics |> + filter(!is.na(estimate_value)) |> visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_grouping_domain) |> dplyr::filter(cdm_name %in% input$summarise_large_scale_characteristics_grouping_cdm_name ) |> dplyr::filter(group_level %in% input$summarise_large_scale_characteristics_grouping_cohort_name) |> @@ -623,6 +611,11 @@ server <- function(input, output, session) { ## output summarise_large_scale_characteristics ----- ## output 0 ----- createOutput0 <- shiny::reactive({ + + if (is.null(dataFiltered$summarise_large_scale_characteristics)) { + validate("No large scale characteristics in results") + } + if (input$top_n < 1) { validate("Top n must be between 1 and 100") } @@ -631,6 +624,7 @@ server <- function(input, output, session) { } lsc_data <- dataFiltered$summarise_large_scale_characteristics |> + filter(!is.na(estimate_value)) |> visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_grouping_domain) |> dplyr::filter(cdm_name %in% input$summarise_large_scale_characteristics_grouping_cdm_name ) |> dplyr::filter(group_level %in% input$summarise_large_scale_characteristics_grouping_cohort_name) |> @@ -709,7 +703,11 @@ server <- function(input, output, session) { ## output incidence ----- ## output 18 ----- createOutput18 <- shiny::reactive({ - # browser() + + if (is.null(dataFiltered$incidence)) { + validate("No incidence in results") + } + result <- dataFiltered$incidence |> filterData("incidence", input) IncidencePrevalence::tableIncidence( @@ -742,6 +740,10 @@ server <- function(input, output, session) { ## output 19 ----- createOutput19 <- shiny::reactive({ + if (is.null(dataFiltered$incidence)) { + validate("No incidence in results") + } + result <- dataFiltered$incidence |> filterData("incidence", input) @@ -818,6 +820,11 @@ server <- function(input, output, session) { ## output incidence_attrition ----- ## output 22 ----- createOutput22 <- shiny::reactive({ + + if (is.null(dataFiltered$incidence_attrition)) { + validate("No incidence attrition in results") + } + result <- dataFiltered$incidence_attrition |> filterData("incidence_attrition", input) IncidencePrevalence::tableIncidenceAttrition( @@ -890,6 +897,10 @@ server <- function(input, output, session) { ## output prevalence ----- ## output prev1 ----- createOutputprev1 <- shiny::reactive({ + if (is.null(dataFiltered$prevalence)) { + validate("No prevalence in results") + } + result <- dataFiltered$prevalence |> filter(cdm_name %in% input$prevalence_grouping_cdm_name, variable_level %in% input$prevalence_settings_outcome_cohort_name) |> @@ -926,6 +937,11 @@ server <- function(input, output, session) { ## output prev2 ----- createOutputprev2 <- shiny::reactive({ + + if (is.null(dataFiltered$prevalence)) { + validate("No prevalence in results") + } + result <- dataFiltered$prevalence |> filter(cdm_name %in% input$prevalence_grouping_cdm_name, variable_level %in% input$prevalence_settings_outcome_cohort_name) |> @@ -964,6 +980,11 @@ server <- function(input, output, session) { # compare lsc ---- outputLSC <- shiny::reactive({ + + if (is.null(dataFiltered$summarise_large_scale_characteristics)) { + validate("No large scale characteristics in results") + } + dataFiltered$summarise_large_scale_characteristics |> filter(variable_level %in% input$compare_large_scale_characteristics_grouping_time_window) |> filterSettings(table_name %in% input$compare_large_scale_characteristics_grouping_table) @@ -1071,6 +1092,15 @@ server <- function(input, output, session) { ## output orphan ----- ## output 99 ----- createOutput99 <- shiny::reactive({ + + if (is.null(dataFiltered$prevalence)) { + validate("No orphan codes in results") + } + + if (is.null(dataFiltered$orphan_code_use)) { + validate("No orphan codes in results") + } + result <- dataFiltered$orphan_code_use |> dplyr::filter(cdm_name %in% input$orphan_grouping_cdm_name, group_level %in% input$orphan_grouping_codelist_name) @@ -1106,6 +1136,10 @@ server <- function(input, output, session) { ## output orphan ----- ## output 99 ----- createOutputUnmapped <- shiny::reactive({ + if (is.null(dataFiltered$unmapped_codes)) { + validate("No unmapped codes in results") + } + CodelistGenerator::tableUnmappedCodes( dataFiltered$unmapped_codes |> dplyr::filter(cdm_name %in% input$unmapped_grouping_cdm_name, diff --git a/inst/shiny/ui.R b/inst/shiny/ui.R index 8707990..6dd2898 100644 --- a/inst/shiny/ui.R +++ b/inst/shiny/ui.R @@ -258,12 +258,12 @@ ui <- bslib::page_navbar( header = NULL, sortable::add_rank_list( text = "none", - labels = c("variable_name", "variable_level", "estimate_name"), + labels = c("variable_name", "variable_level"), input_id = "orphan_gt_99_none" ), sortable::add_rank_list( text = "header", - labels = c("cdm_name", "cohort_name"), + labels = c("cdm_name", "cohort_name", "estimate_name"), input_id = "orphan_gt_99_header" ), sortable::add_rank_list( diff --git a/tests/testthat/test-addCodelistAttribute.R b/tests/testthat/test-addCodelistAttribute.R index faaea44..6cc9b29 100644 --- a/tests/testthat/test-addCodelistAttribute.R +++ b/tests/testthat/test-addCodelistAttribute.R @@ -111,3 +111,40 @@ test_that("test append codelist to existing", { expect_true(omopgenerics::cohortCodelist(cohort, 2) == 5) }) + +test_that("test eunomia", { + skip_if_not_installed("CirceR") + skip_if_not(CDMConnector::eunomia_is_available()) + + con <- DBI::dbConnect(duckdb::duckdb(CDMConnector::eunomia_dir())) + cdm <- CDMConnector::cdm_from_con( + con = con, cdm_name = "eunomia", + cdm_schema = "main", write_schema = "main" + ) + + cohortSet <- CDMConnector::readCohortSet( + system.file(package = "PhenotypeR", "example_cohorts")) + cohortCodes <- CodelistGenerator::codesFromCohort( + system.file(package = "PhenotypeR", "example_cohorts"), cdm = cdm + ) + + cdm <- CDMConnector::generateCohortSet(cdm = cdm, cohortSet = cohortSet, + name = "gibleed") + cdm$gibleed <- addCodelistAttribute(cohort = cdm$gibleed, + codelist = list("gibleed_default" = 1L, + "gibleed_male" = 2L)) + + + + expect_true(omopgenerics::cohortCodelist(cdm$gibleed, + omopgenerics::settings(cdm$gibleed) |> + dplyr::filter(cohort_name == "gibleed_default") |> + dplyr::pull("cohort_definition_id"))[[1]] == 1) + expect_true(omopgenerics::cohortCodelist(cdm$gibleed, + omopgenerics::settings(cdm$gibleed) |> + dplyr::filter(cohort_name == "gibleed_male") |> + dplyr::pull("cohort_definition_id"))[[1]] == 2) + + CDMConnector::cdmDisconnect(cdm) + +}) diff --git a/tests/testthat/test-shinyDiagnostics.R b/tests/testthat/test-shinyDiagnostics.R index a819aca..4532763 100644 --- a/tests/testthat/test-shinyDiagnostics.R +++ b/tests/testthat/test-shinyDiagnostics.R @@ -3,10 +3,10 @@ test_that("basic working example with one cohort", { skip_on_cran() # empty result - should still work without error - # expect_no_error( - # shinyDiagnostics(result = omopgenerics::emptySummarisedResult(), - # directory = here::here()) - # ) + expect_no_error( + shinyDiagnostics(result = omopgenerics::emptySummarisedResult(), + directory = here::here()) + ) # with results cdm_local <- omock::mockCdmReference() |> From cd4e512d53617547786e5feea02a3258537d0b91 Mon Sep 17 00:00:00 2001 From: edward-burn <9583964+edward-burn@users.noreply.github.com> Date: Sun, 17 Nov 2024 15:30:46 +0000 Subject: [PATCH 2/6] usethis --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2595b06..6744dd4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -57,6 +57,7 @@ Imports: magrittr, purrr, rlang, - vctrs + vctrs, + usethis URL: https://ohdsi.github.io/PhenotypeR/ VignetteBuilder: knitr From aaab4d457b11f9b4e93bc065a2dbe1eb95a08111 Mon Sep 17 00:00:00 2001 From: edward-burn <9583964+edward-burn@users.noreply.github.com> Date: Tue, 19 Nov 2024 10:10:36 +0000 Subject: [PATCH 3/6] cran feedback --- .Rbuildignore | 1 + DESCRIPTION | 4 ++- R/shinyDiagnostics.R | 2 +- README.Rmd | 2 +- README.md | 4 +-- cran-comments.md | 9 +++++ inst/shiny/global.R | 22 +++++++----- inst/shiny/scripts/preprocess.R | 60 ++++++++++++++++++--------------- man/PhenotypeR-package.Rd | 3 +- man/shinyDiagnostics.Rd | 2 +- 10 files changed, 65 insertions(+), 44 deletions(-) create mode 100644 cran-comments.md diff --git a/.Rbuildignore b/.Rbuildignore index 67f5d30..641d2c5 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -8,3 +8,4 @@ ^pkgdown$ ^doc$ ^Meta$ +^cran-comments\.md$ diff --git a/DESCRIPTION b/DESCRIPTION index 6744dd4..d174e13 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,7 +14,9 @@ Authors@R: c( person("Albert", "Prats-Uribe", , "albert.prats-uribe@ndorms.ox.ac.uk", role = "aut", comment = c(ORCID = "0000-0003-1202-9153"))) Description: Phenotype study cohorts in data mapped to the - Observational Medical Outcomes Partnership Common Data Model. + Observational Medical Outcomes Partnership Common Data Model. Diagnostics + are run at the database, codelist, cohort, and population level to assess + whether study cohorts are ready for research. License: Apache License (>= 2) Encoding: UTF-8 LazyData: true diff --git a/R/shinyDiagnostics.R b/R/shinyDiagnostics.R index 853da09..7415541 100644 --- a/R/shinyDiagnostics.R +++ b/R/shinyDiagnostics.R @@ -49,7 +49,7 @@ #' schema ="main", #' overwrite = TRUE) #' my_result_cohort_diag <- cdm$my_cohort |> phenotypeDiagnostics() -#' shinyDiagnostics(my_result_cohort_diag, here::here()) +#' shinyDiagnostics(my_result_cohort_diag, tempir()) #' } shinyDiagnostics <- function(result, directory, diff --git a/README.Rmd b/README.Rmd index 4a88160..e232b55 100644 --- a/README.Rmd +++ b/README.Rmd @@ -70,5 +70,5 @@ summary(result) Once we have our results we can quickly view them in an interactive application. This shiny app will be saved in a new directory and can be further customised. ```{r, eval=FALSE} -shinyDiagnostics(result = result) +shinyDiagnostics(result = result, directory = tempdir()) ``` diff --git a/README.md b/README.md index 4ec8fb8..b2eb19c 100644 --- a/README.md +++ b/README.md @@ -71,7 +71,7 @@ result <- cdm$gibleed |> ``` r summary(result) -#> A summarised_result object with 15951 rows, 49 different result_id, 1 different +#> A summarised_result object with 18179 rows, 49 different result_id, 1 different #> cdm names, and 24 settings. #> CDM names: Synthea synthetic health database. #> Settings: package_name, package_version, result_type, timing, table_name, @@ -79,7 +79,7 @@ summary(result) #> analysis_outcome_washout, analysis_repeated_events, analysis_interval, #> analysis_complete_database_intervals, denominator_age_group, denominator_sex, #> denominator_days_prior_observation, denominator_start_date, -#> denominator_end_date, denominator_time_at_risk, …, type, and analysis. +#> denominator_end_date, denominator_target_cohort_name, …, type, and analysis. ``` Once we have our results we can quickly view them in an interactive diff --git a/cran-comments.md b/cran-comments.md new file mode 100644 index 0000000..2862091 --- /dev/null +++ b/cran-comments.md @@ -0,0 +1,9 @@ +## R CMD check results + +0 errors | 0 warnings | 1 note + +* This is a re-submission. +* A more thorough description is provided. +* There are no references to add. +* Use of getwd() has been removed and functions do not write by default or in examples/vignettes/tests in the user's home filespace. + diff --git a/inst/shiny/global.R b/inst/shiny/global.R index 2c2cfdd..9ee2d50 100644 --- a/inst/shiny/global.R +++ b/inst/shiny/global.R @@ -19,12 +19,16 @@ library(shinyWidgets) library(plotly) library(tidyr) -source(file.path(getwd(),"scripts", "functions.R")) +source(here::here("scripts", "functions.R")) -if(file.exists(file.path(getwd(), "data", "appData.RData"))){ - load(file.path(getwd(),"data", "appData.RData")) +if(file.exists(here::here("data", "appData.RData"))){ + cli::cli_inform("Loading existing processed data") + load(here::here("data", "appData.RData")) + cli::cli_alert_success("Data loaded") } else { - source(file.path(getwd(),"scripts", "preprocess.R")) + cli::cli_inform("Preprocessing data from data/raw") + source(here::here("scripts", "preprocess.R")) + cli::cli_alert_success("Data processed") } plotComparedLsc <- function(lsc, cohorts, colour = NULL, facet = NULL){ @@ -32,7 +36,7 @@ plotComparedLsc <- function(lsc, cohorts, colour = NULL, facet = NULL){ plot_data <- lsc |> filter(cohort_name %in% c(cohorts )) |> - select(database = cdm_name, + select(database = cdm_name, cohort_name, variable_name, time_window = variable_level, @@ -42,16 +46,16 @@ plotComparedLsc <- function(lsc, cohorts, colour = NULL, facet = NULL){ pivot_wider(names_from = cohort_name, values_from = percentage) - # plot <- visOmopResults::scatterPlot(plot_data, + # plot <- visOmopResults::scatterPlot(plot_data, # x = cohorts[1], # y = cohorts[2], - # colour = colour, + # colour = colour, # facet = facet, # line = FALSE, - # point = TRUE, + # point = TRUE, # ribbon = FALSE) + # ggplot2::geom_abline(slope = 1, intercept = 0, color = "red", linetype = "dashed") + - # ggplot2::theme_bw() + # ggplot2::theme_bw() plot <- plot_data |> ggplot(aes(text = paste("Concept:", variable_name, diff --git a/inst/shiny/scripts/preprocess.R b/inst/shiny/scripts/preprocess.R index 9b17931..6a34bb4 100644 --- a/inst/shiny/scripts/preprocess.R +++ b/inst/shiny/scripts/preprocess.R @@ -15,7 +15,7 @@ library(sortable) library(visOmopResults) library(shinycssloaders) -data <- omopgenerics::importSummarisedResult(file.path(getwd(),"data", "raw")) +data <- omopgenerics::importSummarisedResult(here::here("data", "raw")) if(nrow(data) == 0){ cli::cli_warn("No data found in data/raw") choices <- list() @@ -49,17 +49,18 @@ for(i in seq_along(settingsUsed)){ workingSetting) } -if(!is.null(dataFiltered$cohort_code_use)){ - codeUseCohorts <- unique(dataFiltered$cohort_code_use |> - visOmopResults::splitAll() |> pull("cohort_name")) - codeUseCodelist <- unique(dataFiltered$cohort_code_use |> - visOmopResults::splitAll() |> pull("codelist_name")) +selected <- choices - choices$cohort_code_use_grouping_cohort_name <- codeUseCohorts - selected$cohort_code_use_grouping_cohort_name <- codeUseCohorts[1] +if(!is.null(dataFiltered$cohort_code_use)){ + if(nrow(dataFiltered$cohort_code_use)>0){ + codeUseCohorts <- unique(dataFiltered$cohort_code_use |> + visOmopResults::splitAll() |> pull("cohort_name")) + codeUseCodelist <- unique(dataFiltered$cohort_code_use |> + visOmopResults::splitAll() |> pull("codelist_name")) -} -selected <- choices + choices$cohort_code_use_grouping_cohort_name <- codeUseCohorts + selected$cohort_code_use_grouping_cohort_name <- codeUseCohorts[1] + }} selected$summarise_characteristics_grouping_cohort_name <- selected$summarise_characteristics_grouping_cohort_name[1] selected$summarise_large_scale_characteristics_grouping_cohort_name <- selected$summarise_large_scale_characteristics_grouping_cohort_name[1] @@ -73,11 +74,12 @@ selected$compare_large_scale_characteristics_grouping_cohort_1 <- choices$compar selected$compare_large_scale_characteristics_grouping_cohort_2 <- choices$compare_large_scale_characteristics_grouping_cohort_1[2] if(!is.null(dataFiltered$summarise_large_scale_characteristics)){ -choices$summarise_large_scale_characteristics_grouping_domain <- settings(dataFiltered$summarise_large_scale_characteristics) |> - pull("table_name") -choices$summarise_large_scale_characteristics_grouping_time_window <- unique(dataFiltered$summarise_large_scale_characteristics |> - pull("variable_level")) -} + if(nrow(dataFiltered$summarise_large_scale_characteristics)>0){ + choices$summarise_large_scale_characteristics_grouping_domain <- settings(dataFiltered$summarise_large_scale_characteristics) |> + pull("table_name") + choices$summarise_large_scale_characteristics_grouping_time_window <- unique(dataFiltered$summarise_large_scale_characteristics |> + pull("variable_level")) + }} selected$summarise_large_scale_characteristics_grouping_domain <- choices$summarise_large_scale_characteristics_grouping_domain selected$summarise_large_scale_characteristics_grouping_time_window <-choices$summarise_large_scale_characteristics_grouping_time_window @@ -87,15 +89,16 @@ selected$compare_large_scale_characteristics_grouping_time_window <- selected$su selected$compare_large_scale_characteristics_grouping_table <- selected$summarise_large_scale_characteristics_grouping_domain if(!is.null(dataFiltered$orphan_code_use)){ - orphanCodelist <- unique(dataFiltered$orphan_code_use |> - visOmopResults::splitAll() |> pull("codelist_name")) - orphanCdm <- unique(dataFiltered$orphan_code_use |> - visOmopResults::addSettings() |> pull("cdm_name")) - choices$orphan_grouping_cdm_name <- orphanCdm - choices$orphan_grouping_codelist_name <- orphanCodelist - selected$orphan_grouping_cdm_name <- orphanCdm - selected$orphan_grouping_cohort_name <- orphanCodelist[1] -} + if(nrow(dataFiltered$orphan_code_use)>0){ + orphanCodelist <- unique(dataFiltered$orphan_code_use |> + visOmopResults::splitAll() |> pull("codelist_name")) + orphanCdm <- unique(dataFiltered$orphan_code_use |> + visOmopResults::addSettings() |> pull("cdm_name")) + choices$orphan_grouping_cdm_name <- orphanCdm + choices$orphan_grouping_codelist_name <- orphanCodelist + selected$orphan_grouping_cdm_name <- orphanCdm + selected$orphan_grouping_cohort_name <- orphanCodelist[1] + }} # # unmappedCodelist <- unique(dataFiltered$unmapped_codes |> @@ -120,10 +123,11 @@ selected$incidence_grouping_incidence_start_date # min_incidence_start <- min(as.Date(selected$incidence_grouping_incidence_start_date)) # max_incidence_end <- max(as.Date(selected$incidence_grouping_incidence_end_date)) if(!is.null(dataFiltered$prevalence)){ -prevalence_cohorts <- unique(dataFiltered$prevalence |> pull("variable_level")) -choices$prevalence_settings_outcome_cohort_name <- prevalence_cohorts -selected$prevalence_settings_outcome_cohort_name <- prevalence_cohorts[1] -} + if(nrow(dataFiltered$prevalence)>0){ + prevalence_cohorts <- unique(dataFiltered$prevalence |> pull("variable_level")) + choices$prevalence_settings_outcome_cohort_name <- prevalence_cohorts + selected$prevalence_settings_outcome_cohort_name <- prevalence_cohorts[1] + }} selected$prevalence_settings_analysis_interval <- selected$prevalence_settings_analysis_interval[1] selected$prevalence_settings_denominator_age_group <- selected$prevalence_settings_denominator_age_group[1] diff --git a/man/PhenotypeR-package.Rd b/man/PhenotypeR-package.Rd index 44de2a9..96d840c 100644 --- a/man/PhenotypeR-package.Rd +++ b/man/PhenotypeR-package.Rd @@ -8,7 +8,7 @@ \description{ \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} -Phenotype study cohorts in data mapped to the Observational Medical Outcomes Partnership Common Data Model. +Phenotype study cohorts in data mapped to the Observational Medical Outcomes Partnership Common Data Model. Diagnostics are run at the database, codelist, cohort, and population level to assess whether study cohorts are ready for research. } \seealso{ Useful links: @@ -24,6 +24,7 @@ Authors: \itemize{ \item Marti Catala \email{marti.catalasabate@ndorms.ox.ac.uk} (\href{https://orcid.org/0000-0003-3308-9905}{ORCID}) \item Xihang Chen \email{xihang.chen@ndorms.ox.ac.uk} (\href{https://orcid.org/0009-0001-8112-8959}{ORCID}) + \item Marta Alcalde-Herraiz \email{marta.alcaldeherraiz@ndorms.ox.ac.uk} (\href{https://orcid.org/0009-0002-4405-1814}{ORCID}) \item Albert Prats-Uribe \email{albert.prats-uribe@ndorms.ox.ac.uk} (\href{https://orcid.org/0000-0003-1202-9153}{ORCID}) } diff --git a/man/shinyDiagnostics.Rd b/man/shinyDiagnostics.Rd index d5375a7..8a89149 100644 --- a/man/shinyDiagnostics.Rd +++ b/man/shinyDiagnostics.Rd @@ -57,6 +57,6 @@ includes: schema ="main", overwrite = TRUE) my_result_cohort_diag <- cdm$my_cohort |> phenotypeDiagnostics() - shinyDiagnostics(my_result_cohort_diag, here::here()) + shinyDiagnostics(my_result_cohort_diag, tempir()) } } From 54fdb99905b06c6e51d00f560c570131e0bb0c1e Mon Sep 17 00:00:00 2001 From: edward-burn <9583964+edward-burn@users.noreply.github.com> Date: Tue, 19 Nov 2024 10:24:32 +0000 Subject: [PATCH 4/6] typo --- R/reportDiagnostics.R | 24 --------- R/shinyDiagnostics.R | 2 +- man/shinyDiagnostics.Rd | 2 +- tests/testthat/test-dbms.R | 6 +-- tests/testthat/test-reportDiagnostics.R | 72 ------------------------- tests/testthat/test-shinyDiagnostics.R | 6 +-- 6 files changed, 8 insertions(+), 104 deletions(-) delete mode 100644 R/reportDiagnostics.R delete mode 100644 tests/testthat/test-reportDiagnostics.R diff --git a/R/reportDiagnostics.R b/R/reportDiagnostics.R deleted file mode 100644 index 68a4ee3..0000000 --- a/R/reportDiagnostics.R +++ /dev/null @@ -1,24 +0,0 @@ - -# reportDiagnostics <- function(result, -# directory = here::here()){ -# -# input <- system.file("rmd", "phenotype_report.Rmd", -# package = "PhenotypeR") -# -# cohortNames <- result |> -# visOmopResults::addSettings() |> -# omopgenerics::filter(.data$result_type == "summarised_characteristics") |> -# dplyr::filter(.data$group_level != "overall") |> -# dplyr::select("group_level") |> -# dplyr::distinct() |> -# dplyr::pull() -# cohortNames <- paste0(cohortNames, collapse = "; ") -# workingTitle <- paste('PhenotypeR results for cohort', cohortNames) -# -# rmarkdown::render(input = input, -# params = list(title = workingTitle, -# result = result), -# output_file = "report.html", -# output_dir = directory, -# clean = TRUE) -# } diff --git a/R/shinyDiagnostics.R b/R/shinyDiagnostics.R index 7415541..8a80afc 100644 --- a/R/shinyDiagnostics.R +++ b/R/shinyDiagnostics.R @@ -49,7 +49,7 @@ #' schema ="main", #' overwrite = TRUE) #' my_result_cohort_diag <- cdm$my_cohort |> phenotypeDiagnostics() -#' shinyDiagnostics(my_result_cohort_diag, tempir()) +#' shinyDiagnostics(my_result_cohort_diag, tempdir()) #' } shinyDiagnostics <- function(result, directory, diff --git a/man/shinyDiagnostics.Rd b/man/shinyDiagnostics.Rd index 8a89149..fe1a0ee 100644 --- a/man/shinyDiagnostics.Rd +++ b/man/shinyDiagnostics.Rd @@ -57,6 +57,6 @@ includes: schema ="main", overwrite = TRUE) my_result_cohort_diag <- cdm$my_cohort |> phenotypeDiagnostics() - shinyDiagnostics(my_result_cohort_diag, tempir()) + shinyDiagnostics(my_result_cohort_diag, tempdir()) } } diff --git a/tests/testthat/test-dbms.R b/tests/testthat/test-dbms.R index 7d0f559..18d6044 100644 --- a/tests/testthat/test-dbms.R +++ b/tests/testthat/test-dbms.R @@ -18,7 +18,7 @@ test_that("eunomia", { conceptSet = meds_cs, name = "meds") results <- phenotypeDiagnostics(cdm$meds) - expect_no_error(shinyDiagnostics(result = results, directory = here::here())) + expect_no_error(shinyDiagnostics(result = results, directory = tempdir())) }) test_that("postgres test", { @@ -49,7 +49,7 @@ test_that("postgres test", { cdm <- omopgenerics::bind(cdm$asthma, cdm$drugs, name = "my_cohort") results <- phenotypeDiagnostics(cdm$my_cohort) - expect_no_error(shinyDiagnostics(result = results, directory = here::here())) + expect_no_error(shinyDiagnostics(result = results, directory = tempir())) expect_no_error(CodelistGenerator::tableCohortCodeUse(results)) expect_no_error(CodelistGenerator::tableAchillesCodeUse(results)) expect_no_error(CodelistGenerator::tableOrphanCodes(results)) @@ -60,7 +60,7 @@ test_that("postgres test", { expect_no_error(CohortCharacteristics::tableCohortTiming(results)) expect_no_error(CohortCharacteristics::tableLargeScaleCharacteristics(results)) # omopViewer::exportStaticApp(results) - expect_no_error(shinyDiagnostics(result = results, directory = here::here())) + expect_no_error(shinyDiagnostics(result = results, directory = tempir())) CDMConnector::cdm_disconnect(cdm = cdm) diff --git a/tests/testthat/test-reportDiagnostics.R b/tests/testthat/test-reportDiagnostics.R deleted file mode 100644 index f6ce53a..0000000 --- a/tests/testthat/test-reportDiagnostics.R +++ /dev/null @@ -1,72 +0,0 @@ -# test_that("basic working example with one cohort", { -# -# cdm_local <- omock::mockCdmReference() |> -# omock::mockPerson(nPerson = 100) |> -# omock::mockObservationPeriod() |> -# omock::mockConditionOccurrence() |> -# omock::mockDrugExposure() |> -# omock::mockObservation() |> -# omock::mockMeasurement() |> -# omock::mockCohort(name = "my_cohort") -# cdm_local$visit_occurrence <- dplyr::tibble( -# person_id = 1L, -# visit_occurrence_id = 1L, -# visit_concept_id = 1L, -# visit_start_date = as.Date("2000-01-01"), -# visit_end_date = as.Date("2000-01-01"), -# visit_type_concept_id = 1L -# ) -# cdm_local$procedure_occurrence <- dplyr::tibble( -# person_id = 1L, -# procedure_occurrence_id = 1L, -# procedure_concept_id = 1L, -# procedure_date = as.Date("2000-01-01"), -# procedure_type_concept_id = 1L -# ) -# -# db <- DBI::dbConnect(duckdb::duckdb()) -# cdm <- CDMConnector::copyCdmTo(con = db, cdm = cdm_local, -# schema ="main", overwrite = TRUE) -# my_result <- cdm$my_cohort |> cohortDiagnostics() -# expect_no_error(reportDiagnostics(result = my_result)) -# -# CDMConnector::cdm_disconnect(cdm ) -# }) -# -# test_that("basic working example with two cohorts", { -# -# cdm_local <- omock::mockCdmReference() |> -# omock::mockPerson(nPerson = 100) |> -# omock::mockObservationPeriod() |> -# omock::mockConditionOccurrence() |> -# omock::mockDrugExposure() |> -# omock::mockObservation() |> -# omock::mockMeasurement() |> -# omock::mockCohort(name = "my_cohort", -# numberCohorts = 2) -# cdm_local$visit_occurrence <- dplyr::tibble( -# person_id = 1L, -# visit_occurrence_id = 1L, -# visit_concept_id = 1L, -# visit_start_date = as.Date("2000-01-01"), -# visit_end_date = as.Date("2000-01-01"), -# visit_type_concept_id = 1L -# ) -# cdm_local$procedure_occurrence <- dplyr::tibble( -# person_id = 1L, -# procedure_occurrence_id = 1L, -# procedure_concept_id = 1L, -# procedure_date = as.Date("2000-01-01"), -# procedure_type_concept_id = 1L -# ) -# -# db <- DBI::dbConnect(duckdb::duckdb()) -# cdm <- CDMConnector::copyCdmTo(con = db, cdm = cdm_local, -# schema ="main", overwrite = TRUE) -# my_result <- cdm$my_cohort |> cohortDiagnostics() -# expect_no_error(reportDiagnostics(result = my_result)) -# -# CDMConnector::cdm_disconnect(cdm ) -# -# -# }) diff --git a/tests/testthat/test-shinyDiagnostics.R b/tests/testthat/test-shinyDiagnostics.R index 4532763..23696b5 100644 --- a/tests/testthat/test-shinyDiagnostics.R +++ b/tests/testthat/test-shinyDiagnostics.R @@ -5,7 +5,7 @@ test_that("basic working example with one cohort", { # empty result - should still work without error expect_no_error( shinyDiagnostics(result = omopgenerics::emptySummarisedResult(), - directory = here::here()) + directory = tempdir()) ) # with results @@ -38,12 +38,12 @@ test_that("basic working example with one cohort", { schema ="main", overwrite = TRUE) my_result_code_diag <- cohortDiagnostics(cdm$my_cohort ) expect_no_error(shinyDiagnostics(my_result_code_diag, - directory = here::here())) + directory = tempdir())) my_result_cohort_diag <- cdm$my_cohort |> phenotypeDiagnostics() expect_no_error(shinyDiagnostics(my_result_cohort_diag, - directory = here::here())) + directory = tempdir())) }) From 8c6c5aa7f31ae576e00f2e9b1373e1339dd6fb4e Mon Sep 17 00:00:00 2001 From: edward-burn <9583964+edward-burn@users.noreply.github.com> Date: Thu, 21 Nov 2024 09:11:14 +0000 Subject: [PATCH 5/6] leave as dev rm unmapped for now --- DESCRIPTION | 2 +- R/codelistDiagnostics.R | 10 +-- inst/shiny/global.R | 16 +--- inst/shiny/ui.R | 158 ++++++++++++++++++++-------------------- 4 files changed, 88 insertions(+), 98 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index d174e13..7e83773 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: PhenotypeR Type: Package Title: Assess Study Cohorts Using a Common Data Model -Version: 0.1.0 +Version: 0.0.900 Authors@R: c( person("Edward", "Burn", , "edward.burn@ndorms.ox.ac.uk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-9286-1128")), diff --git a/R/codelistDiagnostics.R b/R/codelistDiagnostics.R index d5bf705..ae09422 100644 --- a/R/codelistDiagnostics.R +++ b/R/codelistDiagnostics.R @@ -113,11 +113,11 @@ codelistDiagnostics <- function(cohort){ cli::cli_bullets(c("*" = "Getting code counts in database based on achilles")) results[[paste0("achilles_code_use")]] <- CodelistGenerator::summariseAchillesCodeUse(x = all_codelists, cdm = cdm) - cli::cli_bullets(c("*" = "Getting unmapped concepts")) - results[[paste0("unmapped_codes", i)]] <- CodelistGenerator::summariseUnmappedCodes( - x = all_codelists, - cdm = cdm - ) + # cli::cli_bullets(c("*" = "Getting unmapped concepts")) + # results[[paste0("unmapped_codes", i)]] <- CodelistGenerator::summariseUnmappedCodes( + # x = all_codelists, + # cdm = cdm + # ) cli::cli_bullets(c("*" = "Getting orphan concepts")) results[[paste0("orphan_codes", i)]] <- CodelistGenerator::summariseOrphanCodes( diff --git a/inst/shiny/global.R b/inst/shiny/global.R index 9ee2d50..ffab806 100644 --- a/inst/shiny/global.R +++ b/inst/shiny/global.R @@ -46,19 +46,9 @@ plotComparedLsc <- function(lsc, cohorts, colour = NULL, facet = NULL){ pivot_wider(names_from = cohort_name, values_from = percentage) - # plot <- visOmopResults::scatterPlot(plot_data, - # x = cohorts[1], - # y = cohorts[2], - # colour = colour, - # facet = facet, - # line = FALSE, - # point = TRUE, - # ribbon = FALSE) + - # ggplot2::geom_abline(slope = 1, intercept = 0, color = "red", linetype = "dashed") + - # ggplot2::theme_bw() - - plot <- plot_data |> - ggplot(aes(text = paste("Concept:", variable_name, + plot <- plot_data |> + ggplot(aes(text = paste("
Database:", cdm_name, + "
Concept:", variable_name, "
Concept ID:", concept_id, "
Time window:", time_window, "
Table:", table, diff --git a/inst/shiny/ui.R b/inst/shiny/ui.R index 6dd2898..76a2918 100644 --- a/inst/shiny/ui.R +++ b/inst/shiny/ui.R @@ -149,82 +149,82 @@ ui <- bslib::page_navbar( ), ## unmapped concepts ----- - bslib::nav_panel( - title = "Unmapped concepts", - icon = shiny::icon("database"), - bslib::layout_sidebar( - sidebar = bslib::sidebar(width = 400, open = "closed", - bslib::accordion( - bslib::accordion_panel( - title = "Settings", - shinyWidgets::pickerInput( - inputId = "unmapped_grouping_cdm_name", - label = "Database", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "unmapped_grouping_codelist_name", - label = "Codelist name", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ) - ), - bslib::accordion_panel( - title = "Table formatting", - sortable::bucket_list( - header = NULL, - sortable::add_rank_list( - text = "none", - labels = c( "codelist_name"), - input_id = "unmapped_none" - ), - sortable::add_rank_list( - text = "header", - labels = c("cdm_name", "estimate_name"), - input_id = "unmapped_header" - ), - sortable::add_rank_list( - text = "groupColumn", - labels = NULL, - input_id = "unmapped_groupColumn" - ), - sortable::add_rank_list( - text = "hide", - labels = character(), - input_id = "unmapped_hide" - ) - ) - ) - ) - ), - bslib::nav_panel( - title = "Unmapped", - bslib::card( - full_screen = TRUE, - bslib::card_header( - bslib::popover( - shiny::icon("download"), - shinyWidgets::pickerInput( - inputId = "unmapped_formatted_download_type", - label = "File type", - selected = "docx", - choices = c("docx", "png", "pdf", "html"), - multiple = FALSE - ), - shiny::downloadButton(outputId = "unmapped_formatted_download", label = "Download") - ), - class = "text-end" - ), - gt::gt_output("unmapped_formatted") |> withSpinner() - ) - ) - ) - ), + # bslib::nav_panel( + # title = "Unmapped concepts", + # icon = shiny::icon("database"), + # bslib::layout_sidebar( + # sidebar = bslib::sidebar(width = 400, open = "closed", + # bslib::accordion( + # bslib::accordion_panel( + # title = "Settings", + # shinyWidgets::pickerInput( + # inputId = "unmapped_grouping_cdm_name", + # label = "Database", + # choices = NULL, + # selected = NULL, + # multiple = TRUE, + # options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + # ), + # shinyWidgets::pickerInput( + # inputId = "unmapped_grouping_codelist_name", + # label = "Codelist name", + # choices = NULL, + # selected = NULL, + # multiple = TRUE, + # options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + # ) + # ), + # bslib::accordion_panel( + # title = "Table formatting", + # sortable::bucket_list( + # header = NULL, + # sortable::add_rank_list( + # text = "none", + # labels = c( "codelist_name"), + # input_id = "unmapped_none" + # ), + # sortable::add_rank_list( + # text = "header", + # labels = c("cdm_name", "estimate_name"), + # input_id = "unmapped_header" + # ), + # sortable::add_rank_list( + # text = "groupColumn", + # labels = NULL, + # input_id = "unmapped_groupColumn" + # ), + # sortable::add_rank_list( + # text = "hide", + # labels = character(), + # input_id = "unmapped_hide" + # ) + # ) + # ) + # ) + # ), + # bslib::nav_panel( + # title = "Unmapped", + # bslib::card( + # full_screen = TRUE, + # bslib::card_header( + # bslib::popover( + # shiny::icon("download"), + # shinyWidgets::pickerInput( + # inputId = "unmapped_formatted_download_type", + # label = "File type", + # selected = "docx", + # choices = c("docx", "png", "pdf", "html"), + # multiple = FALSE + # ), + # shiny::downloadButton(outputId = "unmapped_formatted_download", label = "Download") + # ), + # class = "text-end" + # ), + # gt::gt_output("unmapped_formatted") |> withSpinner() + # ) + # ) + # ) + # ), ## Orphan codes ----- bslib::nav_panel( @@ -667,7 +667,7 @@ ui <- bslib::page_navbar( ) ), bslib::navset_card_tab( - + bslib::nav_panel( title = "Table", bslib::card( @@ -1668,8 +1668,8 @@ ui <- bslib::page_navbar( # ) # ) # ) - - + + ), # end ------ bslib::nav_spacer(), From 9d98ff3e94a465ec5e0d1eff53964ac17cb6b943 Mon Sep 17 00:00:00 2001 From: edward-burn <9583964+edward-burn@users.noreply.github.com> Date: Thu, 21 Nov 2024 09:28:05 +0000 Subject: [PATCH 6/6] missing ( in shiny code --- inst/shiny/server.R | 52 ++++++++++++++++++++++----------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/inst/shiny/server.R b/inst/shiny/server.R index 9231af1..1db7a86 100644 --- a/inst/shiny/server.R +++ b/inst/shiny/server.R @@ -33,7 +33,7 @@ server <- function(input, output, session) { if (is.null(dataFiltered$summarise_omop_snapshot)) { validate("No snapshot in results") } - + OmopSketch::tableOmopSnapshot( dataFiltered$summarise_omop_snapshot ) %>% @@ -389,7 +389,7 @@ server <- function(input, output, session) { if (is.null(dataFiltered$summarise_cohort_overlap)) { validate("No cohort overlap in results") } - + result <- dataFiltered$summarise_cohort_overlap |> filterData("summarise_cohort_overlap", input) CohortCharacteristics::tableCohortOverlap( @@ -423,7 +423,7 @@ server <- function(input, output, session) { if (is.null(dataFiltered$summarise_cohort_overlap)) { validate("No cohort overlap in results") } - + result <- dataFiltered$summarise_cohort_overlap |> filterData("summarise_cohort_overlap", input) CohortCharacteristics::plotCohortOverlap( @@ -496,11 +496,11 @@ server <- function(input, output, session) { ## output summarise_characteristics ----- ## output 7 ----- createOutput7 <- shiny::reactive({ - + if (is.null(dataFiltered$summarise_characteristics)) { validate("No summarised characteristics in results") } - + if(isTRUE(input$summarise_characteristics_include_matched)){ selectedCohorts <- c( input$summarise_characteristics_grouping_cohort_name, @@ -510,7 +510,7 @@ server <- function(input, output, session) { } else { selectedCohorts <- input$summarise_characteristics_grouping_cohort_name } - + result <- dataFiltered$summarise_characteristics |> dplyr::filter(cdm_name %in% input$summarise_characteristics_grouping_cdm_name, group_level %in% selectedCohorts) @@ -577,9 +577,9 @@ server <- function(input, output, session) { if (is.null(dataFiltered$summarise_large_scale_characteristics)) { validate("No large scale characteristics in results") } - + lsc_data <- dataFiltered$summarise_large_scale_characteristics |> - filter(!is.na(estimate_value)) |> + filter(!is.na(estimate_value)) |> visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_grouping_domain) |> dplyr::filter(cdm_name %in% input$summarise_large_scale_characteristics_grouping_cdm_name ) |> dplyr::filter(group_level %in% input$summarise_large_scale_characteristics_grouping_cohort_name) |> @@ -611,11 +611,11 @@ server <- function(input, output, session) { ## output summarise_large_scale_characteristics ----- ## output 0 ----- createOutput0 <- shiny::reactive({ - + if (is.null(dataFiltered$summarise_large_scale_characteristics)) { validate("No large scale characteristics in results") } - + if (input$top_n < 1) { validate("Top n must be between 1 and 100") } @@ -624,13 +624,13 @@ server <- function(input, output, session) { } lsc_data <- dataFiltered$summarise_large_scale_characteristics |> - filter(!is.na(estimate_value)) |> + filter(!is.na(estimate_value)) |> visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_grouping_domain) |> dplyr::filter(cdm_name %in% input$summarise_large_scale_characteristics_grouping_cdm_name ) |> dplyr::filter(group_level %in% input$summarise_large_scale_characteristics_grouping_cohort_name) |> dplyr::filter(variable_level %in% input$summarise_large_scale_characteristics_grouping_time_window) - CohortCharacteristics::tableLargeScaleCharacteristics(lsc_data |> arrange(desc(estimate_type), desc(as.numeric(estimate_value)), + CohortCharacteristics::tableLargeScaleCharacteristics(lsc_data |> arrange(desc(estimate_type), desc(as.numeric(estimate_value))), topConcepts = input$top_n # , # header = input$summarise_large_scale_characteristics_gt_0_header, @@ -703,11 +703,11 @@ server <- function(input, output, session) { ## output incidence ----- ## output 18 ----- createOutput18 <- shiny::reactive({ - + if (is.null(dataFiltered$incidence)) { validate("No incidence in results") } - + result <- dataFiltered$incidence |> filterData("incidence", input) IncidencePrevalence::tableIncidence( @@ -743,7 +743,7 @@ server <- function(input, output, session) { if (is.null(dataFiltered$incidence)) { validate("No incidence in results") } - + result <- dataFiltered$incidence |> filterData("incidence", input) @@ -820,11 +820,11 @@ server <- function(input, output, session) { ## output incidence_attrition ----- ## output 22 ----- createOutput22 <- shiny::reactive({ - + if (is.null(dataFiltered$incidence_attrition)) { validate("No incidence attrition in results") } - + result <- dataFiltered$incidence_attrition |> filterData("incidence_attrition", input) IncidencePrevalence::tableIncidenceAttrition( @@ -900,7 +900,7 @@ server <- function(input, output, session) { if (is.null(dataFiltered$prevalence)) { validate("No prevalence in results") } - + result <- dataFiltered$prevalence |> filter(cdm_name %in% input$prevalence_grouping_cdm_name, variable_level %in% input$prevalence_settings_outcome_cohort_name) |> @@ -937,11 +937,11 @@ server <- function(input, output, session) { ## output prev2 ----- createOutputprev2 <- shiny::reactive({ - + if (is.null(dataFiltered$prevalence)) { validate("No prevalence in results") } - + result <- dataFiltered$prevalence |> filter(cdm_name %in% input$prevalence_grouping_cdm_name, variable_level %in% input$prevalence_settings_outcome_cohort_name) |> @@ -980,11 +980,11 @@ server <- function(input, output, session) { # compare lsc ---- outputLSC <- shiny::reactive({ - + if (is.null(dataFiltered$summarise_large_scale_characteristics)) { validate("No large scale characteristics in results") } - + dataFiltered$summarise_large_scale_characteristics |> filter(variable_level %in% input$compare_large_scale_characteristics_grouping_time_window) |> filterSettings(table_name %in% input$compare_large_scale_characteristics_grouping_table) @@ -1092,15 +1092,15 @@ server <- function(input, output, session) { ## output orphan ----- ## output 99 ----- createOutput99 <- shiny::reactive({ - + if (is.null(dataFiltered$prevalence)) { validate("No orphan codes in results") } - + if (is.null(dataFiltered$orphan_code_use)) { validate("No orphan codes in results") } - + result <- dataFiltered$orphan_code_use |> dplyr::filter(cdm_name %in% input$orphan_grouping_cdm_name, group_level %in% input$orphan_grouping_codelist_name) @@ -1139,7 +1139,7 @@ server <- function(input, output, session) { if (is.null(dataFiltered$unmapped_codes)) { validate("No unmapped codes in results") } - + CodelistGenerator::tableUnmappedCodes( dataFiltered$unmapped_codes |> dplyr::filter(cdm_name %in% input$unmapped_grouping_cdm_name,