From 6f3702fcfdfe2a180540fd5756a78cb8fd24d39e Mon Sep 17 00:00:00 2001 From: Marta Alcalde-Herraiz <91142894+martaalcalde@users.noreply.github.com> Date: Thu, 12 Dec 2024 13:08:29 +0000 Subject: [PATCH 1/5] Add age distribution plot --- .gitignore | 1 + DESCRIPTION | 6 +- inst/shiny/global.R | 13 ++-- inst/shiny/server.R | 180 +++++++++++++++++++++++++++++++++++--------- 4 files changed, 158 insertions(+), 42 deletions(-) diff --git a/.gitignore b/.gitignore index a127bac..5d103d3 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,4 @@ inst/doc .Rhistory inst/shiny/data/raw/*.csv inst/shiny/data/appData.RData +inst/shiny/*.RData diff --git a/DESCRIPTION b/DESCRIPTION index 3bb79a9..1d44b63 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,7 +35,7 @@ Suggests: RPostgres, PatientProfiles (>= 1.2.2), ggplot2, - ggpubr, + ggpubr, stringr, shiny, DiagrammeR, @@ -46,7 +46,9 @@ Suggests: bslib, shinyWidgets, plotly, - tidyr + tidyr, + patchwork, + scales Config/testthat/edition: 3 RoxygenNote: 7.3.2 Imports: diff --git a/inst/shiny/global.R b/inst/shiny/global.R index 5789ca9..2ccc6b9 100644 --- a/inst/shiny/global.R +++ b/inst/shiny/global.R @@ -18,6 +18,7 @@ library(shinycssloaders) library(shinyWidgets) library(plotly) library(tidyr) +library(patchwork) # ensure minimum versions rlang::check_installed("omopgenerics", version = "0.4") @@ -43,8 +44,8 @@ plotComparedLsc <- function(lsc, cohorts, imputeMissings, colour = NULL, facet = plot_data <- lsc |> filter(group_level %in% c(cohorts )) |> - filter(estimate_name == "percentage") |> - omopgenerics::addSettings() |> + filter(estimate_name == "percentage") |> + omopgenerics::addSettings() |> select(database = cdm_name, cohort_name = group_level, variable_name, @@ -53,16 +54,16 @@ plotComparedLsc <- function(lsc, cohorts, imputeMissings, colour = NULL, facet = table = table_name, percentage = estimate_value) |> mutate(percentage = if_else(percentage == "-", - NA, percentage)) |> - mutate(percentage = as.numeric(percentage)) |> + NA, percentage)) |> + mutate(percentage = as.numeric(percentage)) |> pivot_wider(names_from = cohort_name, values_from = percentage) if(isTRUE(imputeMissings)){ - plot_data <- plot_data |> + plot_data <- plot_data |> mutate(across(c(cohorts[1], cohorts[2]), ~if_else(is.na(.x), 0, .x))) } - + plot <- plot_data |> ggplot(aes(text = paste("
Database:", database, "
Concept:", variable_name, diff --git a/inst/shiny/server.R b/inst/shiny/server.R index d459780..3af74df 100644 --- a/inst/shiny/server.R +++ b/inst/shiny/server.R @@ -608,6 +608,7 @@ 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") } @@ -636,7 +637,7 @@ server <- function(input, output, session) { }) output$summarise_large_scale_characteristics_tidy <- DT::renderDT({ DT::datatable( - getTidyDataSummariseLargeScaleCharacteristics() |> + getTidyDataSummariseLargeScaleCharacteristics() |> dplyr::arrange(dplyr::desc(percentage)), options = list(scrollX = TRUE), rownames = FALSE @@ -672,8 +673,8 @@ server <- function(input, output, session) { 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), + CohortCharacteristics::tableLargeScaleCharacteristics(lsc_data |> + arrange(desc(estimate_type), desc(as.numeric(estimate_value))) # , # topConcepts = input$top_n @@ -748,18 +749,18 @@ server <- function(input, output, session) { ## output incidence ----- incidenceFiltered <- shiny::reactive({ dataFiltered$incidence |> - filter(cdm_name %in% - input$incidence_grouping_cdm_name) |> - filterGroup(outcome_cohort_name %in% - input$incidence_grouping_outcome_cohort_name) |> + filter(cdm_name %in% + input$incidence_grouping_cdm_name) |> + filterGroup(outcome_cohort_name %in% + input$incidence_grouping_outcome_cohort_name) |> filterSettings(denominator_age_group %in% - input$incidence_settings_denominator_age_group, - denominator_sex %in% - input$incidence_settings_denominator_sex) |> + input$incidence_settings_denominator_age_group, + denominator_sex %in% + input$incidence_settings_denominator_sex) |> filterAdditional(analysis_interval %in% input$incidence_settings_analysis_interval) }) - + ## output 18 ----- createOutput18 <- shiny::reactive({ @@ -777,7 +778,7 @@ server <- function(input, output, session) { result, # header = input$incidence_gt_18_header, groupColumn = c("cdm_name", "outcome_cohort_name"), - hide = "denominator_cohort_name", + hide = "denominator_cohort_name", settingsColumns = c("denominator_age_group", "denominator_sex", "outcome_cohort_name") @@ -787,7 +788,7 @@ server <- function(input, output, session) { subtitle = "Incidence rates estimated for outcomes of interest" ) %>% tab_options( - heading.align = "left" + heading.align = "left" ) }) output$incidence_gt_18 <- gt::render_gt({ @@ -808,21 +809,21 @@ server <- function(input, output, session) { } result <- incidenceFiltered() - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + IncidencePrevalence::plotIncidence( result, x = input$incidence_ggplot2_19_x, ribbon = FALSE, facet = input$incidence_ggplot2_19_facet, colour = input$incidence_ggplot2_19_colour - ) |> + ) |> plotly::ggplotly() }) - + output$incidence_ggplot2_19 <- plotly::renderPlotly({ createOutput19() }) @@ -927,18 +928,18 @@ server <- function(input, output, session) { # prevalence ----- prevalenceFiltered <- shiny::reactive({ dataFiltered$prevalence |> - filter(cdm_name %in% - input$prevalence_grouping_cdm_name) |> - filterGroup(outcome_cohort_name %in% - input$prevalence_grouping_outcome_cohort_name) |> + filter(cdm_name %in% + input$prevalence_grouping_cdm_name) |> + filterGroup(outcome_cohort_name %in% + input$prevalence_grouping_outcome_cohort_name) |> filterSettings(denominator_age_group %in% - input$prevalence_settings_denominator_age_group, - denominator_sex %in% - input$prevalence_settings_denominator_sex, + input$prevalence_settings_denominator_age_group, + denominator_sex %in% + input$prevalence_settings_denominator_sex, analysis_interval %in% - input$prevalence_settings_analysis_interval) + input$prevalence_settings_analysis_interval) }) - + ## tidy prevalence ----- getTidyDataPrevalence <- shiny::reactive({ res <- dataFiltered$prevalence |> @@ -1065,7 +1066,7 @@ server <- function(input, output, session) { # compare lsc ---- outputLSC <- shiny::reactive({ - +browser() if (is.null(dataFiltered$summarise_large_scale_characteristics)) { validate("No large scale characteristics in results") } @@ -1082,14 +1083,14 @@ server <- function(input, output, session) { if (nrow(lscFiltered) == 0) { validate("No results found for selected inputs") } - + target_cohort <- input$compare_large_scale_characteristics_grouping_cohort_1 comparator_cohort <- input$compare_large_scale_characteristics_grouping_cohort_2 lsc <- lscFiltered |> filter(group_level %in% c(target_cohort, comparator_cohort )) |> - filter(estimate_name == "percentage") |> - omopgenerics::addSettings() |> + filter(estimate_name == "percentage") |> + omopgenerics::addSettings() |> select(database = cdm_name, cohort_name = group_level, variable_name, @@ -1098,16 +1099,16 @@ server <- function(input, output, session) { table = table_name, percentage = estimate_value) |> mutate(percentage = if_else(percentage == "-", - NA, percentage)) |> - mutate(percentage = as.numeric(percentage)) |> + NA, percentage)) |> + mutate(percentage = as.numeric(percentage)) |> pivot_wider(names_from = cohort_name, values_from = percentage) if(isTRUE(input$compare_large_scale_characteristics_impute_missings)){ - lsc <- lsc |> + lsc <- lsc |> mutate(across(c(target_cohort, comparator_cohort), ~if_else(is.na(.x), 0, .x))) } - + lsc <-lsc |> mutate(across(c(target_cohort, comparator_cohort), ~ as.numeric(.x)/100)) |> mutate(smd = (!!sym(target_cohort) - !!sym(comparator_cohort))/sqrt((!!sym(target_cohort)*(1-!!sym(target_cohort)) + !!sym(comparator_cohort)*(1-!!sym(comparator_cohort)))/2)) |> @@ -1268,4 +1269,115 @@ server <- function(input, output, session) { + ## age distribution ---- + ## output table ---- + outputLSC <- shiny::reactive({ + addPyramidTheme <- function(plot, colour){ + plot + + theme_void() + + theme( + axis.text.x = element_text(), + panel.grid.major.x = element_line(color = "grey90"), + legend.box = "horizontal", + axis.text.y = ggplot2::element_blank(), + axis.title.y = ggplot2::element_blank(), + legend.position = "bottom", + legend.title = ggplot2::element_blank() + ) + + scale_fill_manual(values = colour) + } + + # Get age lables + age_labels <- tibble( + min_age = c(seq(0,95,5), 100), + max_age = c(seq(5,100,5),350), + age_group = paste0(min_age,"-",max_age-1)) |> + mutate(age_group = if_else(age_group == "100-349", "100+", age_group)) |> + mutate(age_group = factor(age_group, levels = age_group)) + + age_labels_plot <- age_labels |> + ggplot(aes(x = 1, y = age_group, label = age_group)) + + geom_text() + + theme_void() + + # Get age density and split it into groups + age_pyramid <- dataFiltered$summarise_table |> + filter(variable_name == "age") |> + filter(cdm_name == "CPRD GOLD") |> + filter(group_level == "overall") |> + select("variable_level", "estimate_name", "estimate_value", "sex" = "strata_level") |> + pivot_wider(names_from = "estimate_name", values_from = "estimate_value") |> + mutate(density_x = as.numeric(density_x), + density_y = as.numeric(density_y)) |> + mutate(age_group = case_when( + density_x >= 0 & density_x < 5 ~ "0-4", + density_x >= 5 & density_x < 10 ~ "5-9", + density_x >= 10 & density_x < 15 ~ "10-14", + density_x >= 15 & density_x < 20 ~ "15-19", + density_x >= 20 & density_x < 25 ~ "20-24", + density_x >= 25 & density_x < 30 ~ "25-29", + density_x >= 30 & density_x < 35 ~ "30-34", + density_x >= 35 & density_x < 40 ~ "35-39", + density_x >= 40 & density_x < 45 ~ "40-44", + density_x >= 45 & density_x < 50 ~ "45-49", + density_x >= 50 & density_x < 55 ~ "50-54", + density_x >= 55 & density_x < 60 ~ "55-59", + density_x >= 60 & density_x < 65 ~ "60-64", + density_x >= 65 & density_x < 70 ~ "65-69", + density_x >= 70 & density_x < 75 ~ "70-74", + density_x >= 75 & density_x < 80 ~ "75-79", + density_x >= 80 & density_x < 85 ~ "80-84", + density_x >= 85 & density_x < 90 ~ "85-89", + density_x >= 90 & density_x < 95 ~ "90-94", + density_x >= 95 & density_x < 100 ~ "95-99", + density_x >= 100 ~ "100+" + )) |> + mutate(percent = mean(density_y, na.rm = FALSE), .by = age_group) |> + select("age_group", "percent", "sex") |> + mutate(percent = if_else(sex == "Female",-percent,percent)) |> + distinct() + + age_pyramid <- age_labels |> + select("age_group") |> + slice(rep(1:n(), each = 2)) |> + mutate(sex = if_else(row_number() == 1, "Female", "Male"), .by = age_group) |> + left_join(age_pyramid, + by = c("age_group","sex"), + relationship = "many-to-many") |> + mutate(percent = if_else(is.na(percent), 0, percent)) + + max_percent <- max(age_pyramid$percent, na.rm = TRUE) + + age_pyramid_female <- age_pyramid |> + filter(sex == "Female") |> + mutate(age_group = factor(age_group, levels = age_group)) |> + ggplot(aes(x = percent, y = age_group, fill = sex)) + + geom_col() + + scale_x_continuous(labels = function(x) label_percent()(abs(x)), + breaks = breaks_pretty(), + limits = c(-max_percent, 0)) + age_pyramid_female <- age_pyramid_female |> addPyramidTheme("#4682B4") + + age_pyramid_male <- age_pyramid |> + filter(sex == "Male") |> + mutate(age_group = factor(age_group, levels = age_group)) |> + ggplot(aes(x = percent, y = age_group, fill = sex)) + + geom_col() + + scale_x_continuous( + labels = label_percent(), + breaks = breaks_pretty(), + limits = c(0, max_percent)) + age_pyramid_male <- age_pyramid_male |> addPyramidTheme("#003153") + + age_pyramid_female + + age_labels_plot + + age_pyramid_male + + plot_layout( + widths = c(7.5, 1, 7.5) + ) + + + }) + + } From 146d8c91b5b62695c0ef537550b112305d1cd6a9 Mon Sep 17 00:00:00 2001 From: Marta Alcalde-Herraiz <91142894+martaalcalde@users.noreply.github.com> Date: Thu, 12 Dec 2024 13:52:08 +0000 Subject: [PATCH 2/5] cowplot or patchwork --- inst/shiny/server.R | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/inst/shiny/server.R b/inst/shiny/server.R index 3af74df..6208797 100644 --- a/inst/shiny/server.R +++ b/inst/shiny/server.R @@ -1279,7 +1279,7 @@ browser() axis.text.x = element_text(), panel.grid.major.x = element_line(color = "grey90"), legend.box = "horizontal", - axis.text.y = ggplot2::element_blank(), + # axis.text.y = ggplot2::element_blank(), axis.title.y = ggplot2::element_blank(), legend.position = "bottom", legend.title = ggplot2::element_blank() @@ -1369,13 +1369,19 @@ browser() limits = c(0, max_percent)) age_pyramid_male <- age_pyramid_male |> addPyramidTheme("#003153") - age_pyramid_female + - age_labels_plot + - age_pyramid_male + - plot_layout( - widths = c(7.5, 1, 7.5) - ) - + # cowplot::plot_grid(age_pyramid_female, + # # age_labels_plot, + # age_pyramid_male, + # ncol = 3, + # rel_widths = c(6,6)) + # + # + # plot <- age_pyramid_female + + # age_labels_plot + + # age_pyramid_male + + # plot_layout( + # widths = c(7.5, 1, 7.5) + # ) }) From 8a2b11072f18ef14bd7cc0d2ae208b71827a1691 Mon Sep 17 00:00:00 2001 From: Marta Alcalde-Herraiz <91142894+martaalcalde@users.noreply.github.com> Date: Thu, 12 Dec 2024 17:52:59 +0000 Subject: [PATCH 3/5] Use ggpol to plot age distribution --- DESCRIPTION | 2 +- inst/shiny/server.R | 92 ++--- inst/shiny/ui.R | 937 ++++++++++++++++++++++---------------------- 3 files changed, 509 insertions(+), 522 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1d44b63..14bb175 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -47,7 +47,7 @@ Suggests: shinyWidgets, plotly, tidyr, - patchwork, + ggpol, scales Config/testthat/edition: 3 RoxygenNote: 7.3.2 diff --git a/inst/shiny/server.R b/inst/shiny/server.R index 6208797..7c605b8 100644 --- a/inst/shiny/server.R +++ b/inst/shiny/server.R @@ -1066,7 +1066,7 @@ server <- function(input, output, session) { # compare lsc ---- outputLSC <- shiny::reactive({ -browser() + if (is.null(dataFiltered$summarise_large_scale_characteristics)) { validate("No large scale characteristics in results") } @@ -1271,21 +1271,7 @@ browser() ## age distribution ---- ## output table ---- - outputLSC <- shiny::reactive({ - addPyramidTheme <- function(plot, colour){ - plot + - theme_void() + - theme( - axis.text.x = element_text(), - panel.grid.major.x = element_line(color = "grey90"), - legend.box = "horizontal", - # axis.text.y = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - legend.position = "bottom", - legend.title = ggplot2::element_blank() - ) + - scale_fill_manual(values = colour) - } + createAgePyramid <- shiny::reactive({ # Get age lables age_labels <- tibble( @@ -1332,7 +1318,9 @@ browser() density_x >= 95 & density_x < 100 ~ "95-99", density_x >= 100 ~ "100+" )) |> - mutate(percent = mean(density_y, na.rm = FALSE), .by = age_group) |> + group_by(age_group, sex) |> + mutate(percent = mean(density_y, na.rm = FALSE)) |> + ungroup() |> select("age_group", "percent", "sex") |> mutate(percent = if_else(sex == "Female",-percent,percent)) |> distinct() @@ -1344,46 +1332,32 @@ browser() left_join(age_pyramid, by = c("age_group","sex"), relationship = "many-to-many") |> - mutate(percent = if_else(is.na(percent), 0, percent)) - - max_percent <- max(age_pyramid$percent, na.rm = TRUE) - - age_pyramid_female <- age_pyramid |> - filter(sex == "Female") |> - mutate(age_group = factor(age_group, levels = age_group)) |> - ggplot(aes(x = percent, y = age_group, fill = sex)) + - geom_col() + - scale_x_continuous(labels = function(x) label_percent()(abs(x)), - breaks = breaks_pretty(), - limits = c(-max_percent, 0)) - age_pyramid_female <- age_pyramid_female |> addPyramidTheme("#4682B4") - - age_pyramid_male <- age_pyramid |> - filter(sex == "Male") |> - mutate(age_group = factor(age_group, levels = age_group)) |> - ggplot(aes(x = percent, y = age_group, fill = sex)) + - geom_col() + - scale_x_continuous( - labels = label_percent(), - breaks = breaks_pretty(), - limits = c(0, max_percent)) - age_pyramid_male <- age_pyramid_male |> addPyramidTheme("#003153") - - # cowplot::plot_grid(age_pyramid_female, - # # age_labels_plot, - # age_pyramid_male, - # ncol = 3, - # rel_widths = c(6,6)) - # - # - # plot <- age_pyramid_female + - # age_labels_plot + - # age_pyramid_male + - # plot_layout( - # widths = c(7.5, 1, 7.5) - # ) - - }) - - + mutate(percent = if_else(is.na(percent), 0, percent)) |> + mutate(age_group = factor(age_group, levels = age_labels$age_group)) + + ggplot(age_pyramid, aes(x = percent, y = age_group, fill = sex)) + + geom_bar(stat = "identity") + + ggpol::facet_share(~sex, dir = "h", scales = "free", reverse_num = FALSE) + + scale_x_continuous(labels = function(x) scales::label_percent()(abs(x))) + + theme( + axis.text.x = element_text(), + axis.title.x = ggplot2::element_blank(), + panel.grid.major.x = element_line(color = "grey90"), + legend.box = "horizontal", + axis.title.y = ggplot2::element_blank(), + legend.position = "bottom", + legend.title = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + strip.text = ggplot2::element_blank(), + plot.margin = margin(10, 10, 10, 10) + ) + + scale_fill_manual(values = list("Male" = "#4682B4","Female" = "#003153")) + + + }) + + output$plot_age_pyramid <- plotly::renderPlotly({ + createAgePyramid() + }) + } diff --git a/inst/shiny/ui.R b/inst/shiny/ui.R index fad519b..326fb40 100644 --- a/inst/shiny/ui.R +++ b/inst/shiny/ui.R @@ -4,13 +4,13 @@ ui <- bslib::page_navbar( theme = bs_theme(bootswatch = "pulse"), # zephyr - + title = "PhenotypeR", bslib::nav_panel( title = "Background", icon = shiny::icon("disease"), shiny::includeMarkdown(path = "background.md") - + ), # Database diagnostics ----- bslib::nav_menu( @@ -20,50 +20,50 @@ ui <- bslib::page_navbar( bslib::nav_panel( title = "Snapshot", icon = shiny::icon("clipboard-list"), - bslib::card( - full_screen = TRUE, - bslib::card_header( - bslib::popover( - shiny::icon("download"), - shinyWidgets::pickerInput( - inputId = "summarise_omop_snapshot_gt_17_download_type", - label = "File type", - selected = "docx", - choices = c("docx", "png", "pdf", "html"), - multiple = FALSE - ), - shiny::downloadButton(outputId = "summarise_omop_snapshot_gt_17_download", label = "Download") - ), - class = "text-end" - ), - gt::gt_output("summarise_omop_snapshot_gt_17") |> withSpinner() - ) + bslib::card( + full_screen = TRUE, + bslib::card_header( + bslib::popover( + shiny::icon("download"), + shinyWidgets::pickerInput( + inputId = "summarise_omop_snapshot_gt_17_download_type", + label = "File type", + selected = "docx", + choices = c("docx", "png", "pdf", "html"), + multiple = FALSE + ), + shiny::downloadButton(outputId = "summarise_omop_snapshot_gt_17_download", label = "Download") + ), + class = "text-end" + ), + gt::gt_output("summarise_omop_snapshot_gt_17") |> withSpinner() + ) ), ## observation periods ----- bslib::nav_panel( title = "Observation periods", icon = shiny::icon("eye"), - bslib::nav_panel( - title = "Table observation period", - bslib::card( - full_screen = TRUE, - bslib::card_header( - bslib::popover( - shiny::icon("download"), - shinyWidgets::pickerInput( - inputId = "summarise_observation_period_gt_15_download_type", - label = "File type", - selected = "docx", - choices = c("docx", "png", "pdf", "html"), - multiple = FALSE - ), - shiny::downloadButton(outputId = "summarise_observation_period_gt_15_download", label = "Download") - ), - class = "text-end" + bslib::nav_panel( + title = "Table observation period", + bslib::card( + full_screen = TRUE, + bslib::card_header( + bslib::popover( + shiny::icon("download"), + shinyWidgets::pickerInput( + inputId = "summarise_observation_period_gt_15_download_type", + label = "File type", + selected = "docx", + choices = c("docx", "png", "pdf", "html"), + multiple = FALSE ), - gt::gt_output("summarise_observation_period_gt_15") |> withSpinner() - ) - ) + shiny::downloadButton(outputId = "summarise_observation_period_gt_15_download", label = "Download") + ), + class = "text-end" + ), + gt::gt_output("summarise_observation_period_gt_15") |> withSpinner() + ) + ) ) ), # Codelist diagnostics ----- @@ -147,7 +147,7 @@ ui <- bslib::page_navbar( ) ) ), - + ## unmapped concepts ----- # bslib::nav_panel( # title = "Unmapped concepts", @@ -225,7 +225,7 @@ ui <- bslib::page_navbar( # ) # ) # ), - + ## Orphan codes ----- bslib::nav_panel( title = "Orphan codes", @@ -297,20 +297,20 @@ ui <- bslib::page_navbar( ), gt::gt_output("orphan_gt_99") |> withSpinner() ) - - + + )) - + ), - + # Cohort diagnostics ----- - + bslib::nav_menu( title = "Cohort diagnostics", icon = shiny::icon("list"), - + ## Cohort code use ----- - + bslib::nav_panel( title = "Cohort code use", icon = shiny::icon("chart-column"), @@ -404,63 +404,66 @@ ui <- bslib::page_navbar( ) ), ## Cohort characteristics ----- - bslib::nav_panel( + bslib::nav_panel( title = "Cohort characteristics", icon = shiny::icon("users-gear"), bslib::layout_sidebar( sidebar = bslib::sidebar(width = 400, open = "closed", - bslib::accordion( - bslib::accordion_panel( - title = "Settings", - shinyWidgets::pickerInput( - inputId = "summarise_characteristics_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 = "summarise_characteristics_grouping_cohort_name", - label = "Cohort name", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::prettyCheckbox( - inputId = "summarise_characteristics_include_matched", - label = "Show matched cohorts", - value = FALSE) - ), - bslib::accordion_panel( - title = "Table formatting", - sortable::bucket_list( - header = NULL, - sortable::add_rank_list( - text = "none", - labels = c("variable_name", "variable_level", "estimate_name"), - input_id = "summarise_characteristics_gt_7_none" - ), - sortable::add_rank_list( - text = "header", - labels = c("cdm_name", "cohort_name"), - input_id = "summarise_characteristics_gt_7_header" - ), - sortable::add_rank_list( - text = "groupColumn", - labels = NULL, - input_id = "summarise_characteristics_gt_7_groupColumn" - ), - sortable::add_rank_list( - text = "hide", - labels = character(), - input_id = "summarise_characteristics_gt_7_hide" - ) - ) - ) - ) + bslib::accordion( + bslib::accordion_panel( + title = "Settings", + shinyWidgets::pickerInput( + inputId = "summarise_characteristics_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 = "summarise_characteristics_grouping_cohort_name", + label = "Cohort name", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::prettyCheckbox( + inputId = "summarise_characteristics_include_matched", + label = "Show matched cohorts", + value = FALSE) + ), + bslib::accordion_panel( + title = "Table formatting", + sortable::bucket_list( + header = NULL, + sortable::add_rank_list( + text = "none", + labels = c("variable_name", "variable_level", "estimate_name"), + input_id = "summarise_characteristics_gt_7_none" + ), + sortable::add_rank_list( + text = "header", + labels = c("cdm_name", "cohort_name"), + input_id = "summarise_characteristics_gt_7_header" + ), + sortable::add_rank_list( + text = "groupColumn", + labels = NULL, + input_id = "summarise_characteristics_gt_7_groupColumn" + ), + sortable::add_rank_list( + text = "hide", + labels = character(), + input_id = "summarise_characteristics_gt_7_hide" + ) + ) + ) + ) ), + bslib::navset_card_tab( + bslib::nav_panel( + title = "Table", bslib::card( full_screen = TRUE, bslib::card_header( @@ -477,62 +480,71 @@ ui <- bslib::page_navbar( ), class = "text-end" ), - gt::gt_output("summarise_characteristics_gt_7") |> withSpinner() + gt::gt_output("summarise_characteristics_gt_7") |> withSpinner() + ) + ), + bslib::nav_panel( + title = "Age pyramid", + bslib::card( + full_screen = TRUE, + plotly::plotlyOutput("plot_age_pyramid") |> withSpinner() ) + ) + ) ) ), - ## Large scale characteristics ----- - + ## Large scale characteristics ----- + bslib::nav_panel( title = "Large scale characteristics", icon = shiny::icon("arrow-up-right-dots"), bslib::layout_sidebar( sidebar = bslib::sidebar(width = 400, open = "closed", - bslib::accordion( - bslib::accordion_panel( - title = "Settings", - shinyWidgets::pickerInput( - inputId = "summarise_large_scale_characteristics_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 = "summarise_large_scale_characteristics_grouping_cohort_name", - label = "Cohort name", - choices = NULL, - selected = NULL, - multiple = FALSE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "summarise_large_scale_characteristics_grouping_domain", - label = "Domain", - choices = NULL, - selected = NULL, - multiple = FALSE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "summarise_large_scale_characteristics_grouping_time_window", - label = "Time window", - choices = NULL, - selected = NULL, - multiple = FALSE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "summarise_large_scale_characteristics_settings_analysis", - label = "Concept type", - choices = NULL, - selected = NULL, - multiple = FALSE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ) - ) - ) + bslib::accordion( + bslib::accordion_panel( + title = "Settings", + shinyWidgets::pickerInput( + inputId = "summarise_large_scale_characteristics_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 = "summarise_large_scale_characteristics_grouping_cohort_name", + label = "Cohort name", + choices = NULL, + selected = NULL, + multiple = FALSE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "summarise_large_scale_characteristics_grouping_domain", + label = "Domain", + choices = NULL, + selected = NULL, + multiple = FALSE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "summarise_large_scale_characteristics_grouping_time_window", + label = "Time window", + choices = NULL, + selected = NULL, + multiple = FALSE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "summarise_large_scale_characteristics_settings_analysis", + label = "Concept type", + choices = NULL, + selected = NULL, + multiple = FALSE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ) + ) + ) ), bslib::navset_card_tab( bslib::nav_panel( @@ -569,31 +581,31 @@ ui <- bslib::page_navbar( ), bslib::layout_sidebar( sidebar = bslib::sidebar(width = 400, open = "closed", - # numericInput("top_n", "Top n:", 10, min = 1, max = 100), - sortable::bucket_list( - header = NULL, - sortable::add_rank_list( - text = "none", - labels = c("concept_id", "variable_name", "variable_level", "estimate_name", "table_name", "type", "analysis"), - input_id = "summarise_large_scale_characteristics_gt_0_none" - ), - sortable::add_rank_list( - text = "header", - labels = "cdm_name", - input_id = "summarise_large_scale_characteristics_gt_0_header" - ), - sortable::add_rank_list( - text = "group", - labels = "cohort_name", - input_id = "summarise_large_scale_characteristics_gt_0_group" - ), - sortable::add_rank_list( - text = "hide", - labels = character(), - input_id = "summarise_large_scale_characteristics_gt_0_hide" - ) - ), - position = "right" + # numericInput("top_n", "Top n:", 10, min = 1, max = 100), + sortable::bucket_list( + header = NULL, + sortable::add_rank_list( + text = "none", + labels = c("concept_id", "variable_name", "variable_level", "estimate_name", "table_name", "type", "analysis"), + input_id = "summarise_large_scale_characteristics_gt_0_none" + ), + sortable::add_rank_list( + text = "header", + labels = "cdm_name", + input_id = "summarise_large_scale_characteristics_gt_0_header" + ), + sortable::add_rank_list( + text = "group", + labels = "cohort_name", + input_id = "summarise_large_scale_characteristics_gt_0_group" + ), + sortable::add_rank_list( + text = "hide", + labels = character(), + input_id = "summarise_large_scale_characteristics_gt_0_hide" + ) + ), + position = "right" ), gt::gt_output("summarise_large_scale_characteristics_gt_0") |> withSpinner() ) @@ -602,167 +614,168 @@ ui <- bslib::page_navbar( ) ) ), - ## Compare large scale characteristics ----- + ## Compare large scale characteristics ----- bslib::nav_panel( title = "Compare large scale characteristics", icon = shiny::icon("arrow-up-right-dots"), - bslib::layout_sidebar( - sidebar = bslib::sidebar(width = 400, open = "closed", - bslib::accordion( - bslib::accordion_panel( - title = "Settings", - shinyWidgets::pickerInput( - inputId = "compare_large_scale_characteristics_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 = "compare_large_scale_characteristics_grouping_cohort_1", - label = "Cohort 1", - choices = NULL, - selected = NULL, - multiple = FALSE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "compare_large_scale_characteristics_grouping_cohort_2", - label = "Cohort 2", - choices = NULL, - selected = NULL, - multiple = FALSE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "compare_large_scale_characteristics_grouping_time_window", - label = "Time window", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "compare_large_scale_characteristics_grouping_domain", - label = "Domain", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "compare_large_scale_characteristics_settings_analysis", - label = "Concept type", - choices = NULL, - selected = NULL, - multiple = FALSE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::prettyCheckbox( - inputId = "compare_large_scale_characteristics_impute_missings", - label = "Impute missing values as 0", - value = FALSE) - ) + bslib::layout_sidebar( + sidebar = bslib::sidebar(width = 400, open = "closed", + bslib::accordion( + bslib::accordion_panel( + title = "Settings", + shinyWidgets::pickerInput( + inputId = "compare_large_scale_characteristics_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 = "compare_large_scale_characteristics_grouping_cohort_1", + label = "Cohort 1", + choices = NULL, + selected = NULL, + multiple = FALSE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "compare_large_scale_characteristics_grouping_cohort_2", + label = "Cohort 2", + choices = NULL, + selected = NULL, + multiple = FALSE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "compare_large_scale_characteristics_grouping_time_window", + label = "Time window", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "compare_large_scale_characteristics_grouping_domain", + label = "Domain", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "compare_large_scale_characteristics_settings_analysis", + label = "Concept type", + choices = NULL, + selected = NULL, + multiple = FALSE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::prettyCheckbox( + inputId = "compare_large_scale_characteristics_impute_missings", + label = "Impute missing values as 0", + value = FALSE) ) + ) ), bslib::navset_card_tab( - + bslib::nav_panel( title = "Table", - bslib::card( - full_screen = TRUE, - DT::DTOutput("gt_compare_lsc") |> withSpinner() - ) + bslib::card( + full_screen = TRUE, + DT::DTOutput("gt_compare_lsc") |> withSpinner() + ) ), bslib::nav_panel( title = "Plot", - bslib::card( - full_screen = TRUE, - bslib::layout_sidebar( - sidebar = bslib::sidebar(width = 400, open = "closed", + bslib::card( + full_screen = TRUE, + bslib::layout_sidebar( + sidebar = bslib::sidebar(width = 400, open = "closed", + shinyWidgets::pickerInput( + inputId = "compare_large_scale_characteristics_colour_1", + label = "Colour", + selected = c("table"), + multiple = TRUE, + choices = c("table", "database", "time_window"), + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "compare_large_scale_characteristics_facet_1", + label = "Facet", + selected = c("database"), + multiple = TRUE, + choices = c("table", "database", "time_window"), + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + position = "right" + ), + position = "right" + ), + plotly::plotlyOutput("plotly_compare_lsc") |> withSpinner() + ) + ) + ) + ) + ), + ## Cohort overlap ----- + bslib::nav_panel( + title = "Cohort overlap", + icon = shiny::icon("circle-half-stroke"), + bslib::layout_sidebar( + sidebar = bslib::sidebar(width = 400, open = "closed", + bslib::accordion( + bslib::accordion_panel( + title = "Settings", shinyWidgets::pickerInput( - inputId = "compare_large_scale_characteristics_colour_1", - label = "Colour", - selected = c("table"), + inputId = "summarise_cohort_overlap_grouping_cdm_name", + label = "Database", + choices = NULL, + selected = NULL, multiple = TRUE, - choices = c("table", "database", "time_window"), options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") ), shinyWidgets::pickerInput( - inputId = "compare_large_scale_characteristics_facet_1", - label = "Facet", - selected = c("database"), + inputId = "summarise_cohort_overlap_grouping_cohort_name_reference", + label = "Cohort name reference", + choices = NULL, + selected = NULL, multiple = TRUE, - choices = c("table", "database", "time_window"), options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") ), - position = "right" - ), - position = "right" - ), - plotly::plotlyOutput("plotly_compare_lsc") |> withSpinner() - ) - ) - )) - ), - ## Cohort overlap ----- - bslib::nav_panel( - title = "Cohort overlap", - icon = shiny::icon("circle-half-stroke"), - bslib::layout_sidebar( - sidebar = bslib::sidebar(width = 400, open = "closed", - bslib::accordion( - bslib::accordion_panel( - title = "Settings", - shinyWidgets::pickerInput( - inputId = "summarise_cohort_overlap_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 = "summarise_cohort_overlap_grouping_cohort_name_reference", - label = "Cohort name reference", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "summarise_cohort_overlap_grouping_cohort_name_comparator", - label = "Cohort name comparator", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ) - ), - bslib::accordion_panel( - title = "Variables", - shinyWidgets::pickerInput( - inputId = "summarise_cohort_overlap_variable_name", - label = "Variable name", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ) - ), - bslib::accordion_panel( - title = "Estimates", - shinyWidgets::pickerInput( - inputId = "summarise_cohort_overlap_estimate_name", - label = "Estimate name", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ) - ) - ) + shinyWidgets::pickerInput( + inputId = "summarise_cohort_overlap_grouping_cohort_name_comparator", + label = "Cohort name comparator", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ) + ), + bslib::accordion_panel( + title = "Variables", + shinyWidgets::pickerInput( + inputId = "summarise_cohort_overlap_variable_name", + label = "Variable name", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ) + ), + bslib::accordion_panel( + title = "Estimates", + shinyWidgets::pickerInput( + inputId = "summarise_cohort_overlap_estimate_name", + label = "Estimate name", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ) + ) + ) ), bslib::navset_card_tab( bslib::nav_panel( @@ -785,35 +798,35 @@ ui <- bslib::page_navbar( ), bslib::layout_sidebar( sidebar = bslib::sidebar(width = 400, open = "closed", - sortable::bucket_list( - header = NULL, - sortable::add_rank_list( - text = "none", - labels = c("cohort_name_reference", "cohort_name_comparator", "estimate_name"), - input_id = "summarise_cohort_overlap_gt_1_none" - ), - sortable::add_rank_list( - text = "header", - labels = "variable_name", - input_id = "summarise_cohort_overlap_gt_1_header" - ), - sortable::add_rank_list( - text = "groupColumn", - labels = "cdm_name", - input_id = "summarise_cohort_overlap_gt_1_groupColumn" - ), - sortable::add_rank_list( - text = "hide", - labels = "variable_level", - input_id = "summarise_cohort_overlap_gt_1_hide" - ) - ), - shiny::checkboxInput( - inputId = "summarise_cohort_overlap_gt_1_uniqueCombinations", - label = "uniqueCombinations", - value = c(TRUE) - ), - position = "right" + sortable::bucket_list( + header = NULL, + sortable::add_rank_list( + text = "none", + labels = c("cohort_name_reference", "cohort_name_comparator", "estimate_name"), + input_id = "summarise_cohort_overlap_gt_1_none" + ), + sortable::add_rank_list( + text = "header", + labels = "variable_name", + input_id = "summarise_cohort_overlap_gt_1_header" + ), + sortable::add_rank_list( + text = "groupColumn", + labels = "cdm_name", + input_id = "summarise_cohort_overlap_gt_1_groupColumn" + ), + sortable::add_rank_list( + text = "hide", + labels = "variable_level", + input_id = "summarise_cohort_overlap_gt_1_hide" + ) + ), + shiny::checkboxInput( + inputId = "summarise_cohort_overlap_gt_1_uniqueCombinations", + label = "uniqueCombinations", + value = c(TRUE) + ), + position = "right" ), gt::gt_output("summarise_cohort_overlap_gt_1") |> withSpinner() ) @@ -855,20 +868,20 @@ ui <- bslib::page_navbar( ), bslib::layout_sidebar( sidebar = bslib::sidebar(width = 400, open = "closed", - shinyWidgets::pickerInput( - inputId = "summarise_cohort_overlap_ggplot2_2_facet", - label = "facet", - selected = c("cdm_name", "cohort_name_reference"), - multiple = TRUE, - choices = c("cdm_name", "cohort_name_reference", "cohort_name_comparator", "variable_name", "variable_level", "estimate_name"), - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shiny::checkboxInput( - inputId = "summarise_cohort_overlap_ggplot2_2_uniqueCombinations", - label = "uniqueCombinations", - value = c(TRUE) - ), - position = "right" + shinyWidgets::pickerInput( + inputId = "summarise_cohort_overlap_ggplot2_2_facet", + label = "facet", + selected = c("cdm_name", "cohort_name_reference"), + multiple = TRUE, + choices = c("cdm_name", "cohort_name_reference", "cohort_name_comparator", "variable_name", "variable_level", "estimate_name"), + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shiny::checkboxInput( + inputId = "summarise_cohort_overlap_ggplot2_2_uniqueCombinations", + label = "uniqueCombinations", + value = c(TRUE) + ), + position = "right" ), plotly::plotlyOutput("summarise_cohort_overlap_ggplot2_2") ) @@ -878,7 +891,7 @@ ui <- bslib::page_navbar( ) ) ), - + # Population diagnostics ----- bslib::nav_menu( title = "Population diagnostics", @@ -889,51 +902,51 @@ ui <- bslib::page_navbar( icon = shiny::icon("chart-line"), bslib::layout_sidebar( sidebar = bslib::sidebar(width = 400, open = "closed", - bslib::accordion( - bslib::accordion_panel( - title = "Settings", - shinyWidgets::pickerInput( - inputId = "incidence_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 = "incidence_grouping_outcome_cohort_name", - label = "Outcome cohort name", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "incidence_settings_analysis_interval", - label = "Time interval", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "incidence_settings_denominator_age_group", - label = "Denominator age group", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "incidence_settings_denominator_sex", - label = "Denominator sex", - choices = NULL, - selected = NULL, - multiple = TRUE, - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ) - ) - ) + bslib::accordion( + bslib::accordion_panel( + title = "Settings", + shinyWidgets::pickerInput( + inputId = "incidence_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 = "incidence_grouping_outcome_cohort_name", + label = "Outcome cohort name", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "incidence_settings_analysis_interval", + label = "Time interval", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "incidence_settings_denominator_age_group", + label = "Denominator age group", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "incidence_settings_denominator_sex", + label = "Denominator sex", + choices = NULL, + selected = NULL, + multiple = TRUE, + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ) + ) + ) ), bslib::navset_card_tab( bslib::nav_panel( @@ -956,30 +969,30 @@ ui <- bslib::page_navbar( ), bslib::layout_sidebar( sidebar = bslib::sidebar(width = 400, open = "closed", - sortable::bucket_list( - header = NULL, - sortable::add_rank_list( - text = "none", - labels = c("cdm_name", "denominator_cohort_name", "incidence_start_date", "incidence_end_date", "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", "denominator_target_cohort_name", "outcome_cohort_name", "variable_name", "variable_level"), - input_id = "incidence_gt_18_none" - ), - sortable::add_rank_list( - text = "header", - labels = "estimate_name", - input_id = "incidence_gt_18_header" - ), - sortable::add_rank_list( - text = "groupColumn", - labels = character(), - input_id = "incidence_gt_18_groupColumn" - ), - sortable::add_rank_list( - text = "hide", - labels = character(), - input_id = "incidence_gt_18_hide" - ) - ), - position = "right" + sortable::bucket_list( + header = NULL, + sortable::add_rank_list( + text = "none", + labels = c("cdm_name", "denominator_cohort_name", "incidence_start_date", "incidence_end_date", "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", "denominator_target_cohort_name", "outcome_cohort_name", "variable_name", "variable_level"), + input_id = "incidence_gt_18_none" + ), + sortable::add_rank_list( + text = "header", + labels = "estimate_name", + input_id = "incidence_gt_18_header" + ), + sortable::add_rank_list( + text = "groupColumn", + labels = character(), + input_id = "incidence_gt_18_groupColumn" + ), + sortable::add_rank_list( + text = "hide", + labels = character(), + input_id = "incidence_gt_18_hide" + ) + ), + position = "right" ), gt::gt_output("incidence_gt_18") |> withSpinner() ) @@ -1020,36 +1033,36 @@ ui <- bslib::page_navbar( ), bslib::layout_sidebar( sidebar = bslib::sidebar(width = 400, open = "closed", - shinyWidgets::pickerInput( - inputId = "incidence_ggplot2_19_x", - label = "x", - selected = "incidence_start_date", - multiple = FALSE, - choices = c("cdm_name", "denominator_cohort_name", "incidence_start_date", "incidence_end_date", "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", "denominator_target_cohort_name", "outcome_cohort_name", "variable_name", "variable_level", "estimate_name"), - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shiny::checkboxInput( - inputId = "incidence_ggplot2_19_ribbon", - label = "ribbon", - value = c(FALSE) - ), - shinyWidgets::pickerInput( - inputId = "incidence_ggplot2_19_facet", - label = "facet", - selected = NULL, - multiple = TRUE, - choices = c("cdm_name", "denominator_cohort_name", "incidence_start_date", "incidence_end_date", "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", "denominator_target_cohort_name", "outcome_cohort_name", "variable_name", "variable_level", "estimate_name"), - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - shinyWidgets::pickerInput( - inputId = "incidence_ggplot2_19_colour", - label = "colour", - selected = NULL, - multiple = TRUE, - choices = c("cdm_name", "denominator_cohort_name", "incidence_start_date", "incidence_end_date", "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", "denominator_target_cohort_name", "outcome_cohort_name", "variable_name", "variable_level", "estimate_name"), - options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") - ), - position = "right" + shinyWidgets::pickerInput( + inputId = "incidence_ggplot2_19_x", + label = "x", + selected = "incidence_start_date", + multiple = FALSE, + choices = c("cdm_name", "denominator_cohort_name", "incidence_start_date", "incidence_end_date", "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", "denominator_target_cohort_name", "outcome_cohort_name", "variable_name", "variable_level", "estimate_name"), + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shiny::checkboxInput( + inputId = "incidence_ggplot2_19_ribbon", + label = "ribbon", + value = c(FALSE) + ), + shinyWidgets::pickerInput( + inputId = "incidence_ggplot2_19_facet", + label = "facet", + selected = NULL, + multiple = TRUE, + choices = c("cdm_name", "denominator_cohort_name", "incidence_start_date", "incidence_end_date", "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", "denominator_target_cohort_name", "outcome_cohort_name", "variable_name", "variable_level", "estimate_name"), + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + shinyWidgets::pickerInput( + inputId = "incidence_ggplot2_19_colour", + label = "colour", + selected = NULL, + multiple = TRUE, + choices = c("cdm_name", "denominator_cohort_name", "incidence_start_date", "incidence_end_date", "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", "denominator_target_cohort_name", "outcome_cohort_name", "variable_name", "variable_level", "estimate_name"), + options = list(`actions-box` = TRUE, size = 10, `selected-text-format` = "count > 3") + ), + position = "right" ), plotly::plotlyOutput("incidence_ggplot2_19") ) @@ -1275,7 +1288,7 @@ ui <- bslib::page_navbar( # ) # ) # ) - + ## Prevalence ----- bslib::nav_panel( title = "Prevalence", @@ -1668,8 +1681,8 @@ ui <- bslib::page_navbar( # ) # ) # ) - - + + ), # end ------ bslib::nav_spacer(), From 223aac74d118c9299035f69f38cf3e68ba43c752 Mon Sep 17 00:00:00 2001 From: Marta Alcalde-Herraiz <91142894+martaalcalde@users.noreply.github.com> Date: Fri, 13 Dec 2024 18:45:08 +0000 Subject: [PATCH 4/5] add plotAgeDistribution function --- inst/shiny/global.R | 64 +++++++ inst/shiny/server.R | 422 +++++++++++++++++++------------------------- inst/shiny/ui.R | 75 ++++---- 3 files changed, 292 insertions(+), 269 deletions(-) diff --git a/inst/shiny/global.R b/inst/shiny/global.R index 2ccc6b9..efebf7b 100644 --- a/inst/shiny/global.R +++ b/inst/shiny/global.R @@ -86,3 +86,67 @@ plotComparedLsc <- function(lsc, cohorts, imputeMissings, colour = NULL, facet = ggplotly(plot) } + +plotAgeDistribution <- function(summarise_table, summarise_characteristics){ + + data <- summarise_table |> + filter(variable_name == "age") |> + pivot_wider(names_from = "estimate_name", values_from = "estimate_value") |> + mutate(density_x = as.numeric(density_x), + density_y = as.numeric(density_y)) |> + splitStrata() |> + mutate(density_y = if_else(sex == "Female", -density_y, density_y)) + + max_density <- max(data$density_y, na.rm = TRUE) + min_age <- (floor((data$density_x |> min())/5))*5 + max_age <- (ceiling((data$density_x |> max())/5))*5 + + iqr <- dataFiltered$summarise_characteristics |> + filter(variable_name == "Age", + strata_level %in% c("Female","Male"), + estimate_name %in% c("q25", "median", "q75")) |> + mutate(estimate_value = as.numeric(estimate_value)) |> + left_join( + data |> + select("cdm_name", "strata_level" = "sex", "estimate_value" = "density_x", "density_y") |> + arrange(strata_level, estimate_value, density_y) |> + mutate(estimate_value_round = round(estimate_value)) |> + mutate(estimate_value_diff = estimate_value - estimate_value_round) |> + group_by(strata_level, estimate_value_round) |> + filter(estimate_value_diff == min(estimate_value_diff)) |> + select("cdm_name", "estimate_value" = "estimate_value_round", "density_y", "strata_level"), + by = c("estimate_value", "strata_level", "cdm_name") + ) |> + rename("sex" = "strata_level") + + ggplot(data, aes(x = density_x, y = density_y, fill = sex)) + + geom_polygon() + + geom_segment(data = iqr[iqr$estimate_name == "median", ], + aes(x = estimate_value, y = 0, xend = estimate_value, yend = density_y), + linewidth = 1) + + geom_segment(data = iqr[iqr$estimate_name != "median", ], + aes(x = estimate_value, y = 0, xend = estimate_value, yend = density_y), + linetype = 2, + linewidth = 1) + + scale_y_continuous(labels = function(x) scales::label_percent()(abs(x)), + limits = c(-max_percentage*1.1, max_percentage*1.1)) + + theme_bw() + + theme( + axis.text.x = element_text(), + axis.title.x = ggplot2::element_blank(), + panel.grid.major.x = element_line(color = "grey90"), + panel.grid.major.y = element_line(color = "grey90"), + legend.box = "horizontal", + axis.title.y = ggplot2::element_blank(), + legend.position = "bottom", + legend.title = ggplot2::element_blank(), + panel.background = ggplot2::element_blank() + ) + + scale_x_continuous(labels = c(as.character(seq(min_age,max_age-5,5)), paste0(max_age,"+")), + breaks = c(seq(min_age,max_age-5,5), max_age)) + + scale_fill_manual(values = list("Male" = "#4682B4","Female" = "#003153")) + + facet_wrap(c("cdm_name", "group_level")) + + coord_flip(clip = "off") + + labs(subtitle = "The solid line represents the median, while the dotted lines indicate the interquartile range.") +} + diff --git a/inst/shiny/server.R b/inst/shiny/server.R index 7c605b8..7c68fdd 100644 --- a/inst/shiny/server.R +++ b/inst/shiny/server.R @@ -19,7 +19,7 @@ server <- function(input, output, session) { selected = selected[[k]], server = TRUE ) - + shinyWidgets::updatePickerInput(session, inputId = names(choices)[k], choices = choices[[k]], @@ -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 ) %>% @@ -55,28 +55,28 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - - + + # 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) - + if (nrow(achillesFiltered) == 0) { validate("No results found for selected inputs") } - + CodelistGenerator::tableAchillesCodeUse(achillesFiltered, header = input$achilles_code_use_header, groupColumn = input$achilles_code_use_groupColumn, hide = input$achilles_code_use_hide) - + }) - + output$achilles_code_use_gt <- gt::render_gt({ createOutputAchillesCodeUse() }) @@ -86,25 +86,25 @@ server <- function(input, output, session) { res <- dataFiltered$summarise_observation_period |> filterData("summarise_observation_period", input) |> tidyData() - + # columns to eliminate colsEliminate <- colnames(res) colsEliminate <- colsEliminate[!colsEliminate %in% c( input$summarise_observation_period_tidy_columns, "variable_name", "variable_level", "estimate_name", "estimate_type", "estimate_value" )] - + # pivot pivot <- input$summarise_observation_period_tidy_pivot if (pivot != "none") { vars <- switch(pivot, - "estimates" = "estimate_name", - "estimates and variables" = c("variable_name", "variable_level", "estimate_name") + "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)) }) @@ -149,16 +149,16 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - + ## output 16 ----- createOutput16 <- shiny::reactive({ result <- dataFiltered$summarise_observation_period |> filterData("summarise_observation_period", input) - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + OmopSketch::plotObservationPeriod( result, variableName = input$summarise_observation_period_ggplot2_16_variableName, @@ -183,26 +183,26 @@ server <- function(input, output, session) { ) } ) - - + + # cohort_code_use ----- ## tidy cohort_code_use ----- getTidyDataCohortCodeUse <- shiny::reactive({ res <- dataFiltered$cohort_code_use |> tidyData() - - + + # pivot pivot <- input$cohort_code_use_tidy_pivot if (pivot != "none") { vars <- switch(pivot, - "estimates" = "estimate_name", - "estimates and variables" = c("variable_name", "variable_level", "estimate_name") + "estimates" = "estimate_name", + "estimates and variables" = c("variable_name", "variable_level", "estimate_name") ) res <- res |> visOmopResults::pivotEstimates(pivotEstimatesBy = vars) } - + res }) output$cohort_code_use_tidy <- DT::renderDT({ @@ -227,11 +227,11 @@ server <- function(input, output, session) { } result <- dataFiltered$cohort_code_use |> filterData("cohort_code_use", input) - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + CodelistGenerator::tableCohortCodeUse( result, header = input$cohort_code_use_gt_12_header, @@ -256,33 +256,33 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - - + + # summarise_cohort_attrition ----- ## tidy summarise_cohort_attrition ----- getTidyDataSummariseCohortAttrition <- shiny::reactive({ res <- dataFiltered$summarise_cohort_attrition |> filterData("summarise_cohort_attrition", input) |> tidyData() - + # columns to eliminate colsEliminate <- colnames(res) colsEliminate <- colsEliminate[!colsEliminate %in% c( input$summarise_cohort_attrition_tidy_columns, "variable_name", "variable_level", "estimate_name", "estimate_type", "estimate_value" )] - + # pivot pivot <- input$summarise_cohort_attrition_tidy_pivot if (pivot != "none") { vars <- switch(pivot, - "estimates" = "estimate_name", - "estimates and variables" = c("variable_name", "variable_level", "estimate_name") + "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)) }) @@ -305,11 +305,11 @@ server <- function(input, output, session) { createOutput3 <- shiny::reactive({ result <- dataFiltered$summarise_cohort_attrition |> filterData("summarise_cohort_attrition", input) - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + CohortCharacteristics::tableCohortAttrition( result, header = input$summarise_cohort_attrition_gt_3_header, @@ -334,7 +334,7 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - + ## output 4 ----- createOutput4 <- shiny::reactive({ result <- dataFiltered$summarise_cohort_attrition |> @@ -359,33 +359,33 @@ server <- function(input, output, session) { ) } ) - - + + # summarise_cohort_overlap ----- ## tidy summarise_cohort_overlap ----- getTidyDataSummariseCohortOverlap <- shiny::reactive({ res <- dataFiltered$summarise_cohort_overlap |> filterData("summarise_cohort_overlap", input) |> tidyData() - + # columns to eliminate colsEliminate <- colnames(res) colsEliminate <- colsEliminate[!colsEliminate %in% c( input$summarise_cohort_overlap_tidy_columns, "variable_name", "variable_level", "estimate_name", "estimate_type", "estimate_value" )] - + # pivot pivot <- input$summarise_cohort_overlap_tidy_pivot if (pivot != "none") { vars <- switch(pivot, - "estimates" = "estimate_name", - "estimates and variables" = c("variable_name", "variable_level", "estimate_name") + "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)) }) @@ -409,14 +409,14 @@ 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) - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + CohortCharacteristics::tableCohortOverlap( result, uniqueCombinations = input$summarise_cohort_overlap_gt_1_uniqueCombinations, @@ -442,13 +442,13 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - + ## 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( @@ -474,33 +474,33 @@ server <- function(input, output, session) { ) } ) - - + + # summarise_characteristics ----- ## tidy summarise_characteristics ----- getTidyDataSummariseCharacteristics <- shiny::reactive({ res <- dataFiltered$summarise_characteristics |> filterData("summarise_characteristics", input) |> tidyData() - + # columns to eliminate colsEliminate <- colnames(res) colsEliminate <- colsEliminate[!colsEliminate %in% c( input$summarise_characteristics_tidy_columns, "variable_name", "variable_level", "estimate_name", "estimate_type", "estimate_value" )] - + # pivot pivot <- input$summarise_characteristics_tidy_pivot if (pivot != "none") { vars <- switch(pivot, - "estimates" = "estimate_name", - "estimates and variables" = c("variable_name", "variable_level", "estimate_name") + "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)) }) @@ -521,11 +521,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, @@ -536,11 +536,11 @@ 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) - + if (nrow(result) == 0) { validate("No results found for selected inputs") } @@ -569,16 +569,16 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - + ## output 8 ----- createOutput8 <- shiny::reactive({ result <- dataFiltered$summarise_characteristics |> filterData("summarise_characteristics", input) - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + CohortCharacteristics::plotCharacteristics( result, plotType = input$summarise_characteristics_ggplot2_8_plotType, @@ -603,16 +603,16 @@ 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)) |> filter(estimate_value != "-") |> @@ -621,11 +621,11 @@ server <- function(input, output, session) { 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) - + if (nrow(lsc_data) == 0) { validate("No results found for selected inputs") } - + tidy(lsc_data) |> mutate(concept = paste0(variable_name, " (", concept_id, ")")) |> @@ -633,7 +633,7 @@ server <- function(input, output, session) { "concept", "count", "percentage") - + }) output$summarise_large_scale_characteristics_tidy <- DT::renderDT({ DT::datatable( @@ -653,26 +653,26 @@ 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") # } # if (input$top_n > 100) { # validate("Top n must be between 1 and 100") # } - - lsc_data <- dataFiltered$summarise_large_scale_characteristics |> - filter(!is.na(estimate_value)) |> - filter(estimate_value != "-") |> - visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_grouping_domain, - analysis %in% input$summarise_large_scale_characteristics_settings_analysis) |> + + lsc_data <- dataFiltered$summarise_large_scale_characteristics |> + filter(!is.na(estimate_value)) |> + filter(estimate_value != "-") |> + visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_grouping_domain, + analysis %in% input$summarise_large_scale_characteristics_settings_analysis) |> 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) + 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))) @@ -682,7 +682,7 @@ server <- function(input, output, session) { # header = input$summarise_large_scale_characteristics_gt_0_header, # groupColumn = input$summarise_large_scale_characteristics_gt_0_group, # hide = input$summarise_large_scale_characteristics_gt_0_hide - ) %>% + ) %>% tab_header( title = "Large scale characteristics", subtitle = "Summary of all records from clinical tables within a time window" @@ -690,7 +690,7 @@ server <- function(input, output, session) { tab_options( heading.align = "left" ) - + }) output$summarise_large_scale_characteristics_gt_0 <- gt::render_gt({ createOutput0() @@ -702,33 +702,33 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - - + + # incidence ----- ## tidy incidence ----- getTidyDataIncidence <- shiny::reactive({ res <- dataFiltered$incidence |> filterData("incidence", input) |> tidyData() - + # columns to eliminate colsEliminate <- colnames(res) colsEliminate <- colsEliminate[!colsEliminate %in% c( input$incidence_tidy_columns, "variable_name", "variable_level", "estimate_name", "estimate_type", "estimate_value" )] - + # pivot pivot <- input$incidence_tidy_pivot if (pivot != "none") { vars <- switch(pivot, - "estimates" = "estimate_name", - "estimates and variables" = c("variable_name", "variable_level", "estimate_name") + "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)) }) @@ -760,20 +760,20 @@ server <- function(input, output, session) { filterAdditional(analysis_interval %in% input$incidence_settings_analysis_interval) }) - + ## output 18 ----- createOutput18 <- shiny::reactive({ - + if (is.null(dataFiltered$incidence)) { validate("No incidence in results") } - + result <- incidenceFiltered() - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + IncidencePrevalence::tableIncidence( result, # header = input$incidence_gt_18_header, @@ -801,19 +801,19 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - + ## output 19 ----- createOutput19 <- shiny::reactive({ if (is.null(dataFiltered$incidence)) { validate("No incidence in results") } - + result <- incidenceFiltered() - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + IncidencePrevalence::plotIncidence( result, x = input$incidence_ggplot2_19_x, @@ -823,7 +823,7 @@ server <- function(input, output, session) { ) |> plotly::ggplotly() }) - + output$incidence_ggplot2_19 <- plotly::renderPlotly({ createOutput19() }) @@ -841,33 +841,33 @@ server <- function(input, output, session) { ) } ) - - + + # incidence_attrition ----- ## tidy incidence_attrition ----- getTidyDataIncidenceAttrition <- shiny::reactive({ res <- dataFiltered$incidence |> filterData("incidence_attrition", input) |> tidyData() - + # columns to eliminate colsEliminate <- colnames(res) colsEliminate <- colsEliminate[!colsEliminate %in% c( input$incidence_attrition_tidy_columns, "variable_name", "variable_level", "estimate_name", "estimate_type", "estimate_value" )] - + # pivot pivot <- input$incidence_attrition_tidy_pivot if (pivot != "none") { vars <- switch(pivot, - "estimates" = "estimate_name", - "estimates and variables" = c("variable_name", "variable_level", "estimate_name") + "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)) }) @@ -888,18 +888,18 @@ 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) - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + IncidencePrevalence::tableIncidenceAttrition( result, header = input$incidence_attrition_gt_22_header, @@ -924,10 +924,10 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - + # prevalence ----- prevalenceFiltered <- shiny::reactive({ - dataFiltered$prevalence |> + dataFiltered$prevalence |> filter(cdm_name %in% input$prevalence_grouping_cdm_name) |> filterGroup(outcome_cohort_name %in% @@ -939,20 +939,20 @@ server <- function(input, output, session) { analysis_interval %in% input$prevalence_settings_analysis_interval) }) - + ## tidy prevalence ----- getTidyDataPrevalence <- shiny::reactive({ res <- dataFiltered$prevalence |> filterData("prevalence", input) |> tidyData() - + # columns to eliminate colsEliminate <- colnames(res) colsEliminate <- colsEliminate[!colsEliminate %in% c( input$prevalence_tidy_columns, "variable_name", "variable_level", "estimate_name", "estimate_type", "estimate_value" )] - + # pivot pivot <- input$prevalence_tidy_pivot if (pivot != "none") { @@ -963,7 +963,7 @@ server <- function(input, output, session) { res <- res |> visOmopResults::pivotEstimates(pivotEstimatesBy = vars) } - + res |> dplyr::select(!dplyr::all_of(colsEliminate)) }) @@ -987,13 +987,13 @@ server <- function(input, output, session) { if (is.null(dataFiltered$prevalence)) { validate("No prevalence in results") } - + result <- prevalenceFiltered() - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + IncidencePrevalence::tablePrevalence( result, # header = input$prevalence_gt_prev1_header, @@ -1021,20 +1021,20 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - + ## output prev2 ----- createOutputprev2 <- shiny::reactive({ - + if (is.null(dataFiltered$prevalence)) { validate("No prevalence in results") } - + result <- prevalenceFiltered() - + if (nrow(result) == 0) { validate("No results found for selected inputs") } - + IncidencePrevalence::plotPrevalence( result, x = input$prevalence_ggplot2_prev2_x, @@ -1061,12 +1061,12 @@ server <- function(input, output, session) { ) } ) - - + + # compare lsc ---- - + outputLSC <- shiny::reactive({ - + browser() if (is.null(dataFiltered$summarise_large_scale_characteristics)) { validate("No large scale characteristics in results") } @@ -1074,16 +1074,16 @@ server <- function(input, output, session) { filter(variable_level %in% input$compare_large_scale_characteristics_grouping_time_window) |> filterSettings(table_name %in% input$compare_large_scale_characteristics_grouping_domain, analysis %in% input$compare_large_scale_characteristics_settings_analysis) - + }) - + output$gt_compare_lsc <- DT::renderDT({ lscFiltered <- outputLSC() - + if (nrow(lscFiltered) == 0) { validate("No results found for selected inputs") } - + target_cohort <- input$compare_large_scale_characteristics_grouping_cohort_1 comparator_cohort <- input$compare_large_scale_characteristics_grouping_cohort_2 lsc <- lscFiltered |> @@ -1103,12 +1103,12 @@ server <- function(input, output, session) { mutate(percentage = as.numeric(percentage)) |> pivot_wider(names_from = cohort_name, values_from = percentage) - + if(isTRUE(input$compare_large_scale_characteristics_impute_missings)){ lsc <- lsc |> mutate(across(c(target_cohort, comparator_cohort), ~if_else(is.na(.x), 0, .x))) } - + lsc <-lsc |> mutate(across(c(target_cohort, comparator_cohort), ~ as.numeric(.x)/100)) |> mutate(smd = (!!sym(target_cohort) - !!sym(comparator_cohort))/sqrt((!!sym(target_cohort)*(1-!!sym(target_cohort)) + !!sym(comparator_cohort)*(1-!!sym(comparator_cohort)))/2)) |> @@ -1121,23 +1121,23 @@ server <- function(input, output, session) { target_cohort, comparator_cohort, "Standardised mean difference" = smd) - - + + round_cols <- c("Standardised mean difference", target_cohort, comparator_cohort) - + DT::datatable(lsc, rownames= FALSE) %>% formatRound(columns=c(round_cols), digits=2) - + }) - - + + output$plotly_compare_lsc <- renderPlotly({ if (nrow(outputLSC()) == 0) { validate("No data to plot") } - + plotComparedLsc(lsc = outputLSC(), cohorts = c(input$compare_large_scale_characteristics_grouping_cohort_1, input$compare_large_scale_characteristics_grouping_cohort_2), @@ -1146,21 +1146,21 @@ server <- function(input, output, session) { imputeMissings = input$compare_large_scale_characteristics_impute_missings ) }) - + # orphan ----- ## tidy orphan ----- getTidyDataSummariseCharacteristics <- shiny::reactive({ res <- dataFiltered$orphan |> filterData("orphan", input) |> tidyData() - + # columns to eliminate colsEliminate <- colnames(res) colsEliminate <- colsEliminate[!colsEliminate %in% c( input$orphan_tidy_columns, "variable_name", "variable_level", "estimate_name", "estimate_type", "estimate_value" )] - + # pivot pivot <- input$orphan_tidy_pivot if (pivot != "none") { @@ -1171,7 +1171,7 @@ server <- function(input, output, session) { res <- res |> visOmopResults::pivotEstimates(pivotEstimatesBy = vars) } - + res |> dplyr::select(!dplyr::all_of(colsEliminate)) }) @@ -1192,34 +1192,34 @@ 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) - tbl <- CodelistGenerator::tableOrphanCodes( + tbl <- CodelistGenerator::tableOrphanCodes( result, header = input$orphan_gt_99_header, groupColumn = input$orphan_gt_99_groupColumn, hide = input$orphan_gt_99_hide ) - - tbl %>% + + tbl %>% tab_header( title = "Summary of orphan codes", subtitle = "Orphan codes refer to concepts present in the database that are not in a codelist but are related to included codes." ) %>% - tab_options( - heading.align = "left" - ) - + tab_options( + heading.align = "left" + ) + }) output$orphan_gt_99 <- gt::render_gt({ createOutput99() @@ -1231,7 +1231,7 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - + ## unmapped codes ----- ## output orphan ----- ## output 99 ----- @@ -1239,7 +1239,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, @@ -1266,98 +1266,42 @@ server <- function(input, output, session) { gt::gtsave(data = obj, filename = file) } ) - - - + + + ## age distribution ---- ## output table ---- createAgePyramid <- shiny::reactive({ - # Get age lables - age_labels <- tibble( - min_age = c(seq(0,95,5), 100), - max_age = c(seq(5,100,5),350), - age_group = paste0(min_age,"-",max_age-1)) |> - mutate(age_group = if_else(age_group == "100-349", "100+", age_group)) |> - mutate(age_group = factor(age_group, levels = age_group)) - - age_labels_plot <- age_labels |> - ggplot(aes(x = 1, y = age_group, label = age_group)) + - geom_text() + - theme_void() - - # Get age density and split it into groups - age_pyramid <- dataFiltered$summarise_table |> - filter(variable_name == "age") |> - filter(cdm_name == "CPRD GOLD") |> - filter(group_level == "overall") |> - select("variable_level", "estimate_name", "estimate_value", "sex" = "strata_level") |> - pivot_wider(names_from = "estimate_name", values_from = "estimate_value") |> - mutate(density_x = as.numeric(density_x), - density_y = as.numeric(density_y)) |> - mutate(age_group = case_when( - density_x >= 0 & density_x < 5 ~ "0-4", - density_x >= 5 & density_x < 10 ~ "5-9", - density_x >= 10 & density_x < 15 ~ "10-14", - density_x >= 15 & density_x < 20 ~ "15-19", - density_x >= 20 & density_x < 25 ~ "20-24", - density_x >= 25 & density_x < 30 ~ "25-29", - density_x >= 30 & density_x < 35 ~ "30-34", - density_x >= 35 & density_x < 40 ~ "35-39", - density_x >= 40 & density_x < 45 ~ "40-44", - density_x >= 45 & density_x < 50 ~ "45-49", - density_x >= 50 & density_x < 55 ~ "50-54", - density_x >= 55 & density_x < 60 ~ "55-59", - density_x >= 60 & density_x < 65 ~ "60-64", - density_x >= 65 & density_x < 70 ~ "65-69", - density_x >= 70 & density_x < 75 ~ "70-74", - density_x >= 75 & density_x < 80 ~ "75-79", - density_x >= 80 & density_x < 85 ~ "80-84", - density_x >= 85 & density_x < 90 ~ "85-89", - density_x >= 90 & density_x < 95 ~ "90-94", - density_x >= 95 & density_x < 100 ~ "95-99", - density_x >= 100 ~ "100+" - )) |> - group_by(age_group, sex) |> - mutate(percent = mean(density_y, na.rm = FALSE)) |> - ungroup() |> - select("age_group", "percent", "sex") |> - mutate(percent = if_else(sex == "Female",-percent,percent)) |> - distinct() - - age_pyramid <- age_labels |> - select("age_group") |> - slice(rep(1:n(), each = 2)) |> - mutate(sex = if_else(row_number() == 1, "Female", "Male"), .by = age_group) |> - left_join(age_pyramid, - by = c("age_group","sex"), - relationship = "many-to-many") |> - mutate(percent = if_else(is.na(percent), 0, percent)) |> - mutate(age_group = factor(age_group, levels = age_labels$age_group)) - - ggplot(age_pyramid, aes(x = percent, y = age_group, fill = sex)) + - geom_bar(stat = "identity") + - ggpol::facet_share(~sex, dir = "h", scales = "free", reverse_num = FALSE) + - scale_x_continuous(labels = function(x) scales::label_percent()(abs(x))) + - theme( - axis.text.x = element_text(), - axis.title.x = ggplot2::element_blank(), - panel.grid.major.x = element_line(color = "grey90"), - legend.box = "horizontal", - axis.title.y = ggplot2::element_blank(), - legend.position = "bottom", - legend.title = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - strip.text = ggplot2::element_blank(), - plot.margin = margin(10, 10, 10, 10) - ) + - scale_fill_manual(values = list("Male" = "#4682B4","Female" = "#003153")) - + summarise_table <- dataFiltered$summarise_table |> + filter(cdm_name %in% input$summarise_characteristics_grouping_cdm_name, + group_level %in% input$summarise_characteristics_grouping_cohort_name) + summarise_characteristics <- dataFiltered$summarise_characteristics |> + filter(cdm_name %in% input$summarise_characteristics_grouping_cdm_name, + group_level %in% input$summarise_characteristics_grouping_cohort_name) + + plotAgeDensity(summarise_table, summarise_characteristics) + }) - output$plot_age_pyramid <- plotly::renderPlotly({ + output$plot_age_pyramid <- shiny::renderPlot({ createAgePyramid() }) + output$plot_age_pyramid_download <- shiny::downloadHandler( + filename = paste0("output_ggplot2_age_pyramid.", "png"), + content = function(file) { + obj <- createAgePyramid() + ggplot2::ggsave( + filename = file, + plot = obj, + width = as.numeric(input$plot_age_pyramid_download_width), + height = as.numeric(input$plot_age_pyramid_download_height), + units = input$plot_age_pyramid_download_units, + dpi = as.numeric(input$plot_age_pyramid_download_dpi) + ) + } + ) + } diff --git a/inst/shiny/ui.R b/inst/shiny/ui.R index 326fb40..19deef3 100644 --- a/inst/shiny/ui.R +++ b/inst/shiny/ui.R @@ -432,32 +432,6 @@ ui <- bslib::page_navbar( inputId = "summarise_characteristics_include_matched", label = "Show matched cohorts", value = FALSE) - ), - bslib::accordion_panel( - title = "Table formatting", - sortable::bucket_list( - header = NULL, - sortable::add_rank_list( - text = "none", - labels = c("variable_name", "variable_level", "estimate_name"), - input_id = "summarise_characteristics_gt_7_none" - ), - sortable::add_rank_list( - text = "header", - labels = c("cdm_name", "cohort_name"), - input_id = "summarise_characteristics_gt_7_header" - ), - sortable::add_rank_list( - text = "groupColumn", - labels = NULL, - input_id = "summarise_characteristics_gt_7_groupColumn" - ), - sortable::add_rank_list( - text = "hide", - labels = character(), - input_id = "summarise_characteristics_gt_7_hide" - ) - ) ) ) ), @@ -480,21 +454,62 @@ ui <- bslib::page_navbar( ), class = "text-end" ), - gt::gt_output("summarise_characteristics_gt_7") |> withSpinner() + bslib::layout_sidebar( + sidebar = bslib::sidebar(width = 400, open = "closed", + sortable::bucket_list( + header = NULL, + sortable::add_rank_list( + text = "none", + labels = c("variable_name", "variable_level", "estimate_name"), + input_id = "summarise_characteristics_gt_7_none" + ), + sortable::add_rank_list( + text = "header", + labels = c("cdm_name", "cohort_name"), + input_id = "summarise_characteristics_gt_7_header" + ), + sortable::add_rank_list( + text = "groupColumn", + labels = NULL, + input_id = "summarise_characteristics_gt_7_groupColumn" + ), + sortable::add_rank_list( + text = "hide", + labels = character(), + input_id = "summarise_characteristics_gt_7_hide" + ) + ), + position = "right" + ), + gt::gt_output("summarise_characteristics_gt_7") |> withSpinner() + ) ) ), bslib::nav_panel( - title = "Age pyramid", + title = "Age distribution", bslib::card( full_screen = TRUE, - plotly::plotlyOutput("plot_age_pyramid") |> withSpinner() + bslib::card_header( + bslib::popover( + shiny::icon("download"), + shinyWidgets::pickerInput( + inputId = "plot_age_pyramid_download", + label = "File type", + selected = "png", + choices = c("docx", "png", "pdf", "html"), + multiple = FALSE + ), + shiny::downloadButton(outputId = "plot_age_pyramid_download", label = "Download") + ), + class = "text-end" + ), + shiny::plotOutput("plot_age_pyramid") ) ) ) ) ), ## Large scale characteristics ----- - bslib::nav_panel( title = "Large scale characteristics", icon = shiny::icon("arrow-up-right-dots"), From c5dc639981b6048fa4122161b2f2e506f928aadc Mon Sep 17 00:00:00 2001 From: Marta Alcalde-Herraiz <91142894+martaalcalde@users.noreply.github.com> Date: Fri, 13 Dec 2024 18:45:33 +0000 Subject: [PATCH 5/5] remove browser() --- inst/shiny/server.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/inst/shiny/server.R b/inst/shiny/server.R index 7c68fdd..fbb74df 100644 --- a/inst/shiny/server.R +++ b/inst/shiny/server.R @@ -1066,7 +1066,7 @@ server <- function(input, output, session) { # compare lsc ---- outputLSC <- shiny::reactive({ - browser() + if (is.null(dataFiltered$summarise_large_scale_characteristics)) { validate("No large scale characteristics in results") } @@ -1272,7 +1272,7 @@ server <- function(input, output, session) { ## age distribution ---- ## output table ---- createAgePyramid <- shiny::reactive({ - + summarise_table <- dataFiltered$summarise_table |> filter(cdm_name %in% input$summarise_characteristics_grouping_cdm_name, group_level %in% input$summarise_characteristics_grouping_cohort_name)