Nothing
inst/shiny/server.R
In PhenotypeR: Assess Study Cohorts Using a Common Data Model
# Generated by OmopViewer 0.1.0
# Be careful editing this file
server <- function(input, output, session) {
# Shared variables
inputs_initialized <- reactiveVal(FALSE)
shared_cdm_names <- reactiveVal(NULL)
shared_cohort_names <- reactiveVal(NULL)
# fill selectise variables ----
shiny::observe({
for (k in seq_along(choices)) {
if(!grepl("cdm_name|cohort_name", names(choices)[k])){
shiny::updateSelectizeInput(
session,
inputId = names(choices)[k],
choices = choices[[k]],
selected = selected[[k]],
server = TRUE
)
shinyWidgets::updatePickerInput(session,
inputId = names(choices)[k],
choices = choices[[k]],
selected = selected[[k]])
}
}
inputs_initialized(TRUE)
})
# sortable ui elements -----
# have these in server to avoid race condition (if in UI)
output$achilles_sortable <- renderUI({
sortable::bucket_list(
header = NULL,
sortable::add_rank_list(
text = "none",
labels = c("codelist_name"),
input_id = "achilles_code_use_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name", "estimate_name"),
input_id = "achilles_code_use_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = character(),
input_id = "achilles_code_use_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = character(),
input_id = "achilles_code_use_hide"
)
)
})
outputOptions(output, "achilles_sortable", suspendWhenHidden = FALSE)
output$orphan_sortable <- renderUI({
sortable::bucket_list(
header = NULL,
sortable::add_rank_list(
text = "none",
labels = c("variable_name", "cohort_name", "variable_level"),
input_id = "orphan_codes_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name", "estimate_name"),
input_id = "orphan_codes_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = character(),
input_id = "orphan_codes_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = character(),
input_id = "orphan_codes_gt_hide"
)
)
})
outputOptions(output, "orphan_sortable", suspendWhenHidden = FALSE)
output$cohort_code_use_sortable <- renderUI({
sortable::bucket_list(
header = NULL,
sortable::add_rank_list(
text = "none",
labels = c("cohort_name", "codelist_name", "source_concept_name", "source_concept_id", "variable_name", "variable_level"),
input_id = "cohort_code_use_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name", "estimate_name"),
input_id = "cohort_code_use_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = character(),
input_id = "cohort_code_use_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("diagnostic", "phenotyper_version",
"domain_id", "timing"),
input_id = "cohort_code_use_gt_hide"
)
)
})
outputOptions(output, "cohort_code_use_sortable", suspendWhenHidden = FALSE)
output$measurement_value_as_concept_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("variable_level", "estimate_name"),
input_id = "measurement_value_as_concept_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name"),
input_id = "measurement_value_as_concepts_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = c("cohort_name", "codelist_name"),
input_id = "measurement_value_as_concept_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("variable_name"),
input_id = "measurement_value_as_concept_gt_hide"
)
)
})
outputOptions(output, "measurement_value_as_concept_sortable", suspendWhenHidden = FALSE)
output$measurement_value_as_number_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("estimate_name"),
input_id = "measurement_value_as_number_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name"),
input_id = "measurement_value_as_number_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = c("cohort_name", "codelist_name"),
input_id = "measurement_value_as_number_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("variable_name", "variable_level"),
input_id = "measurement_value_as_number_gt_hide"
)
)
})
outputOptions(output, "measurement_value_as_number_sortable", suspendWhenHidden = FALSE)
output$measurement_summary_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("variable_name", "estimate_name"),
input_id = "measurement_summary_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name"),
input_id = "measurement_summary_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = c("cohort_name", "codelist_name"),
input_id = "measurement_summary_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("variable_level"),
input_id = "measurement_summary_gt_hide"
)
)
})
outputOptions(output, "measurement_summary_sortable", suspendWhenHidden = FALSE)
output$drug_diagnostics_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("ingredient_name","variable_name", "estimate_name"),
input_id = "drug_diagnostics_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name"),
input_id = "drug_diagnostics_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = c("cohort_name", "codelist_name"),
input_id = "drug_diagnostics_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("route", "drug_type",
"variable_level",
"ingredient_concept_id"),
input_id = "drug_diagnostics_gt_hide"
)
)
})
outputOptions(output, "drug_diagnostics_sortable", suspendWhenHidden = FALSE)
output$summarise_characteristics_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("variable_name", "variable_level", "estimate_name"),
input_id = "summarise_characteristics_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name", "cohort_name"),
input_id = "summarise_characteristics_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = NULL,
input_id = "summarise_characteristics_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("diagnostic", "phenotyper_version", "matchedSample"),
input_id = "summarise_characteristics_gt_hide"
)
)
})
outputOptions(output, "summarise_characteristics_sortable", suspendWhenHidden = FALSE)
output$summarise_cohort_overlap_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("cohort_name_reference", "cohort_name_comparator", "estimate_name"),
input_id = "summarise_cohort_overlap_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = "variable_name",
input_id = "summarise_cohort_overlap_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = "cdm_name",
input_id = "summarise_cohort_overlap_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("variable_level", "diagnostic", "phenotyper_version", "matchedSample"),
input_id = "summarise_cohort_overlap_gt_hide"
)
)
})
outputOptions(output, "summarise_cohort_overlap_sortable", suspendWhenHidden = FALSE)
output$summarise_cohort_timing_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("cohort_name_reference", "cohort_name_comparator", "estimate_name"),
input_id = "summarise_cohort_timing_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = "variable_name",
input_id = "summarise_cohort_timing_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = "cdm_name",
input_id = "summarise_cohort_timing_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = "variable_level",
input_id = "summarise_cohort_timing_gt_hide"
)
)
})
outputOptions(output, "summarise_cohort_timing_sortable", suspendWhenHidden = FALSE)
output$summarise_cohort_survival_sortable<- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("cdm_name", "target_cohort"),
input_id = "survival_table_none"
),
sortable::add_rank_list(
text = "header",
labels = "estimate_name",
input_id = "survival_table_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = character(),
input_id = "survival_table_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = character(),
input_id = "survival_table_hide"
)
)
})
outputOptions(output, "summarise_cohort_survival_sortable", suspendWhenHidden = FALSE)
# Define shared cdm_names values ----
cdm_values <- names(choices)[grepl("cdm_name", names(choices)) & names(choices) != "shared_cdm_names"]
last_active_cdm_input <- reactiveVal(NULL)
for(inputValue in cdm_values){
local({
inputValue_local <- inputValue
shiny::observeEvent(input[[inputValue_local]], {
val <- input[[inputValue_local]]
if (is.null(val) || length(val) == 0 || all(val == "")) {
val <- character(0)
}
if (!identical(val, shared_cdm_names())) {
last_active_cdm_input(inputValue_local)
shared_cdm_names(val)
}
}, ignoreNULL = FALSE)
})
}
shiny::observeEvent(shared_cdm_names(), {
new_shared_val <- shared_cdm_names()
source_input <- isolate(last_active_cdm_input())
for (inputId in cdm_values) {
if (!is.null(source_input) && inputId == source_input) {
next
}
current_val <- isolate(input[[inputId]])
if (is.null(current_val)) current_val <- character(0)
if (!identical(new_shared_val, current_val)) {
shinyWidgets::updatePickerInput(session, inputId, selected = new_shared_val)
}
}
}, ignoreNULL = FALSE, ignoreInit = TRUE)
# Define shared cohort_names values ----
cohort_values <- names(choices)[grepl("cohort_name", names(choices)) & names(choices) != "shared_cohort_names"]
last_active_cohort_input <- reactiveVal(NULL)
for(inputValue in cohort_values){
local({
inputValue_local <- inputValue
shiny::observeEvent(input[[inputValue_local]], {
val <- input[[inputValue_local]]
if (is.null(val) || length(val) == 0 || all(val == "")) {
val <- character(0)
}
if (!identical(val, shared_cohort_names())) {
last_active_cohort_input(inputValue_local) # Log the source!
shared_cohort_names(val)
}
}, ignoreNULL = FALSE)
})
}
shiny::observeEvent(shared_cohort_names(), {
new_shared_val <- shared_cohort_names()
source_input <- isolate(last_active_cohort_input())
for (inputId in cohort_values) {
if (!is.null(source_input) && inputId == source_input) {
next
}
current_val <- isolate(input[[inputId]])
if (is.null(current_val)) { current_val <- character(0) }
if (!identical(new_shared_val, current_val)) {
shinyWidgets::updatePickerInput(session, inputId, selected = new_shared_val)
}
}
}, ignoreNULL = FALSE, ignoreInit = TRUE)
# download raw data -----
output$download_raw <- shiny::downloadHandler(
filename = "results.csv",
content = function(file) {
# Initialize a progress bar
shiny::withProgress(value = 0, {
# Step 1: Importing data
shiny::incProgress(.25, message = "Importing data", detail = "Preparing summarised result...")
rawData <- omopgenerics::importSummarisedResult(file.path(getwd(), "data", "raw"))
# Step 2: Exporting data
shiny::incProgress(.75, message = "Exporting data", detail = "Preparing file for download...")
omopgenerics::exportSummarisedResult(rawData, fileName = file)
})
}
)
# summarise_omop_snapshot -----
filterOmopSnapshot <- eventReactive(input$updateSnapshot, ({
if (is.null(dataFiltered$summarise_omop_snapshot)) {
validate("No snapshot in results")
}
result <- dataFiltered$summarise_omop_snapshot |>
dplyr::filter(cdm_name %in% shared_cdm_names())
attr(result, "settings") <- attr(result, "settings") |>
dplyr::select(!c("diagnostic", "phenotyper_version"))
validateFilteredResult(result)
return(result)
}))
## Table summarise_omop_snapshot ----
createTableOmopSnapshot <- shiny::reactive({
filterOmopSnapshot() |>
OmopSketch::tableOmopSnapshot() |>
tab_header(
title = "Database metadata",
subtitle = "Overview of data source"
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_omop_snapshot_gt <- gt::render_gt({
createTableOmopSnapshot()
})
output$summarise_omop_snapshot_gt_download <- shiny::downloadHandler(
filename = "summarise_omop_snapshot_gt.docx",
content = function(file) {
gt::gtsave(data = createTableOmopSnapshot(), filename = file)
}
)
# summarise_person -----
filterPerson <- eventReactive(input$updatePerson, ({
if (is.null(dataFiltered$summarise_person)) {
validate("No person summary in results")
}
result <- dataFiltered$summarise_person |>
dplyr::filter(cdm_name %in% shared_cdm_names())
attr(result, "settings") <- attr(result, "settings") |>
dplyr::select(!c("diagnostic", "phenotyper_version"))
validateFilteredResult(result)
return(result)
}))
## Table summarise_person -----
createTablePerson <- shiny::reactive({
filterPerson() |>
OmopSketch::tablePerson() |>
tab_header(
title = "Summary of person table",
subtitle = "The person table contains core information on patients captured in the OMOP CDM dataset."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_person_gt <- gt::render_gt({
createTablePerson()
})
output$summarise_person_gt_download <- shiny::downloadHandler(
filename = "summarise_person_gt.docx",
content = function(file) {
obj <- createTablePerson()
gt::gtsave(data = obj, filename = file)
}
)
## Plot date of birth ----
filterPersonDob <- eventReactive(input$updatePerson, ({
if (is.null(dataFiltered$summarise_dob_density)) {
validate("No date of birth summary in results")
}
result <- dataFiltered$summarise_dob_density |>
dplyr::filter(cdm_name %in% shared_cdm_names())
validateFilteredResult(result)
return(result)
}))
output$dobPlot <- renderPlot({
filterPersonDob() |>
visOmopResults::scatterPlot(
x = "density_x",
y = "density_y",
colour = "cdm_name",
line = TRUE,
point = FALSE,
ribbon = FALSE,
ymin = NULL,
ymax = NULL) +
ggplot2::xlab("Date of Birth") +
ggplot2::ylab("Density") +
ggplot2::scale_y_continuous(labels = scales::label_number()) +
visOmopResults::themeVisOmop()
})
# summarise_observation_period -----
filterObservationPeriod <- eventReactive(input$updateObservationPeriod, ({
if (is.null(dataFiltered$summarise_observation_period)) {
validate("No observation period summary in results")
}
result <- dataFiltered$summarise_observation_period |>
dplyr::filter(cdm_name %in% shared_cdm_names())
attr(result, "settings") <- attr(result, "settings") |>
dplyr::select(!c("diagnostic", "phenotyper_version"))
validateFilteredResult(result)
return(result)
}))
## Table summarise_observation_period -----
createTableObservationPeriod <- shiny::reactive({
filterObservationPeriod() |>
OmopSketch::tableObservationPeriod() |>
tab_header(
title = "Summary of observation periods",
subtitle = "Observation periods are used to define time under observation for individuals in the data source."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_observation_period_gt <- gt::render_gt({
createTableObservationPeriod()
})
output$summarise_observation_period_gt_download <- shiny::downloadHandler(
filename = "summarise_observation_period_gt.docx",
content = function(file) {
obj <- createTableObservationPeriod()
gt::gtsave(data = obj, filename = file)
}
)
## Plot obs start end ----
filterObs <- eventReactive(input$updateObservationPeriod, ({
if (is.null(dataFiltered$summarise_obs_density)) {
validate("No date of observation period distributions in results")
}
result <- dataFiltered$summarise_obs_density |>
dplyr::filter(cdm_name %in% shared_cdm_names())
validateFilteredResult(result)
return(result)
}))
output$obsPlot <- renderPlot({
filterObs() |>
dplyr::mutate(variable_name =
dplyr::if_else(variable_name == "observation_period_start_date",
"observation period start date",
"observation period end date")) |>
dplyr::mutate(variable_name = factor(variable_name,
levels = c("observation period start date",
"observation period end date"))) |>
visOmopResults::scatterPlot(
x = "density_x",
y = "density_y",
group = "variable_name",
facet = "variable_name",
colour = "cdm_name",
line = TRUE,
point = FALSE,
ribbon = FALSE,
ymin = NULL,
ymax = NULL) +
ggplot2::xlab("Date") +
ggplot2::ylab("Density") +
ggplot2::scale_y_continuous(labels = scales::label_number()) +
ggplot2::facet_wrap(vars(variable_name),
ncol = 1, scales = "free_y")
})
# summarise_clinical_records ----
filterClinicalRecords <- eventReactive(input$updateClinicalRecords, ({
if (is.null(dataFiltered$summarise_clinical_records)) {
validate("No clinical records summary in results")
}
result <- dataFiltered$summarise_clinical_records |>
dplyr::filter(cdm_name %in% shared_cdm_names(),
group_level %in% input$summarise_clinical_records_omop_table)
attr(result, "settings") <- attr(result, "settings") |>
dplyr::select(!c("diagnostic", "phenotyper_version"))
validateFilteredResult(result)
return(result)
}))
## Table summarise_clinical_records -----
createClinicalRecordsTable <- shiny::reactive({
filterClinicalRecords() |>
OmopSketch::tableClinicalRecords() |>
tab_header(
title = "Summary of Clinical Records",
subtitle = "Summary of the clinical tables that contain the codes from the cohort codelist."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_clinical_records_gt <- gt::render_gt({
createClinicalRecordsTable()
})
output$summarise_clinical_records_gt_download <- shiny::downloadHandler(
filename = "summarise_clinical_records_gt.docx",
content = function(file) {
obj <- createClinicalRecordsTable()
gt::gtsave(data = obj, filename = file)
}
)
## Plot clinical record trends -----
filterClinicalRecordTrends <- eventReactive(input$updateClinicalRecords, ({
if (is.null(dataFiltered$summarise_trend)) {
validate("No clinical records summary in results")
}
result <- dataFiltered$summarise_trend |>
dplyr::filter(cdm_name %in% shared_cdm_names(),
group_level %in% input$summarise_clinical_records_omop_table)
validateFilteredResult(result)
return(result)
}))
output$clinicalTrends <- renderPlot({
plot <- filterClinicalRecordTrends() |>
OmopSketch::plotTrend(style = "default",
colour = input$clinical_records_plot_colour,
facet = input$clinical_records_plot_facet)
if(!is.null(input$clinical_records_plot_facet) &&
isTRUE(input$clinical_records_plot_facet_free)){
plot <- plot +
facet_wrap(facets = input$clinical_records_plot_facet,
scales = "free_y")
}
plot
})
# achilles_code_use -----
filterAchillesCodeUse <- eventReactive(input$updateAchillesCodeUse, ({
req(shared_cdm_names())
req(inputs_initialized())
if (is.null(dataFiltered$achilles_code_use)) {
validate("No achilles code use in results")
}
achillesFiltered <- dataFiltered$achilles_code_use |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% input$achilles_code_use_codelist_name)
if(isFALSE(input$achilles_person_count)){
achillesFiltered <- achillesFiltered |>
filter(estimate_name != "person_count")
}
if(isFALSE(input$achilles_record_count)){
achillesFiltered <- achillesFiltered |>
filter(estimate_name != "record_count")
}
validateFilteredResult(achillesFiltered)
return(achillesFiltered)
}))
## Table achilles_code_use ----
createAchillesCodeUseGT <- shiny::reactive({
tbl <- CodelistGenerator::tableAchillesCodeUse(filterAchillesCodeUse(),
header = input$achilles_code_use_header,
groupColumn = input$achilles_code_use_groupColumn,
hide = input$achilles_code_use_hide) |>
tab_header(
title = "Summary of achilles codes",
subtitle = "Codes from codelist observed in achilles tables."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
createAchillesCodeUseInteractive <- shiny::reactive({
tbl <- CodelistGenerator::tableAchillesCodeUse(filterAchillesCodeUse(),
header = input$achilles_code_use_header,
groupColumn = input$achilles_code_use_groupColumn,
hide = input$achilles_code_use_hide,
type = "tibble")
names(tbl) <- stringr::str_remove_all(names(tbl),
"\\[header_name\\]Database name\\n\\[header_level\\]")
names(tbl) <- stringr::str_remove_all(names(tbl),
"Estimate name\n\\[header_level\\]")
names(tbl) <- stringr::str_replace_all(names(tbl),
"\n\\[header_name\\]",
": ")
return(tbl)
})
output$achilles_code_use_tbl <- shiny::renderUI({
if(isFALSE(input$achilles_interactive)){
tbl <- createAchillesCodeUseGT()
return(tbl)
} else {
tbl <- createAchillesCodeUseInteractive()
# column ordering by codelist and first column with a count
order <- list("Codelist name" = "asc",
"count" = "desc")
names(order)[2] <- names(tbl)[9]
# suppressed to NA
tbl <- tbl |>
purrr::map_df(~ ifelse(grepl("^<", .), NA, .)) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ gsub(",", "", .))) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ suppressWarnings(as.numeric(.))))
tbl <- reactable::reactable(tbl,
defaultSorted = order,
groupBy = c("Codelist name"),
columns = getColsForTbl(tbl),
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Summary of achilles codes",
font_size = 25,
font_weight = "normal") |>
reactablefmtr_add_subtitle("Codes from codelist observed in achilles tables.",
font_size = 15,
font_weight = "normal")
return(tbl)
}
})
output$achilles_code_use_download <- shiny::downloadHandler(
filename = function(){
if(isFALSE(input$achilles_interactive)){
"summarise_achilles_code_use_gt.docx"
}else{
"summarise_achilles_code_use_tbl.csv"
}
},
content = function(file){
if(isFALSE(input$achilles_interactive)){
gt::gtsave(data = createAchillesCodeUseGT(), filename = file)
}else{
readr::write_csv(createAchillesCodeUseInteractive(), file = file)
}
}
)
# orphan_codes -----
filterOrphanCodes <- eventReactive(input$updateOrphanCodeUse, ({
req(shared_cdm_names())
req(inputs_initialized())
if (is.null(dataFiltered$orphan_code_use)) {
validate("No orphan codes in results")
}
result <- dataFiltered$orphan_code_use |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% input$orphan_code_use_codelist_name)
if(isFALSE(input$orphan_person_count)){
result <- result |>
filter(estimate_name != "person_count")
}
if(isFALSE(input$orphan_record_count)){
result <- result |>
filter(estimate_name != "record_count")
}
validateFilteredResult(result)
return(result)
}))
## Table orphan_codes -----
createOrphanCodesGT <- shiny::reactive({
tbl <- CodelistGenerator::tableOrphanCodes(
filterOrphanCodes(),
header = input$orphan_codes_gt_header,
groupColumn = input$orphan_codes_gt_groupColumn,
hide = input$orphan_codes_gt_hide
)
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"
)
return(tbl)
})
createOrphanCodesInteractive <- shiny::reactive({
tbl <- CodelistGenerator::tableOrphanCodes(
filterOrphanCodes(),
header = input$orphan_codes_gt_header,
groupColumn = input$orphan_codes_gt_groupColumn,
hide = input$orphan_codes_gt_hide,
type = "tibble"
)
names(tbl) <-stringr::str_remove_all(names(tbl),
"\\[header_name\\]Database name\\n\\[header_level\\]")
names(tbl) <- stringr::str_remove_all(names(tbl),
"Estimate name\n\\[header_level\\]")
names(tbl) <- stringr::str_replace_all(names(tbl),
"\n\\[header_name\\]",
": ")
return(tbl)
})
output$orphan_codes_tbl <- shiny::renderUI({
if(isFALSE(input$orphan_interactive)){
tbl <- createOrphanCodesGT()
return(tbl)
} else {
tbl <- createOrphanCodesInteractive()
# column ordering by codelist and first column with a count
order <- list("Codelist name" = "asc",
"count" = "desc")
names(order)[2] <- names(tbl)[11]
# suppressed to NA
tbl <- tbl |>
purrr::map_df(~ ifelse(grepl("^<", .), NA, .)) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ gsub(",", "", .))) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ suppressWarnings(as.numeric(.))))
tbl <- reactable(tbl,
groupBy = c("Codelist name"),
columns = getColsForTbl(tbl),
defaultSorted = order,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Summary of orphan codes",
font_size = 25,
font_weight = "normal") |>
reactablefmtr_add_subtitle("Orphan codes refer to concepts present in the database that are not in a codelist but are related to included codes.",
font_size = 15,
font_weight = "normal")
return(tbl)
}
})
output$orphan_codes_download <- shiny::downloadHandler(
filename = function(){
if(isFALSE(input$orphan_interactive)){
"summarise_orphan_codes_gt.docx"
}else{
"summarise_orphan_codes_tbl.csv"
}
},
content = function(file){
if(isFALSE(input$orphan_interactive)){
gt::gtsave(data = createOrphanCodesGT(), filename = file)
}else{
readr::write_csv(createOrphanCodesInteractive(), file = file)
}
}
)
# cohort_code_use -----
filterCohortCodeUse <- eventReactive(input$updateCohortCodeUse, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$cohort_code_use)) {
validate("No cohort code use in results")
}
result <- dataFiltered$cohort_code_use |>
visOmopResults::splitGroup(keep = TRUE) |>
visOmopResults::splitAdditional(keep = TRUE) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$cohort_name %in% shared_cohort_names(),
.data$domain_id %in% input$cohort_code_use_domain_id) |>
dplyr::select(-visOmopResults::groupColumns(dataFiltered$cohort_code_use)) |>
dplyr::select(-visOmopResults::additionalColumns(dataFiltered$cohort_code_use))
if(isFALSE(input$cohort_code_use_person_count)){
result <- result |>
filter(estimate_name != "person_count")
}
if(isFALSE(input$cohort_code_use_record_count)){
result <- result |>
filter(estimate_name != "record_count")
}
validateFilteredResult(result)
return(result)
}))
## Table cohort_code_use -----
createCohortCodeUseGT <- shiny::reactive({
tbl <- CodelistGenerator::tableCohortCodeUse(
filterCohortCodeUse(),
header = input$cohort_code_use_gt_header,
groupColumn = input$cohort_code_use_gt_groupColumn,
hide = input$cohort_code_use_gt_hide
) |>
tab_header(
title = "Summary of cohort code use",
subtitle = "Codes from codelist observed on day of cohort entry. Note more than one code could be seen for a person on this day (both of which would have led to inclusion)."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
createCohortCodeUseInteractive <- shiny::reactive({
tbl <- CodelistGenerator::tableCohortCodeUse(
filterCohortCodeUse(),
header = input$cohort_code_use_gt_header,
groupColumn = input$cohort_code_use_gt_groupColumn,
hide = input$cohort_code_use_gt_hide,
type = "tibble"
)
names(tbl) <-stringr::str_remove_all(names(tbl),
"\\[header_name\\]Database name\\n\\[header_level\\]")
names(tbl) <- stringr::str_remove_all(names(tbl),
"Estimate name\n\\[header_level\\]")
names(tbl) <- stringr::str_replace_all(names(tbl),
"\n\\[header_name\\]",
": ")
return(tbl)
})
output$cohort_code_use_tbl <- shiny::renderUI({
if(isFALSE(input$cohort_code_use_interactive)){
tbl <- createCohortCodeUseGT()
return(tbl)
} else {
tbl <- createCohortCodeUseInteractive() |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ gsub(",", "", .))) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ suppressWarnings(as.numeric(.))))
tbl <- tbl |>
dplyr::mutate("Cohort name - Codelist name" =
paste0(.data[["Cohort name"]], " - ", .data[["Codelist name"]])) |>
dplyr::select(-c("Cohort name", "Codelist name")) |>
dplyr::relocate("Cohort name - Codelist name")
# column ordering by codelist and first column with a count
order <- list("Cohort name - Codelist name" = "asc",
"count" = "desc")
names(order)[2] <- names(tbl)[11]
# suppressed to NA
tbl <- tbl |>
purrr::map_df(~ ifelse(grepl("^<", .), NA, .))
tbl <- reactable(tbl,
groupBy = c("Cohort name - Codelist name"),
columns = getColsForTbl(tbl,
sortNALast = FALSE,
names = c("Standard concept ID", "Source concept ID")),
defaultSorted = order,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Summary of cohort code use",
font_size = 25,
font_weight = "normal") |>
reactablefmtr_add_subtitle("Codes from codelist observed on day of cohort entry. Note more than one code could be seen for a person on this day (both of which would have led to inclusion).",
font_size = 15,
font_weight = "normal")
return(tbl)
}
})
output$cohort_code_use_download <- shiny::downloadHandler(
filename = function(){
if(isFALSE(input$cohort_code_use_interactive)){
file <- "summarise_cohort_code_use_gt.docx"
}else{
file <- "summarise_cohort_code_use_tbl.csv"
}
return(file)
},
content = function(file){
if(isFALSE(input$cohort_code_use_interactive)){
gt::gtsave(data = createCohortCodeUseGT(), filename = file)
}else{
readr::write_csv(createCohortCodeUseInteractive(), file = file)
}
}
)
# summarise measurement diagnostics -----
filterMeasurementSummary <- eventReactive(input$updateMeasurementCodeUse, ({
req(shared_cdm_names())
req(shared_cohort_names())
if (is.null(dataFiltered$measurement_summary)) {
validate("No measurement summary in results")
}
result <- dataFiltered$measurement_summary |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$cohort_name %in% shared_cohort_names())
validateFilteredResult(result)
return(result)
}))
## Table measurement_summary -----
createMeasurementSummaryGT <- shiny::reactive({
tbl <- MeasurementDiagnostics::tableMeasurementSummary(
filterMeasurementSummary(),
header = input$measurement_summary_gt_header,
groupColumn = input$measurement_summary_gt_groupColumn,
hide = input$measurement_summary_gt_hide
) |>
tab_header(
title = "Summary of measurements",
subtitle = "Only codes from measurements/observations are shown. Time between measurements and number of measurements per subject."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
output$measurement_summary_tbl <- shiny::renderUI({
createMeasurementSummaryGT()
})
output$measurement_summary_gt_download <- shiny::downloadHandler(
filename = "summarise_measurement_summary_gt.docx",
content = function(file){
gt::gtsave(data = createMeasurementSummaryGT(), filename = file)
}
)
## Plot measurement_summary ----
getPlotMeasurementSummary <- shiny::reactive({
result <- filterMeasurementSummary()
MeasurementDiagnostics::plotMeasurementSummary(
result,
y = input$measurement_summary_y,
plotType = input$measurement_summary_plottype,
timeScale = input$measurement_summary_time_scale,
facet = input$measurement_summary_facet,
colour = input$measurement_summary_colour)
})
output$plot_measurement_summary <- shiny::renderPlot({
getPlotMeasurementSummary()
})
output$plot_measurement_summary_download <- shiny::downloadHandler(
filename = "output_ggplot2_measurement_summary.png",
content = function(file) {
obj <- getPlotMeasurementSummary()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$plot_measurement_summary_download_width),
height = as.numeric(input$plot_measurement_summary_download_height),
units = input$plot_measurement_summary_download_units,
dpi = as.numeric(input$plot_measurement_summary_download_dpi)
)
}
)
# summarise measurement value as concept
filterMeasurementValueAsConcept <- eventReactive(input$updateMeasurementCodeUse, ({
if (is.null(dataFiltered$measurement_value_as_concept)) {
validate("No measurement value as concept in results")
}
result <- dataFiltered$measurement_value_as_concept |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$cohort_name %in% shared_cohort_names())
validateFilteredResult(result)
return(result)
}))
## Table measurement_value_as_concept -----
createMeasurementValueAsConceptGT <- shiny::reactive({
tbl <- MeasurementDiagnostics::tableMeasurementValueAsConcept(
filterMeasurementValueAsConcept(),
header = input$measurement_value_as_concept_gt_header,
groupColumn = input$measurement_value_as_concept_gt_groupColumn,
hide = input$measurement_value_as_concept_gt_hide
) |>
tab_header(
title = "Summary of measurement values (concepts)",
subtitle = "Only codes from measurements that are concepts are shown."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
output$measurement_value_as_concept_tbl <- shiny::renderUI({
createMeasurementValueAsConceptGT()
})
output$measurement_value_as_concept_gt_download <- shiny::downloadHandler(
filename = "summarise_measurement_value_as_concept_gt.docx",
content = function(file){
gt::gtsave(data = createMeasurementValueAsConceptGT(), filename = file)
}
)
## Plot measurement_value_as_concept ----
getPlotMeasurementValueAsConcept <- shiny::reactive({
result <- filterMeasurementValueAsConcept()
MeasurementDiagnostics::plotMeasurementValueAsConcept(
result,
x = input$measurement_value_as_concept_x,
y = input$measurement_value_as_concept_y,
facet = input$measurement_value_as_concept_facet,
colour = input$measurement_value_as_concept_colour
) +
facet_wrap(input$measurement_value_as_concept_facet, scales = "free_y")
})
output$plot_measurement_value_as_concept <- shiny::renderPlot({
getPlotMeasurementValueAsConcept()
})
output$plot_measurement_value_as_concept_download <- shiny::downloadHandler(
filename = "output_ggplot2_measurement_value_as_concept.png",
content = function(file) {
obj <- getPlotMeasurementValueAsConcept()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$plot_measurement_value_as_concept_download_width),
height = as.numeric(input$plot_measurement_value_as_concept_download_height),
units = input$plot_measurement_value_as_concept_download_units,
dpi = as.numeric(input$plot_measurement_value_as_concept_download_dpi)
)
}
)
# summarise measurement value as number
filterMeasurementValueAsNumber <- eventReactive(input$updateMeasurementCodeUse, ({
if (is.null(dataFiltered$measurement_value_as_number)) {
validate("No measurement value as number in results")
}
result <- dataFiltered$measurement_value_as_number |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$cohort_name %in% shared_cohort_names())
validateFilteredResult(result)
return(result)
}))
## Table measurement_value_as_number -----
createMeasurementValueAsNumberGT <- shiny::reactive({
tbl <- MeasurementDiagnostics::tableMeasurementValueAsNumber(
filterMeasurementValueAsNumber(),
header = input$measurement_value_as_number_gt_header,
groupColumn = input$measurement_value_as_number_gt_groupColumn,
hide = input$measurement_value_as_number_gt_hide
) |>
tab_header(
title = "Summary of measurement values (numeric)",
subtitle = "Only codes from measurements which results are numeric are shown."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
output$measurement_value_as_number_tbl <- shiny::renderUI({
createMeasurementValueAsNumberGT()
})
output$measurement_value_as_number_gt_download <- shiny::downloadHandler(
filename = "summarise_measurement_value_as_number_gt.docx",
content = function(file){
gt::gtsave(data = createMeasurementValueAsNumberGT(), filename = file)
}
)
## Plot measurement_value_as_number ----
getPlotMeasurementValueAsNumber <- shiny::reactive({
result <- filterMeasurementValueAsNumber()
MeasurementDiagnostics::plotMeasurementValueAsNumber(
result,
x = input$measurement_value_as_number_x,
plotType = input$measurement_value_as_number_plottype,
facet = input$measurement_value_as_number_facet,
colour = input$measurement_value_as_number_colour
)
})
output$plot_measurement_value_as_number <- shiny::renderPlot({
getPlotMeasurementValueAsNumber()
})
output$plot_measurement_value_as_number_download <- shiny::downloadHandler(
filename = "output_ggplot2_measurement_value_as_number.png",
content = function(file) {
obj <- getPlotMeasurementValueAsNumber()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$plot_measurement_value_as_number_download_width),
height = as.numeric(input$plot_measurement_value_as_number_download_height),
units = input$plot_measurement_value_as_number_download_units,
dpi = as.numeric(input$plot_measurement_value_as_number_download_dpi)
)
}
)
# summarise drug diagnostics -----
filterDrugDiagnostics<- eventReactive(input$updateDrugDiagnostics, ({
req(shared_cdm_names())
req(shared_cohort_names())
if (is.null(dataFiltered$summarise_drug_use)) {
validate("No drug diagnostics in results")
}
result <- dataFiltered$summarise_drug_use |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$cohort_name %in%
shared_cohort_names()) |>
omopgenerics::filterGroup(.data$codelist_name %in%
input$summarise_drug_use_codelist_name) |>
omopgenerics::filterGroup(.data$route %in%
input$summarise_drug_use_route) |>
omopgenerics::filterGroup(.data$drug_type %in%
input$summarise_drug_use_drug_type)
if(isFALSE(input$drug_use_overall)){
result <- result |>
dplyr::filter(str_detect(group_name, "concept_name"))
}
if(isFALSE(input$drug_use_by_concept)){
result <- result |>
dplyr::filter(str_detect(group_name, "concept_name", negate = TRUE))
}
validateFilteredResult(result)
return(result)
}))
## Table drug diagnostics -----
createDrugDiagnosticsGT <- shiny::reactive({
res <- filterDrugDiagnostics()
tbl <- res |>
dplyr::arrange(group_name, group_level) |>
visOmopResults::visOmopTable(header = input$drug_diagnostics_gt_header,
groupColumn = input$drug_diagnostics_gt_groupColumn,
estimateName = c(N = "<count>",
`Median [Q01, Q05, Q25 to Q75, Q95, Q99]` = "<median> [<q01>, <q05>, <q25> to <q75>, <q95>, <q99>]",
Range = "<min> to <max>",
`Percentage missing` = "<percentage_missing> %"),
hide = input$drug_diagnostics_gt_hide ) |>
tab_header(
title = "Drug exposure diagnostics"
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
createDrugDiagnosticsInteractive <- shiny::reactive({
res <- filterDrugDiagnostics()
tbl <- res |>
dplyr::arrange(group_name, group_level) |>
visOmopResults::visOmopTable(header = input$drug_diagnostics_gt_header,
groupColumn = input$drug_diagnostics_gt_groupColumn,
estimateName = c(N = "<count>",
`Median [Q01, Q05, Q25 to Q75, Q95, Q99]` = "<median> [<q01>, <q05>, <q25> to <q75>, <q95>, <q99>]",
Range = "<min> to <max>",
`Percentage missing` = "<percentage_missing> %"),
hide = input$drug_diagnostics_gt_hide,
type = "tibble")
names(tbl) <-stringr::str_remove_all(names(tbl),
"\\[header_name\\]CDM name\\n\\[header_level\\]")
names(tbl) <- stringr::str_remove_all(names(tbl),
"Estimate name\n\\[header_level\\]")
names(tbl) <- stringr::str_replace_all(names(tbl),
"\n\\[header_name\\]",
": ")
return(tbl)
})
output$drug_diagnostics_tbl <- shiny::renderUI({
if(isFALSE(input$drug_diagnostics_interactive)){
tbl <- createDrugDiagnosticsGT()
return(tbl)
} else {
tbl <- createDrugDiagnosticsInteractive()
tbl <- tbl |>
dplyr::mutate("Cohort name - Codelist name" =
paste0(.data[["Cohort name"]], " - ", .data[["Codelist name"]])) |>
dplyr::select(-c("Cohort name", "Codelist name")) |>
dplyr::relocate("Cohort name - Codelist name")
# column ordering by codelist and first column with a count
order <- list("Cohort name - Codelist name" = "asc")
tbl <- reactable(tbl,
groupBy = c("Cohort name - Codelist name"),
columns = getColsForTbl(tbl,
sortNALast = FALSE,
names = c("Standard concept ID", "Source concept ID")),
defaultSorted = order,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Drug diagnostics",
font_size = 25,
font_weight = "normal")
}
tbl
})
output$drug_diagnostics_gt_download <- shiny::downloadHandler(
filename = "summarise_drug_diagnostics_gt.docx",
content = function(file){
gt::gtsave(data = createDrugDiagnosticsGT(), filename = file)
}
)
# summarise_cohort_count -----
filterCohortCount <- eventReactive(input$updateCohortCount, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_cohort_count)) {
validate("No cohort count in results")
}
result <- dataFiltered$summarise_cohort_count |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% shared_cohort_names())
if(isFALSE(input$cohort_count_person_count)){
result <- result |>
dplyr::filter(.data$variable_name != "Number subjects")
}
if(isFALSE(input$cohort_count_record_count)){
result <- result |>
dplyr::filter(.data$variable_name != "Number records")
}
validateFilteredResult(result)
return(result)
}))
## Table summarise_cohort_count ----
createTableCohortCount <- shiny::reactive({
res <- filterCohortCount()
CohortCharacteristics::tableCohortCount(res,
hide = c("variable_level",
"estimate_name",
settingsColumns(res))) |>
tab_header(
title = "Cohort count",
subtitle = "Number of records and subjects in the study cohorts."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_cohort_count_gt <- gt::render_gt({
createTableCohortCount()
})
output$summarise_cohort_count_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_count_gt.docx",
content = function(file) {
obj <- createTableCohortCount()
gt::gtsave(data = obj, filename = file)
}
)
# summarise_cohort_attrition -----
filterCohortAttrition <- eventReactive(input$updateCohortCount,({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_cohort_attrition)) {
validate("No cohort attrition in results")
}
result <- dataFiltered$summarise_cohort_attrition |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% shared_cohort_names())
if(isFALSE(input$cohort_count_person_count)){
result <- result |>
dplyr::filter(!stringr::str_detect(.data$variable_name, "subjects"))
}
if(isFALSE(input$cohort_count_record_count)){
result <- result |>
dplyr::filter(!stringr::str_detect(.data$variable_name, "records"))
}
validateFilteredResult(result)
return(result)
}))
## Table summarise_cohort_attrition ----
createTableCohortAttrition <- shiny::reactive({
filterCohortAttrition() |>
CohortCharacteristics::tableCohortAttrition() |>
tab_header(
title = "Cohort attrition",
subtitle = "Attrition of the study cohorts."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_cohort_attrition_gt <- gt::render_gt({
createTableCohortAttrition()
})
output$summarise_cohort_attrition_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_attrition_gt.docx",
content = function(file) {
obj <- createTableCohortAttrition()
gt::gtsave(data = obj, filename = file)
}
)
## Diagram summarise_cohort_attrition -----
createDiagramCohortAttrition <- shiny::reactive({
result <- filterCohortAttrition()
n <- result |>
select(cdm_name, group_level) |>
distinct() |>
nrow()
CohortCharacteristics::plotCohortAttrition(
result
)
})
output$summarise_cohort_attrition_grViz <- DiagrammeR::renderGrViz({
createDiagramCohortAttrition()
})
output$summarise_cohort_attrition_grViz_download <- shiny::downloadHandler(
filename = "summarise_cohort_attrition_diagram.png",
content = function(file) {
createDiagramCohortAttrition() |>
DiagrammeRsvg::export_svg() |>
charToRaw() |>
rsvg::rsvg_png(file,
width = input$summarise_cohort_attrition_grViz_download_width,
height = input$summarise_cohort_attrition_grViz_download_height)
}
)
# summarise_characteristics -----
filterSummariseCharacteristics <- eventReactive(input$updateCohortCharacteristics, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_characteristics)) {
validate("No cohort characteristics in results")
}
selectedCohorts <- shared_cohort_names()
if(isTRUE(input$summarise_characteristics_include_matched)){
selectedCohorts <- as.vector(t(outer(selectedCohorts, c("", "_sampled", "_matched"), paste0)))
}
result <- dataFiltered$summarise_characteristics |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% selectedCohorts) |>
dplyr::mutate(group_level = factor(group_level, levels = selectedCohorts)) |>
arrange(group_level)
validateFilteredResult(result)
return(result)
}))
## Table summarise_characteristics -----
createTableSummariseCharacteristics <- shiny::reactive({
filterSummariseCharacteristics() |>
CohortCharacteristics::tableCharacteristics(
header = input$summarise_characteristics_gt_header,
groupColumn = input$summarise_characteristics_gt_groupColumn,
hide = c(input$summarise_characteristics_gt_hide,
"table_name", "value", "window", "table",
"diagnostic", "cohort_sample", "matched_sample", "phenotyper_version")
) |>
tab_header(
title = "Patient characteristics",
subtitle = "Summary of patient characteristics relative to cohort entry. Please be aware that statistics are calculated by record, not by subject."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_characteristics_gt <- gt::render_gt({
createTableSummariseCharacteristics()
})
output$summarise_characteristics_gt_download <- shiny::downloadHandler(
filename = "summarise_characteristics_gt.docx",
content = function(file) {
obj <- createTableSummariseCharacteristics()
gt::gtsave(data = obj, filename = file)
}
)
## Plot age_pyramid ----
createAgePyramid <- eventReactive(input$updateCohortCharacteristics, ({
summarise_characteristics <- filterSummariseCharacteristics()
summarise_table <- dataFiltered$summarise_table |>
filter(cdm_name %in% shared_cdm_names())
selectedCohorts <- shared_cohort_names()
if(isTRUE(input$summarise_characteristics_include_matched)){
selectedCohorts <- as.vector(t(outer(selectedCohorts, c("", "_sampled", "_matched"), paste0)))
}
summarise_table <- summarise_table |>
dplyr::filter(.data$group_level %in% selectedCohorts) |>
dplyr::mutate(group_level = factor(group_level, levels = selectedCohorts)) |>
arrange(group_level)
if (nrow(summarise_table) == 0 || nrow(summarise_characteristics) == 0 ) {
validate("No results found for selected inputs")
}
if (nrow(summarise_table) == 0 || nrow(summarise_characteristics) == 0 ) {
validate("No results found for selected inputs")
}
plotAgeDensity(summarise_table, summarise_characteristics, input$summarise_characteristics_add_interquantile_range)
}))
output$plot_age_pyramid <- shiny::renderPlot({
createAgePyramid()
})
output$plot_age_pyramid_download <- shiny::downloadHandler(
filename = "age_pyramid_plot.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)
)
}
)
# summarise_large_scale_characteristics -----
filterLargeScaleCharacteristics <- eventReactive(input$updateLSC, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
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 != "-") |>
visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_table_name,
analysis %in% input$summarise_large_scale_characteristics_analysis) |>
dplyr::filter(cdm_name %in% shared_cdm_names()) |>
dplyr::filter(group_level %in% shared_cohort_names()) |>
dplyr::filter(variable_level %in% input$summarise_large_scale_characteristics_variable_level)
validateFilteredResult(lsc_data)
return(lsc_data)
}))
## Table summarise_characteristics -----
tidyLargeScaleCharacteristics <- shiny::reactive({
tidy_lsc <- filterLargeScaleCharacteristics()
tidy_lsc <- tidy_lsc |>
tidy() |>
mutate(concept = paste0(variable_name, " (",
concept_id, ")"))
if("source_concept_id" %in% colnames(tidy_lsc)){
tidy_lsc <- tidy_lsc |>
mutate(source_concept = paste0(source_concept_name, " (",
source_concept_id, ")"))
}
tidy_lsc <- tidy_lsc |>
dplyr::select(dplyr::any_of(c("cdm_name",
"cohort_name",
"concept",
"source_concept",
"time_window" = "variable_level",
"count",
"percentage")))
return(tidy_lsc)
})
## Table summarise_large_scale_characteristics -----
output$summarise_large_scale_characteristics_tidy <- shiny::renderUI({
tbl_data <- tidyLargeScaleCharacteristics()
if("source_concept" %in% colnames(tbl_data)){
tbl_data <- tbl_data |>
rename("CDM name" = "cdm_name",
"Cohort" = "cohort_name",
"Time window" = "time_window",
"Concept name (concept ID)" = "concept",
"Source concept name (concept ID)" = "source_concept")
cols <- list("Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
"Source concept name (concept ID)" = colDef(name = "Source concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
count = colDef(format = colFormat(separators = TRUE)),
percentage = colDef(format = colFormat(percent = TRUE))
)
} else {
tbl_data <- tbl_data |>
rename("CDM name" = "cdm_name",
"Cohort" = "cohort_name",
"Time window" = "time_window",
"Concept name (concept ID)" = "concept")
cols <- list("Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
count = colDef(format = colFormat(separators = TRUE)),
percentage = colDef(format = colFormat(percent = TRUE))
)
}
reactable(tbl_data |>
mutate(percentage = percentage / 100), # to use colFormat
defaultSorted = list("percentage" = "desc"),
columns = cols,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Large scale characteristics",
font_size = 25,
font_weight = "normal") |>
reactablefmtr_add_subtitle("Summary of all records from clinical tables within a time window. The sampled cohort represents individuals from the original cohort, the matched cohort comprises individuals of similar age and sex from the database.",
font_size = 15,
font_weight = "normal")
})
output$summarise_large_scale_characteristics_tidy_download <- shiny::downloadHandler(
filename = "summarise_large_scale_characteristics_tidy.csv",
content = function(file) {
tidyLargeScaleCharacteristics() |>
readr::write_csv(file = file)
}
)
## Table summarise_large_scale_characteristics -----
createTableLargeScaleCharacteristics <- shiny::reactive({
lsc_data <- filterLargeScaleCharacteristics()
lsc_data |>
CohortCharacteristics::tableTopLargeScaleCharacteristics(
topConcepts = input$summarise_large_scale_characteristics_top_concepts) |>
tab_header(
title = "Top concepts in large scale characteristics",
subtitle = "Summary of the most prevalent concepts by percentage across each cohort."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_large_scale_characteristics_gt <- gt::render_gt({
createTableLargeScaleCharacteristics()
})
output$summarise_large_scale_characteristics_gt_download <- shiny::downloadHandler(
filename = "summarise_large_scale_characteristics_gt.docx",
content = function(file) {
obj <- createTableLargeScaleCharacteristics()
gt::gtsave(data = obj, filename = file)
}
)
# compare large_scale_characteristics ----
getComparedCohorts <- eventReactive(input$updateCompareLSC, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
cohort <- shared_cohort_names()
if(length(cohort) > 1){
validate("Please select only one cohort")
}
if(length(cohort) == 0){
validate("Please select a cohort")
}
cohort1 <- switch(input$compare_large_scale_characteristics_cohort_1,
"original" = cohort,
"sampled" = paste0(cohort,"_sampled"),
"matched" = paste0(cohort,"_matched"))
cohort2 <- switch(input$compare_large_scale_characteristics_cohort_2,
"original" = input$compare_large_scale_characteristics_cohort_compare,
"sampled" = paste0(input$compare_large_scale_characteristics_cohort_compare,"_sampled"),
"matched" = paste0(input$compare_large_scale_characteristics_cohort_compare,"_matched"))
return(list("cohort1" = cohort1,
"cohort2" = cohort2))
}))
filterCompareLargeScaleCharacteristics <- shiny::reactive({
shiny::observeEvent(shared_cdm_names(), {
updatePickerInput(session, "compare_large_scale_characteristics_cdm_name", selected = shared_cdm_names())
})
shiny::observeEvent(shared_cohort_names(), {
updatePickerInput(session, "compare_large_scale_characteristics_cohort_name", selected = shared_cohort_names())
})
if (is.null(dataFiltered$summarise_large_scale_characteristics)) {
validate("No large scale characteristics in results")
}
cohorts <- getComparedCohorts()
cohort1 <- cohorts$cohort1
cohort2 <- cohorts$cohort2
lsc_filtered <- dataFiltered$summarise_large_scale_characteristics |>
visOmopResults::filterSettings(.data$table_name %in% input$compare_large_scale_characteristics_table_name,
.data$analysis %in% input$compare_large_scale_characteristics_analysis) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% c(cohort1, cohort2),
.data$variable_level %in% input$compare_large_scale_characteristics_variable_level)
validateFilteredResult(lsc_filtered)
return(lsc_filtered)
})
## Tidy compare large_scale_characteristics ----
createTidyDataCompareLargeScaleCharacteristics <- shiny::reactive({
lscFiltered <- filterCompareLargeScaleCharacteristics()
cohorts <- getComparedCohorts()
target_cohort <- cohorts$cohort1
comparator_cohort <- cohorts$cohort2
if("matchedSample" %in% (lscFiltered |> omopgenerics::settings() |> colnames())){
msg <- paste0("Matched cohort was created based on a subsample of ", omopgenerics::settings(lscFiltered) |> dplyr::pull("matchedSample") |> unique()," individuals.")
}else{
msg <- ""
}
lsc <- lscFiltered |>
dplyr::filter(.data$estimate_name == "percentage") |>
tidy() |>
tidyr::pivot_wider(names_from = cohort_name,
values_from = percentage)
if(isTRUE(input$compare_large_scale_characteristics_impute_missings)){
lsc <- lsc |>
dplyr::mutate(across(c(target_cohort, comparator_cohort), ~if_else(is.na(.x), 0, .x)))
}
lsc <- lsc |>
dplyr::mutate(across(c(target_cohort, comparator_cohort), ~ as.numeric(.x)/100)) |>
dplyr::mutate(smd = (!!sym(target_cohort) - !!sym(comparator_cohort))/sqrt((!!sym(target_cohort)*(1-!!sym(target_cohort)) + !!sym(comparator_cohort)*(1-!!sym(comparator_cohort)))/2)) |>
dplyr::mutate(smd = if_else(is.na(smd), 0, round(smd, 3))) |>
dplyr::arrange(desc(smd)) |>
mutate(concept = paste0(variable_name, " (",concept_id, ")"))
if("source_concept_name" %in% colnames(lsc)){
lsc <- lsc |>
mutate(source_concept = paste0(source_concept_name, " (",source_concept_id, ")"))
}
lsc <- lsc |>
select(dplyr::any_of(c(
"CDM name" = "cdm_name",
"Concept name (concept ID)" = "concept",
"Source concept name (concept ID)" = "source_concept",
"Table" = "table_name",
"Time window" = "variable_level",
target_cohort,
comparator_cohort,
"Standardised mean difference" = "smd"))) |>
dplyr::mutate(msg)
return(lsc)
})
output$compare_large_scale_characteristics_tidy <- reactable::renderReactable({
cohorts <- getComparedCohorts()
target_cohort <- cohorts$cohort1
comparator_cohort <- cohorts$cohort2
tbl <- createTidyDataCompareLargeScaleCharacteristics()
msg <- tbl$msg |> unique()
tbl <- tbl |> dplyr::select(-"msg")
if("Source concept name (concept ID)" %in% colnames(tbl)){
cols <- list(target_cohort = colDef(name = paste0(target_cohort, " percentage"),
format = colFormat(percent = TRUE),
sortNALast = TRUE),
comparator_cohort = colDef(name = paste0(comparator_cohort, " percentage"),
format = colFormat(percent = TRUE),
sortNALast = TRUE),
"Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
"Source concept name (concept ID)" = colDef(name = "Source concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
"Standardised mean difference" = colDef(name = "Standardised mean difference",
sortNALast = TRUE)
)
} else {
cols <- list(target_cohort = colDef(name = paste0(target_cohort, " percentage"),
format = colFormat(percent = TRUE),
sortNALast = TRUE),
comparator_cohort = colDef(name = paste0(comparator_cohort, " percentage"),
format = colFormat(percent = TRUE),
sortNALast = TRUE),
"Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
"Standardised mean difference" = colDef(name = "Standardised mean difference",
sortNALast = TRUE)
)
}
names(cols)[1] <- target_cohort
names(cols)[2] <- comparator_cohort
table <- reactable::reactable(tbl,
defaultSorted = list("Standardised mean difference" = "desc"),
columns = cols,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE)
return(table)
})
output$compare_large_scale_characteristics_tidy_download <- shiny::downloadHandler(
filename = "compare_large_scale_characteristics_tidy.csv",
content = function(file) {
createTidyDataCompareLargeScaleCharacteristics() |>
readr::write_csv(file = file)
}
)
## Plot compare large_scale_characteristics ----
getPlotlyCompareLsc <- shiny::reactive({
cohorts <- getComparedCohorts()
plotComparedLsc(lsc = filterCompareLargeScaleCharacteristics(),
cohorts = c(cohorts$cohort1, cohorts$cohort2),
colour = c(input$compare_large_scale_characteristics_colour_1),
facet = c(input$compare_large_scale_characteristics_facet_1),
imputeMissings = input$compare_large_scale_characteristics_impute_missings
)
})
output$plotly_compare_lsc <- renderPlotly({
ggplotly(getPlotlyCompareLsc(), tooltip = "Details")
})
output$plot_compare_large_scale_characteristics_download <- shiny::downloadHandler(
filename = "output_ggplot2_compare_large_scale_characteristics.png",
content = function(file) {
obj <- getPlotlyCompareLsc()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$plot_compare_large_scale_characteristics_download_width),
height = as.numeric(input$plot_compare_large_scale_characteristics_download_height),
units = input$plot_compare_large_scale_characteristics_download_units,
dpi = as.numeric(input$plot_compare_large_scale_characteristics_download_dpi)
)
}
)
# summarise_cohort_overlap -----
filterCohortOverlap <- eventReactive(input$updateCompareCohorts, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_cohort_overlap)) {
validate("No cohort overlap in results")
}
result <- dataFiltered$summarise_cohort_overlap |>
visOmopResults::splitGroup(keep = TRUE) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$cohort_name_reference %in% shared_cohort_names(),
.data$cohort_name_comparator %in% input$summarise_cohort_overlap_cohort_comparator,
.data$variable_name %in% input$summarise_cohort_overlap_variable_name
) |>
dplyr::select(-visOmopResults::groupColumns(dataFiltered$summarise_cohort_overlap))
validateFilteredResult(result)
return(result)
}))
## Table cohort_overlap -----
createTableCohortOverlap <- shiny::reactive({
result <- filterCohortOverlap()
CohortCharacteristics::tableCohortOverlap(
result,
uniqueCombinations = input$summarise_cohort_overlap_gt_uniqueCombinations,
header = input$summarise_cohort_overlap_gt_header,
groupColumn = input$summarise_cohort_overlap_gt_groupColumn,
hide = c(input$summarise_cohort_overlap_gt_hide,
"overlap_by",
"diagnostic", "matchedSample", "phenotyper_version")
) |>
tab_header(
title = "Cohort overlap",
subtitle = "Overlap is where the same individual is in both cohorts. Note their cohort entries do not necessarily overlap."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_cohort_overlap_gt <- gt::render_gt({
createTableCohortOverlap()
})
output$summarise_cohort_overlap_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_overlap_gt.docx",
content = function(file) {
obj <- createTableCohortOverlap()
gt::gtsave(data = obj, filename = file)
}
)
## Plot cohort_overlap -----
createPlotCohortOverlap <- shiny::reactive({
result <- filterCohortOverlap()
CohortCharacteristics::plotCohortOverlap(
result,
colour = input$summarise_cohort_overlap_plot_colour,
facet = input$summarise_cohort_overlap_plot_facet,
uniqueCombinations = input$summarise_cohort_overlap_plot_uniqueCombinations
)
})
output$summarise_cohort_overlap_plot <- plotly::renderPlotly({
createPlotCohortOverlap()
})
output$summarise_cohort_overlap_plot_download <- shiny::downloadHandler(
filename = "summarise_cohort_overlap_plot.png",
content = function(file) {
obj <- createPlotCohortOverlap()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$summarise_cohort_overlap_plot_download_width),
height = as.numeric(input$summarise_cohort_overlap_plot_download_height),
units = input$summarise_cohort_overlap_plot_download_units,
dpi = as.numeric(input$summarise_cohort_overlap_plot_download_dpi)
)
}
)
# summarise_cohort_timing ----
filterCohortTiming <- eventReactive(input$updateCompareCohorts, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_cohort_timing)) {
validate("No cohort timing in results")
}
result <- dataFiltered$summarise_cohort_timing |>
visOmopResults::splitGroup(keep = TRUE) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$cohort_name_reference %in% shared_cohort_names(),
.data$cohort_name_comparator %in% input$summarise_cohort_overlap_cohort_comparator) |>
dplyr::select(-visOmopResults::groupColumns(dataFiltered$summarise_cohort_timing))
validateFilteredResult(result)
return(result)
}))
## Table cohort_timing -----
createTableCohortTiming <- shiny::reactive({
result <- filterCohortTiming()
CohortCharacteristics::tableCohortTiming(
result,
timeScale = input$summarise_cohort_timing_gt_time_scale,
uniqueCombinations = input$summarise_cohort_timing_gt_uniqueCombinations,
) |>
tab_header(
title = "Cohort timing",
subtitle = "Cohort timing refers to the time between an individual entering one cohort and another cohort."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_cohort_timing_gt <- gt::render_gt({
createTableCohortTiming()
})
output$summarise_cohort_timing_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_timing_gt.docx",
content = function(file) {
obj <- createTableCohortTiming()
gt::gtsave(data = obj, filename = file)
}
)
## Plot cohort_timing -----
createPlotCohortTiming <- shiny::reactive({
CohortCharacteristics::plotCohortTiming(
filterCohortTiming(),
plotType = "densityplot",
timeScale = input$summarise_cohort_timing_plot_time_scale,
uniqueCombinations = input$summarise_cohort_timing_plot_uniqueCombinations,
facet = input$summarise_cohort_timing_plot_facet,
colour = input$summarise_cohort_timing_plot_colour
)
})
output$summarise_cohort_timing_plot <- shiny::renderUI({
renderPlot(createPlotCohortTiming())
})
output$summarise_cohort_timing_plot_download <- shiny::downloadHandler(
filename = "summarise_cohort_timing_plot.png",
content = function(file) {
obj <- createPlotCohortTiming()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$summarise_cohort_timing_plot_download_width),
height = as.numeric(input$summarise_cohort_timing_plot_download_height),
units = input$summarise_cohort_timing_plot_download_units,
dpi = as.numeric(input$summarise_cohort_timing_plot_download_dpi)
)
}
)
# summarise cohort survival -----
filterCohortSurvival <- eventReactive(input$updateCohortSurvival, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$survival_estimates)) {
validate("No survival in results")
}
if(input$survival_porbability_include_matches){
cohorts <- c(paste0(shared_cohort_names(),"_sampled"),
paste0(shared_cohort_names(),"_matched"))
}else{
cohorts <- shared_cohort_names()
}
result <- omopgenerics::bind(
dataFiltered[str_detect(names(dataFiltered), "survival_")]) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$target_cohort %in% cohorts)
validateFilteredResult(result)
return(result)
}))
getTimeScale <- eventReactive(input$updateCohortSurvival, ({
timeScale <- input$survival_probability_time_scale
return(timeScale)
}))
## Table cohort survival -----
createTableSurvival <- shiny::reactive({
result <- filterCohortSurvival()
timeScale <- getTimeScale()
table <- CohortSurvival::tableSurvival(result,
timeScale = timeScale,
header = input$survival_table_header,
groupColumn = input$survival_table_groupColumn) |>
tab_header(
title = "Single Event Survival Summary",
subtitle = "Time from cohort entry to death"
) |>
tab_options(
heading.align = "left"
)
return(table)
})
output$summarise_cohort_survival_gt <- gt::render_gt({
createTableSurvival()
})
output$summarise_cohort_survival_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_survival_gt.docx",
content = function(file) {
obj <- createTableSurvival()
gt::gtsave(data = obj, filename = file)
}
)
## Plot cohort survival ----
createPlotSurvival <- shiny::reactive({
result <- filterCohortSurvival()
timeScale <- getTimeScale()
CohortSurvival::plotSurvival(result,
timeScale = timeScale,
ribbon = input$survival_plot_ribbon,
facet = input$survival_plot_facet,
colour = input$survival_plot_colour,
logLog = input$survival_plot_log_log,
cumulativeFailure = input$survival_plot_cf) +
labs(color = "Color") +
guides(fill = "none")
})
output$summarise_cohort_survival_plot <- shiny::renderUI({
if(isTRUE(input$survival_plot_interactive)){
plot <- plotly::ggplotly(createPlotSurvival())
} else {
plot <- renderPlot(createPlotSurvival())
}
plot
})
output$summarise_cohort_survival_plot_download <- shiny::downloadHandler(
filename = "summarise_cohort_survival_plot.png",
content = function(file) {
obj <- createPlotSurvival()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$summarise_cohort_survival_plot_download_width),
height = as.numeric(input$summarise_cohort_survival_plot_download_height),
units = input$summarise_cohort_survival_plot_download_units,
dpi = as.numeric(input$summarise_cohort_survival_plot_download_dpi)
)
}
)
# incidence -----
filterIncidence <- eventReactive(input$updateIncidence, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$incidence)) {
validate("No incidence in results")
}
result <- dataFiltered$incidence |>
filter(cdm_name %in% shared_cdm_names()) |>
filterGroup(outcome_cohort_name %in% shared_cohort_names()) |>
filterSettings(denominator_age_group %in%
input$incidence_denominator_age_group,
denominator_sex %in%
input$incidence_denominator_sex,
denominator_days_prior_observation %in%
input$incidence_denominator_days_prior_observation) |>
filterAdditional(analysis_interval %in%
input$incidence_analysis_interval)
validateFilteredResult(result)
return(result)
}))
## Table incidence -----
createTableIncidence <- shiny::reactive({
IncidencePrevalence::tableIncidence(
filterIncidence(),
groupColumn = c("cdm_name", "outcome_cohort_name"),
hide = "denominator_cohort_name",
settingsColumn = c("denominator_age_group",
"denominator_sex",
"denominator_days_prior_observation",
"outcome_cohort_name")
) |>
tab_header(
title = "Incidence estimates",
subtitle = "Incidence rates estimated for outcomes of interest"
) |>
tab_options(
heading.align = "left"
)
})
output$incidence_gt <- gt::render_gt({
createTableIncidence()
})
output$incidence_gt_download <- shiny::downloadHandler(
filename = "incidence_gt.docx",
content = function(file) {
obj <- createTableIncidence()
gt::gtsave(data = obj, filename = file)
}
)
## Plot incidence -----
createPlotIncidence <- shiny::reactive({
result <- filterIncidence()
x <- input$incidence_plot_x
y <- input$incidence_plot_y
facet <- input$incidence_plot_facet
facet_free <- input$incidence_plot_facet_free
colour <- input$incidence_plot_colour
# Plot incidence estimates
if(y == "Incidence"){
plot <- IncidencePrevalence::plotIncidence(
result,
x = x,
ribbon = FALSE,
facet = facet,
colour = colour
)
plot$data <- plot$data |>
filter(incidence_100000_pys > 0)
if(!is.null(facet) && isTRUE(facet_free)){
plot <- plot +
facet_wrap(facets = facet, scales = "free")
}
}else{
# Plot incidence population
y_input <- case_when(
y == "Denominator count" ~ "denominator_count",
y == "Denominator person years" ~ "person_years",
y == "Outcome count" ~ "outcome_count"
)
if(!is.null(facet) && isTRUE(facet_free)){
plot <- plotIncidencePopulation(x = x,
y = y_input,
result = result,
facet = NULL,
colour = colour
) +
facet_wrap(facets = facet, scales = "free")
} else {
plot <- plotIncidencePopulation(x = x,
y = y_input,
result = result,
facet = facet,
colour = colour
)
}
}
return(plot)
})
output$incidence_plot <- shiny::renderUI({
if(isTRUE(input$incidence_plot_interactive)){
plot <- plotly::ggplotly(createPlotIncidence())
} else {
plot <- renderPlot(createPlotIncidence())
}
plot
})
output$incidence_plot_download <- shiny::downloadHandler(
filename = "incidence_plot.png",
content = function(file) {
obj <- createPlotIncidence()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$incidence_plot_download_width),
height = as.numeric(input$incidence_plot_download_height),
units = input$incidence_plot_download_units,
dpi = as.numeric(input$incidence_plot_download_dpi)
)
}
)
# prevalence -----
filterPrevalence <- eventReactive(input$updatePrevalence, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$prevalence)) {
validate("No prevalence in results")
}
result <- dataFiltered$prevalence |>
filter(cdm_name %in% shared_cdm_names()) |>
filterGroup(outcome_cohort_name %in% shared_cohort_names()) |>
filterSettings(denominator_age_group %in%
input$prevalence_denominator_age_group,
denominator_sex %in%
input$prevalence_denominator_sex,
denominator_days_prior_observation %in%
input$prevalence_denominator_days_prior_observation) |>
filterAdditional(analysis_interval %in%
input$prevalence_analysis_interval)
validateFilteredResult(result)
return(result)
}))
## Table prevalence ----
createTablePrevalence <- shiny::reactive({
result <- filterPrevalence()
IncidencePrevalence::tablePrevalence(
result,
groupColumn = c("cdm_name", "outcome_cohort_name"),
hide = "denominator_cohort_name",
settingsColumn = c("denominator_age_group",
"denominator_sex",
"denominator_days_prior_observation",
"outcome_cohort_name")
) |>
tab_header(
title = "Prevalence estimates",
subtitle = "Prevalence rates estimated for outcomes of interest"
) |>
tab_options(
heading.align = "left"
)
})
output$prevalence_gt <- gt::render_gt({
createTablePrevalence()
})
output$prevalence_gt_download <- shiny::downloadHandler(
filename = "prevalence_gt.docx",
content = function(file) {
obj <- createTablePrevalence()
gt::gtsave(data = obj, filename = file)
}
)
## Plot prevalence ----
createPlotPrevalence <- shiny::reactive({
result <- filterPrevalence()
x <- input$prevalence_plot_x
y <- input$prevalence_plot_y
facet <- input$prevalence_plot_facet
facet_free <- input$prevalence_plot_facet_free
colour <- input$prevalence_plot_colour
if(y == "Prevalence"){
plot <- IncidencePrevalence::plotPrevalence(
result,
x = x,
ribbon = FALSE,
facet = facet,
colour = colour
)
plot$data$prevalence_95CI_lower <- round(plot$data$prevalence_95CI_lower, 6)
plot$data$prevalence_95CI_upper <- round(plot$data$prevalence_95CI_upper, 6)
plot$data <- plot$data |>
dplyr::mutate(prevalence = round((outcome_count/denominator_count),6))
if(!is.null(facet) && isTRUE(facet_free)){
plot <- plot +
facet_wrap(facets = facet, scales = "free")
}
}else{
y_input <- case_when(
y == "Denominator count" ~ "denominator_count",
y == "Outcome count" ~ "outcome_count"
)
if(!is.null(facet) && isTRUE(input$facet_free)){
plot <- IncidencePrevalence::plotPrevalencePopulation(
result = result,
x = x,
y = y_input,
facet = NULL,
colour = colour) +
facet_wrap(facets = facet, scales = "free")
} else {
plot <- IncidencePrevalence::plotPrevalencePopulation(
result = result,
x = x,
y = y_input,
facet = facet,
colour = colour
)
}
}
return(plot)
})
output$prevalence_plot <- shiny::renderUI({
if(isTRUE(input$prevalence_plot_interactive)){
plot <- plotly::ggplotly(createPlotPrevalence())
} else {
plot <- renderPlot(createPlotPrevalence())
}
plot
})
output$prevalence_plot_download <- shiny::downloadHandler(
filename = "prevalence_plot.png",
content = function(file) {
obj <- createPlotPrevalence()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$prevalence_plot_download_width),
height = as.numeric(input$prevalence_plot_download_height),
units = input$prevalence_plot_download_units,
dpi = as.numeric(input$prevalence_plot_download_dpi)
)
}
)
# log file -----
output$summarise_log_file_gt <- gt::render_gt({
dataFiltered$summarise_log_file |>
omopgenerics::tidy() |>
dplyr::mutate(log_id = as.integer(log_id)) |>
dplyr::arrange("cdm_name", "log_id") |>
dplyr::select(cdm_name, variable_name,
elapsed_time) |>
dplyr::mutate(elapsed_time =
dplyr::if_else(!is.na(elapsed_time),
sprintf("%d hours, %d minutes, %d seconds",
lubridate::hour(elapsed_time),
lubridate::minute(elapsed_time),
lubridate::second(elapsed_time)),
NA_character_)) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "0 hours, 0 minutes, ", "")) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "0 hours, ", "")) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "1 hours", "1 hour")) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "1 minutes", "1 minute")) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "1 seconds", "1 second")) |>
dplyr::rename("task" = "variable_name",
estimate_value = "elapsed_time") |>
dplyr::mutate(estimate_type = "character",
estimate_name = "Time taken") |>
visOmopResults::visTable(
header = c("cdm_name", "estimate_name"),
rename = c("Database name" = "cdm_name"),
hide = "estimate_type") |>
gt::tab_options(container.width = "100%")
})
# expectations ----
createExpectationsOutput <- function(trigger_input, output_id) {
filteredExpectations <- eventReactive(trigger_input(), {
req(shared_cohort_names())
req(inputs_initialized())
validateExpectations(expectations)
section_name <- gsub("_expectations","",output_id)
result <- expectations |>
dplyr::filter(.data$cohort_name %in% shared_cohort_names())
section_name <- gsub("_expectations","",output_id)
if("diagnostics" %in% colnames(expectations)){
result <- result |>
mutate(diagnostics = strsplit(diagnostics, ",\\s*")) |>
unnest(diagnostics)
validateExpectationSections(result)
result <- result |>
dplyr::filter(.data$diagnostics %in% section_name)
}
if(nrow(result) == 0){
section_name_nice <- stringr::str_replace_all(section_name, "_", " ")
validate(glue::glue("No expectations for {section_name_nice} results."))
}
result
})
output[[output_id]] <- reactable::renderReactable({
filteredExpectations() |>
PhenotypeR::tableCohortExpectations()
})
}
createExpectationsOutput(reactive(input$updateCohortCount), "cohort_count_expectations")
createExpectationsOutput(reactive(input$updateCohortCharacteristics), "cohort_characteristics_expectations")
createExpectationsOutput(reactive(input$updateLSC), "large_scale_characteristics_expectations")
createExpectationsOutput(reactive(input$updateCompareLSC), "compare_large_scale_characteristics_expectations")
createExpectationsOutput(reactive(input$updateCompareCohorts), "compare_cohorts_expectations")
createExpectationsOutput(reactive(input$updateCohortSurvival), "cohort_survival_expectations")
}
Try the PhenotypeR package in your browser
Any scripts or data that you put into this service are public.
PhenotypeR documentation built on March 25, 2026, 5:06 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# Generated by OmopViewer 0.1.0
# Be careful editing this file
server <- function(input, output, session) {
# Shared variables
inputs_initialized <- reactiveVal(FALSE)
shared_cdm_names <- reactiveVal(NULL)
shared_cohort_names <- reactiveVal(NULL)
# fill selectise variables ----
shiny::observe({
for (k in seq_along(choices)) {
if(!grepl("cdm_name|cohort_name", names(choices)[k])){
shiny::updateSelectizeInput(
session,
inputId = names(choices)[k],
choices = choices[[k]],
selected = selected[[k]],
server = TRUE
)
shinyWidgets::updatePickerInput(session,
inputId = names(choices)[k],
choices = choices[[k]],
selected = selected[[k]])
}
}
inputs_initialized(TRUE)
})
# sortable ui elements -----
# have these in server to avoid race condition (if in UI)
output$achilles_sortable <- renderUI({
sortable::bucket_list(
header = NULL,
sortable::add_rank_list(
text = "none",
labels = c("codelist_name"),
input_id = "achilles_code_use_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name", "estimate_name"),
input_id = "achilles_code_use_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = character(),
input_id = "achilles_code_use_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = character(),
input_id = "achilles_code_use_hide"
)
)
})
outputOptions(output, "achilles_sortable", suspendWhenHidden = FALSE)
output$orphan_sortable <- renderUI({
sortable::bucket_list(
header = NULL,
sortable::add_rank_list(
text = "none",
labels = c("variable_name", "cohort_name", "variable_level"),
input_id = "orphan_codes_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name", "estimate_name"),
input_id = "orphan_codes_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = character(),
input_id = "orphan_codes_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = character(),
input_id = "orphan_codes_gt_hide"
)
)
})
outputOptions(output, "orphan_sortable", suspendWhenHidden = FALSE)
output$cohort_code_use_sortable <- renderUI({
sortable::bucket_list(
header = NULL,
sortable::add_rank_list(
text = "none",
labels = c("cohort_name", "codelist_name", "source_concept_name", "source_concept_id", "variable_name", "variable_level"),
input_id = "cohort_code_use_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name", "estimate_name"),
input_id = "cohort_code_use_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = character(),
input_id = "cohort_code_use_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("diagnostic", "phenotyper_version",
"domain_id", "timing"),
input_id = "cohort_code_use_gt_hide"
)
)
})
outputOptions(output, "cohort_code_use_sortable", suspendWhenHidden = FALSE)
output$measurement_value_as_concept_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("variable_level", "estimate_name"),
input_id = "measurement_value_as_concept_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name"),
input_id = "measurement_value_as_concepts_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = c("cohort_name", "codelist_name"),
input_id = "measurement_value_as_concept_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("variable_name"),
input_id = "measurement_value_as_concept_gt_hide"
)
)
})
outputOptions(output, "measurement_value_as_concept_sortable", suspendWhenHidden = FALSE)
output$measurement_value_as_number_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("estimate_name"),
input_id = "measurement_value_as_number_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name"),
input_id = "measurement_value_as_number_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = c("cohort_name", "codelist_name"),
input_id = "measurement_value_as_number_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("variable_name", "variable_level"),
input_id = "measurement_value_as_number_gt_hide"
)
)
})
outputOptions(output, "measurement_value_as_number_sortable", suspendWhenHidden = FALSE)
output$measurement_summary_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("variable_name", "estimate_name"),
input_id = "measurement_summary_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name"),
input_id = "measurement_summary_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = c("cohort_name", "codelist_name"),
input_id = "measurement_summary_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("variable_level"),
input_id = "measurement_summary_gt_hide"
)
)
})
outputOptions(output, "measurement_summary_sortable", suspendWhenHidden = FALSE)
output$drug_diagnostics_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("ingredient_name","variable_name", "estimate_name"),
input_id = "drug_diagnostics_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name"),
input_id = "drug_diagnostics_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = c("cohort_name", "codelist_name"),
input_id = "drug_diagnostics_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("route", "drug_type",
"variable_level",
"ingredient_concept_id"),
input_id = "drug_diagnostics_gt_hide"
)
)
})
outputOptions(output, "drug_diagnostics_sortable", suspendWhenHidden = FALSE)
output$summarise_characteristics_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("variable_name", "variable_level", "estimate_name"),
input_id = "summarise_characteristics_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = c("cdm_name", "cohort_name"),
input_id = "summarise_characteristics_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = NULL,
input_id = "summarise_characteristics_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("diagnostic", "phenotyper_version", "matchedSample"),
input_id = "summarise_characteristics_gt_hide"
)
)
})
outputOptions(output, "summarise_characteristics_sortable", suspendWhenHidden = FALSE)
output$summarise_cohort_overlap_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("cohort_name_reference", "cohort_name_comparator", "estimate_name"),
input_id = "summarise_cohort_overlap_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = "variable_name",
input_id = "summarise_cohort_overlap_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = "cdm_name",
input_id = "summarise_cohort_overlap_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = c("variable_level", "diagnostic", "phenotyper_version", "matchedSample"),
input_id = "summarise_cohort_overlap_gt_hide"
)
)
})
outputOptions(output, "summarise_cohort_overlap_sortable", suspendWhenHidden = FALSE)
output$summarise_cohort_timing_sortable <- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("cohort_name_reference", "cohort_name_comparator", "estimate_name"),
input_id = "summarise_cohort_timing_gt_none"
),
sortable::add_rank_list(
text = "header",
labels = "variable_name",
input_id = "summarise_cohort_timing_gt_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = "cdm_name",
input_id = "summarise_cohort_timing_gt_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = "variable_level",
input_id = "summarise_cohort_timing_gt_hide"
)
)
})
outputOptions(output, "summarise_cohort_timing_sortable", suspendWhenHidden = FALSE)
output$summarise_cohort_survival_sortable<- renderUI({
sortable::bucket_list(
header = "Table formatting",
sortable::add_rank_list(
text = "none",
labels = c("cdm_name", "target_cohort"),
input_id = "survival_table_none"
),
sortable::add_rank_list(
text = "header",
labels = "estimate_name",
input_id = "survival_table_header"
),
sortable::add_rank_list(
text = "groupColumn",
labels = character(),
input_id = "survival_table_groupColumn"
),
sortable::add_rank_list(
text = "hide",
labels = character(),
input_id = "survival_table_hide"
)
)
})
outputOptions(output, "summarise_cohort_survival_sortable", suspendWhenHidden = FALSE)
# Define shared cdm_names values ----
cdm_values <- names(choices)[grepl("cdm_name", names(choices)) & names(choices) != "shared_cdm_names"]
last_active_cdm_input <- reactiveVal(NULL)
for(inputValue in cdm_values){
local({
inputValue_local <- inputValue
shiny::observeEvent(input[[inputValue_local]], {
val <- input[[inputValue_local]]
if (is.null(val) || length(val) == 0 || all(val == "")) {
val <- character(0)
}
if (!identical(val, shared_cdm_names())) {
last_active_cdm_input(inputValue_local)
shared_cdm_names(val)
}
}, ignoreNULL = FALSE)
})
}
shiny::observeEvent(shared_cdm_names(), {
new_shared_val <- shared_cdm_names()
source_input <- isolate(last_active_cdm_input())
for (inputId in cdm_values) {
if (!is.null(source_input) && inputId == source_input) {
next
}
current_val <- isolate(input[[inputId]])
if (is.null(current_val)) current_val <- character(0)
if (!identical(new_shared_val, current_val)) {
shinyWidgets::updatePickerInput(session, inputId, selected = new_shared_val)
}
}
}, ignoreNULL = FALSE, ignoreInit = TRUE)
# Define shared cohort_names values ----
cohort_values <- names(choices)[grepl("cohort_name", names(choices)) & names(choices) != "shared_cohort_names"]
last_active_cohort_input <- reactiveVal(NULL)
for(inputValue in cohort_values){
local({
inputValue_local <- inputValue
shiny::observeEvent(input[[inputValue_local]], {
val <- input[[inputValue_local]]
if (is.null(val) || length(val) == 0 || all(val == "")) {
val <- character(0)
}
if (!identical(val, shared_cohort_names())) {
last_active_cohort_input(inputValue_local) # Log the source!
shared_cohort_names(val)
}
}, ignoreNULL = FALSE)
})
}
shiny::observeEvent(shared_cohort_names(), {
new_shared_val <- shared_cohort_names()
source_input <- isolate(last_active_cohort_input())
for (inputId in cohort_values) {
if (!is.null(source_input) && inputId == source_input) {
next
}
current_val <- isolate(input[[inputId]])
if (is.null(current_val)) { current_val <- character(0) }
if (!identical(new_shared_val, current_val)) {
shinyWidgets::updatePickerInput(session, inputId, selected = new_shared_val)
}
}
}, ignoreNULL = FALSE, ignoreInit = TRUE)
# download raw data -----
output$download_raw <- shiny::downloadHandler(
filename = "results.csv",
content = function(file) {
# Initialize a progress bar
shiny::withProgress(value = 0, {
# Step 1: Importing data
shiny::incProgress(.25, message = "Importing data", detail = "Preparing summarised result...")
rawData <- omopgenerics::importSummarisedResult(file.path(getwd(), "data", "raw"))
# Step 2: Exporting data
shiny::incProgress(.75, message = "Exporting data", detail = "Preparing file for download...")
omopgenerics::exportSummarisedResult(rawData, fileName = file)
})
}
)
# summarise_omop_snapshot -----
filterOmopSnapshot <- eventReactive(input$updateSnapshot, ({
if (is.null(dataFiltered$summarise_omop_snapshot)) {
validate("No snapshot in results")
}
result <- dataFiltered$summarise_omop_snapshot |>
dplyr::filter(cdm_name %in% shared_cdm_names())
attr(result, "settings") <- attr(result, "settings") |>
dplyr::select(!c("diagnostic", "phenotyper_version"))
validateFilteredResult(result)
return(result)
}))
## Table summarise_omop_snapshot ----
createTableOmopSnapshot <- shiny::reactive({
filterOmopSnapshot() |>
OmopSketch::tableOmopSnapshot() |>
tab_header(
title = "Database metadata",
subtitle = "Overview of data source"
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_omop_snapshot_gt <- gt::render_gt({
createTableOmopSnapshot()
})
output$summarise_omop_snapshot_gt_download <- shiny::downloadHandler(
filename = "summarise_omop_snapshot_gt.docx",
content = function(file) {
gt::gtsave(data = createTableOmopSnapshot(), filename = file)
}
)
# summarise_person -----
filterPerson <- eventReactive(input$updatePerson, ({
if (is.null(dataFiltered$summarise_person)) {
validate("No person summary in results")
}
result <- dataFiltered$summarise_person |>
dplyr::filter(cdm_name %in% shared_cdm_names())
attr(result, "settings") <- attr(result, "settings") |>
dplyr::select(!c("diagnostic", "phenotyper_version"))
validateFilteredResult(result)
return(result)
}))
## Table summarise_person -----
createTablePerson <- shiny::reactive({
filterPerson() |>
OmopSketch::tablePerson() |>
tab_header(
title = "Summary of person table",
subtitle = "The person table contains core information on patients captured in the OMOP CDM dataset."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_person_gt <- gt::render_gt({
createTablePerson()
})
output$summarise_person_gt_download <- shiny::downloadHandler(
filename = "summarise_person_gt.docx",
content = function(file) {
obj <- createTablePerson()
gt::gtsave(data = obj, filename = file)
}
)
## Plot date of birth ----
filterPersonDob <- eventReactive(input$updatePerson, ({
if (is.null(dataFiltered$summarise_dob_density)) {
validate("No date of birth summary in results")
}
result <- dataFiltered$summarise_dob_density |>
dplyr::filter(cdm_name %in% shared_cdm_names())
validateFilteredResult(result)
return(result)
}))
output$dobPlot <- renderPlot({
filterPersonDob() |>
visOmopResults::scatterPlot(
x = "density_x",
y = "density_y",
colour = "cdm_name",
line = TRUE,
point = FALSE,
ribbon = FALSE,
ymin = NULL,
ymax = NULL) +
ggplot2::xlab("Date of Birth") +
ggplot2::ylab("Density") +
ggplot2::scale_y_continuous(labels = scales::label_number()) +
visOmopResults::themeVisOmop()
})
# summarise_observation_period -----
filterObservationPeriod <- eventReactive(input$updateObservationPeriod, ({
if (is.null(dataFiltered$summarise_observation_period)) {
validate("No observation period summary in results")
}
result <- dataFiltered$summarise_observation_period |>
dplyr::filter(cdm_name %in% shared_cdm_names())
attr(result, "settings") <- attr(result, "settings") |>
dplyr::select(!c("diagnostic", "phenotyper_version"))
validateFilteredResult(result)
return(result)
}))
## Table summarise_observation_period -----
createTableObservationPeriod <- shiny::reactive({
filterObservationPeriod() |>
OmopSketch::tableObservationPeriod() |>
tab_header(
title = "Summary of observation periods",
subtitle = "Observation periods are used to define time under observation for individuals in the data source."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_observation_period_gt <- gt::render_gt({
createTableObservationPeriod()
})
output$summarise_observation_period_gt_download <- shiny::downloadHandler(
filename = "summarise_observation_period_gt.docx",
content = function(file) {
obj <- createTableObservationPeriod()
gt::gtsave(data = obj, filename = file)
}
)
## Plot obs start end ----
filterObs <- eventReactive(input$updateObservationPeriod, ({
if (is.null(dataFiltered$summarise_obs_density)) {
validate("No date of observation period distributions in results")
}
result <- dataFiltered$summarise_obs_density |>
dplyr::filter(cdm_name %in% shared_cdm_names())
validateFilteredResult(result)
return(result)
}))
output$obsPlot <- renderPlot({
filterObs() |>
dplyr::mutate(variable_name =
dplyr::if_else(variable_name == "observation_period_start_date",
"observation period start date",
"observation period end date")) |>
dplyr::mutate(variable_name = factor(variable_name,
levels = c("observation period start date",
"observation period end date"))) |>
visOmopResults::scatterPlot(
x = "density_x",
y = "density_y",
group = "variable_name",
facet = "variable_name",
colour = "cdm_name",
line = TRUE,
point = FALSE,
ribbon = FALSE,
ymin = NULL,
ymax = NULL) +
ggplot2::xlab("Date") +
ggplot2::ylab("Density") +
ggplot2::scale_y_continuous(labels = scales::label_number()) +
ggplot2::facet_wrap(vars(variable_name),
ncol = 1, scales = "free_y")
})
# summarise_clinical_records ----
filterClinicalRecords <- eventReactive(input$updateClinicalRecords, ({
if (is.null(dataFiltered$summarise_clinical_records)) {
validate("No clinical records summary in results")
}
result <- dataFiltered$summarise_clinical_records |>
dplyr::filter(cdm_name %in% shared_cdm_names(),
group_level %in% input$summarise_clinical_records_omop_table)
attr(result, "settings") <- attr(result, "settings") |>
dplyr::select(!c("diagnostic", "phenotyper_version"))
validateFilteredResult(result)
return(result)
}))
## Table summarise_clinical_records -----
createClinicalRecordsTable <- shiny::reactive({
filterClinicalRecords() |>
OmopSketch::tableClinicalRecords() |>
tab_header(
title = "Summary of Clinical Records",
subtitle = "Summary of the clinical tables that contain the codes from the cohort codelist."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_clinical_records_gt <- gt::render_gt({
createClinicalRecordsTable()
})
output$summarise_clinical_records_gt_download <- shiny::downloadHandler(
filename = "summarise_clinical_records_gt.docx",
content = function(file) {
obj <- createClinicalRecordsTable()
gt::gtsave(data = obj, filename = file)
}
)
## Plot clinical record trends -----
filterClinicalRecordTrends <- eventReactive(input$updateClinicalRecords, ({
if (is.null(dataFiltered$summarise_trend)) {
validate("No clinical records summary in results")
}
result <- dataFiltered$summarise_trend |>
dplyr::filter(cdm_name %in% shared_cdm_names(),
group_level %in% input$summarise_clinical_records_omop_table)
validateFilteredResult(result)
return(result)
}))
output$clinicalTrends <- renderPlot({
plot <- filterClinicalRecordTrends() |>
OmopSketch::plotTrend(style = "default",
colour = input$clinical_records_plot_colour,
facet = input$clinical_records_plot_facet)
if(!is.null(input$clinical_records_plot_facet) &&
isTRUE(input$clinical_records_plot_facet_free)){
plot <- plot +
facet_wrap(facets = input$clinical_records_plot_facet,
scales = "free_y")
}
plot
})
# achilles_code_use -----
filterAchillesCodeUse <- eventReactive(input$updateAchillesCodeUse, ({
req(shared_cdm_names())
req(inputs_initialized())
if (is.null(dataFiltered$achilles_code_use)) {
validate("No achilles code use in results")
}
achillesFiltered <- dataFiltered$achilles_code_use |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% input$achilles_code_use_codelist_name)
if(isFALSE(input$achilles_person_count)){
achillesFiltered <- achillesFiltered |>
filter(estimate_name != "person_count")
}
if(isFALSE(input$achilles_record_count)){
achillesFiltered <- achillesFiltered |>
filter(estimate_name != "record_count")
}
validateFilteredResult(achillesFiltered)
return(achillesFiltered)
}))
## Table achilles_code_use ----
createAchillesCodeUseGT <- shiny::reactive({
tbl <- CodelistGenerator::tableAchillesCodeUse(filterAchillesCodeUse(),
header = input$achilles_code_use_header,
groupColumn = input$achilles_code_use_groupColumn,
hide = input$achilles_code_use_hide) |>
tab_header(
title = "Summary of achilles codes",
subtitle = "Codes from codelist observed in achilles tables."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
createAchillesCodeUseInteractive <- shiny::reactive({
tbl <- CodelistGenerator::tableAchillesCodeUse(filterAchillesCodeUse(),
header = input$achilles_code_use_header,
groupColumn = input$achilles_code_use_groupColumn,
hide = input$achilles_code_use_hide,
type = "tibble")
names(tbl) <- stringr::str_remove_all(names(tbl),
"\\[header_name\\]Database name\\n\\[header_level\\]")
names(tbl) <- stringr::str_remove_all(names(tbl),
"Estimate name\n\\[header_level\\]")
names(tbl) <- stringr::str_replace_all(names(tbl),
"\n\\[header_name\\]",
": ")
return(tbl)
})
output$achilles_code_use_tbl <- shiny::renderUI({
if(isFALSE(input$achilles_interactive)){
tbl <- createAchillesCodeUseGT()
return(tbl)
} else {
tbl <- createAchillesCodeUseInteractive()
# column ordering by codelist and first column with a count
order <- list("Codelist name" = "asc",
"count" = "desc")
names(order)[2] <- names(tbl)[9]
# suppressed to NA
tbl <- tbl |>
purrr::map_df(~ ifelse(grepl("^<", .), NA, .)) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ gsub(",", "", .))) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ suppressWarnings(as.numeric(.))))
tbl <- reactable::reactable(tbl,
defaultSorted = order,
groupBy = c("Codelist name"),
columns = getColsForTbl(tbl),
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Summary of achilles codes",
font_size = 25,
font_weight = "normal") |>
reactablefmtr_add_subtitle("Codes from codelist observed in achilles tables.",
font_size = 15,
font_weight = "normal")
return(tbl)
}
})
output$achilles_code_use_download <- shiny::downloadHandler(
filename = function(){
if(isFALSE(input$achilles_interactive)){
"summarise_achilles_code_use_gt.docx"
}else{
"summarise_achilles_code_use_tbl.csv"
}
},
content = function(file){
if(isFALSE(input$achilles_interactive)){
gt::gtsave(data = createAchillesCodeUseGT(), filename = file)
}else{
readr::write_csv(createAchillesCodeUseInteractive(), file = file)
}
}
)
# orphan_codes -----
filterOrphanCodes <- eventReactive(input$updateOrphanCodeUse, ({
req(shared_cdm_names())
req(inputs_initialized())
if (is.null(dataFiltered$orphan_code_use)) {
validate("No orphan codes in results")
}
result <- dataFiltered$orphan_code_use |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% input$orphan_code_use_codelist_name)
if(isFALSE(input$orphan_person_count)){
result <- result |>
filter(estimate_name != "person_count")
}
if(isFALSE(input$orphan_record_count)){
result <- result |>
filter(estimate_name != "record_count")
}
validateFilteredResult(result)
return(result)
}))
## Table orphan_codes -----
createOrphanCodesGT <- shiny::reactive({
tbl <- CodelistGenerator::tableOrphanCodes(
filterOrphanCodes(),
header = input$orphan_codes_gt_header,
groupColumn = input$orphan_codes_gt_groupColumn,
hide = input$orphan_codes_gt_hide
)
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"
)
return(tbl)
})
createOrphanCodesInteractive <- shiny::reactive({
tbl <- CodelistGenerator::tableOrphanCodes(
filterOrphanCodes(),
header = input$orphan_codes_gt_header,
groupColumn = input$orphan_codes_gt_groupColumn,
hide = input$orphan_codes_gt_hide,
type = "tibble"
)
names(tbl) <-stringr::str_remove_all(names(tbl),
"\\[header_name\\]Database name\\n\\[header_level\\]")
names(tbl) <- stringr::str_remove_all(names(tbl),
"Estimate name\n\\[header_level\\]")
names(tbl) <- stringr::str_replace_all(names(tbl),
"\n\\[header_name\\]",
": ")
return(tbl)
})
output$orphan_codes_tbl <- shiny::renderUI({
if(isFALSE(input$orphan_interactive)){
tbl <- createOrphanCodesGT()
return(tbl)
} else {
tbl <- createOrphanCodesInteractive()
# column ordering by codelist and first column with a count
order <- list("Codelist name" = "asc",
"count" = "desc")
names(order)[2] <- names(tbl)[11]
# suppressed to NA
tbl <- tbl |>
purrr::map_df(~ ifelse(grepl("^<", .), NA, .)) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ gsub(",", "", .))) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ suppressWarnings(as.numeric(.))))
tbl <- reactable(tbl,
groupBy = c("Codelist name"),
columns = getColsForTbl(tbl),
defaultSorted = order,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Summary of orphan codes",
font_size = 25,
font_weight = "normal") |>
reactablefmtr_add_subtitle("Orphan codes refer to concepts present in the database that are not in a codelist but are related to included codes.",
font_size = 15,
font_weight = "normal")
return(tbl)
}
})
output$orphan_codes_download <- shiny::downloadHandler(
filename = function(){
if(isFALSE(input$orphan_interactive)){
"summarise_orphan_codes_gt.docx"
}else{
"summarise_orphan_codes_tbl.csv"
}
},
content = function(file){
if(isFALSE(input$orphan_interactive)){
gt::gtsave(data = createOrphanCodesGT(), filename = file)
}else{
readr::write_csv(createOrphanCodesInteractive(), file = file)
}
}
)
# cohort_code_use -----
filterCohortCodeUse <- eventReactive(input$updateCohortCodeUse, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$cohort_code_use)) {
validate("No cohort code use in results")
}
result <- dataFiltered$cohort_code_use |>
visOmopResults::splitGroup(keep = TRUE) |>
visOmopResults::splitAdditional(keep = TRUE) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$cohort_name %in% shared_cohort_names(),
.data$domain_id %in% input$cohort_code_use_domain_id) |>
dplyr::select(-visOmopResults::groupColumns(dataFiltered$cohort_code_use)) |>
dplyr::select(-visOmopResults::additionalColumns(dataFiltered$cohort_code_use))
if(isFALSE(input$cohort_code_use_person_count)){
result <- result |>
filter(estimate_name != "person_count")
}
if(isFALSE(input$cohort_code_use_record_count)){
result <- result |>
filter(estimate_name != "record_count")
}
validateFilteredResult(result)
return(result)
}))
## Table cohort_code_use -----
createCohortCodeUseGT <- shiny::reactive({
tbl <- CodelistGenerator::tableCohortCodeUse(
filterCohortCodeUse(),
header = input$cohort_code_use_gt_header,
groupColumn = input$cohort_code_use_gt_groupColumn,
hide = input$cohort_code_use_gt_hide
) |>
tab_header(
title = "Summary of cohort code use",
subtitle = "Codes from codelist observed on day of cohort entry. Note more than one code could be seen for a person on this day (both of which would have led to inclusion)."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
createCohortCodeUseInteractive <- shiny::reactive({
tbl <- CodelistGenerator::tableCohortCodeUse(
filterCohortCodeUse(),
header = input$cohort_code_use_gt_header,
groupColumn = input$cohort_code_use_gt_groupColumn,
hide = input$cohort_code_use_gt_hide,
type = "tibble"
)
names(tbl) <-stringr::str_remove_all(names(tbl),
"\\[header_name\\]Database name\\n\\[header_level\\]")
names(tbl) <- stringr::str_remove_all(names(tbl),
"Estimate name\n\\[header_level\\]")
names(tbl) <- stringr::str_replace_all(names(tbl),
"\n\\[header_name\\]",
": ")
return(tbl)
})
output$cohort_code_use_tbl <- shiny::renderUI({
if(isFALSE(input$cohort_code_use_interactive)){
tbl <- createCohortCodeUseGT()
return(tbl)
} else {
tbl <- createCohortCodeUseInteractive() |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ gsub(",", "", .))) |>
dplyr::mutate(dplyr::across(c(ends_with("count")),
~ suppressWarnings(as.numeric(.))))
tbl <- tbl |>
dplyr::mutate("Cohort name - Codelist name" =
paste0(.data[["Cohort name"]], " - ", .data[["Codelist name"]])) |>
dplyr::select(-c("Cohort name", "Codelist name")) |>
dplyr::relocate("Cohort name - Codelist name")
# column ordering by codelist and first column with a count
order <- list("Cohort name - Codelist name" = "asc",
"count" = "desc")
names(order)[2] <- names(tbl)[11]
# suppressed to NA
tbl <- tbl |>
purrr::map_df(~ ifelse(grepl("^<", .), NA, .))
tbl <- reactable(tbl,
groupBy = c("Cohort name - Codelist name"),
columns = getColsForTbl(tbl,
sortNALast = FALSE,
names = c("Standard concept ID", "Source concept ID")),
defaultSorted = order,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Summary of cohort code use",
font_size = 25,
font_weight = "normal") |>
reactablefmtr_add_subtitle("Codes from codelist observed on day of cohort entry. Note more than one code could be seen for a person on this day (both of which would have led to inclusion).",
font_size = 15,
font_weight = "normal")
return(tbl)
}
})
output$cohort_code_use_download <- shiny::downloadHandler(
filename = function(){
if(isFALSE(input$cohort_code_use_interactive)){
file <- "summarise_cohort_code_use_gt.docx"
}else{
file <- "summarise_cohort_code_use_tbl.csv"
}
return(file)
},
content = function(file){
if(isFALSE(input$cohort_code_use_interactive)){
gt::gtsave(data = createCohortCodeUseGT(), filename = file)
}else{
readr::write_csv(createCohortCodeUseInteractive(), file = file)
}
}
)
# summarise measurement diagnostics -----
filterMeasurementSummary <- eventReactive(input$updateMeasurementCodeUse, ({
req(shared_cdm_names())
req(shared_cohort_names())
if (is.null(dataFiltered$measurement_summary)) {
validate("No measurement summary in results")
}
result <- dataFiltered$measurement_summary |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$cohort_name %in% shared_cohort_names())
validateFilteredResult(result)
return(result)
}))
## Table measurement_summary -----
createMeasurementSummaryGT <- shiny::reactive({
tbl <- MeasurementDiagnostics::tableMeasurementSummary(
filterMeasurementSummary(),
header = input$measurement_summary_gt_header,
groupColumn = input$measurement_summary_gt_groupColumn,
hide = input$measurement_summary_gt_hide
) |>
tab_header(
title = "Summary of measurements",
subtitle = "Only codes from measurements/observations are shown. Time between measurements and number of measurements per subject."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
output$measurement_summary_tbl <- shiny::renderUI({
createMeasurementSummaryGT()
})
output$measurement_summary_gt_download <- shiny::downloadHandler(
filename = "summarise_measurement_summary_gt.docx",
content = function(file){
gt::gtsave(data = createMeasurementSummaryGT(), filename = file)
}
)
## Plot measurement_summary ----
getPlotMeasurementSummary <- shiny::reactive({
result <- filterMeasurementSummary()
MeasurementDiagnostics::plotMeasurementSummary(
result,
y = input$measurement_summary_y,
plotType = input$measurement_summary_plottype,
timeScale = input$measurement_summary_time_scale,
facet = input$measurement_summary_facet,
colour = input$measurement_summary_colour)
})
output$plot_measurement_summary <- shiny::renderPlot({
getPlotMeasurementSummary()
})
output$plot_measurement_summary_download <- shiny::downloadHandler(
filename = "output_ggplot2_measurement_summary.png",
content = function(file) {
obj <- getPlotMeasurementSummary()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$plot_measurement_summary_download_width),
height = as.numeric(input$plot_measurement_summary_download_height),
units = input$plot_measurement_summary_download_units,
dpi = as.numeric(input$plot_measurement_summary_download_dpi)
)
}
)
# summarise measurement value as concept
filterMeasurementValueAsConcept <- eventReactive(input$updateMeasurementCodeUse, ({
if (is.null(dataFiltered$measurement_value_as_concept)) {
validate("No measurement value as concept in results")
}
result <- dataFiltered$measurement_value_as_concept |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$cohort_name %in% shared_cohort_names())
validateFilteredResult(result)
return(result)
}))
## Table measurement_value_as_concept -----
createMeasurementValueAsConceptGT <- shiny::reactive({
tbl <- MeasurementDiagnostics::tableMeasurementValueAsConcept(
filterMeasurementValueAsConcept(),
header = input$measurement_value_as_concept_gt_header,
groupColumn = input$measurement_value_as_concept_gt_groupColumn,
hide = input$measurement_value_as_concept_gt_hide
) |>
tab_header(
title = "Summary of measurement values (concepts)",
subtitle = "Only codes from measurements that are concepts are shown."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
output$measurement_value_as_concept_tbl <- shiny::renderUI({
createMeasurementValueAsConceptGT()
})
output$measurement_value_as_concept_gt_download <- shiny::downloadHandler(
filename = "summarise_measurement_value_as_concept_gt.docx",
content = function(file){
gt::gtsave(data = createMeasurementValueAsConceptGT(), filename = file)
}
)
## Plot measurement_value_as_concept ----
getPlotMeasurementValueAsConcept <- shiny::reactive({
result <- filterMeasurementValueAsConcept()
MeasurementDiagnostics::plotMeasurementValueAsConcept(
result,
x = input$measurement_value_as_concept_x,
y = input$measurement_value_as_concept_y,
facet = input$measurement_value_as_concept_facet,
colour = input$measurement_value_as_concept_colour
) +
facet_wrap(input$measurement_value_as_concept_facet, scales = "free_y")
})
output$plot_measurement_value_as_concept <- shiny::renderPlot({
getPlotMeasurementValueAsConcept()
})
output$plot_measurement_value_as_concept_download <- shiny::downloadHandler(
filename = "output_ggplot2_measurement_value_as_concept.png",
content = function(file) {
obj <- getPlotMeasurementValueAsConcept()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$plot_measurement_value_as_concept_download_width),
height = as.numeric(input$plot_measurement_value_as_concept_download_height),
units = input$plot_measurement_value_as_concept_download_units,
dpi = as.numeric(input$plot_measurement_value_as_concept_download_dpi)
)
}
)
# summarise measurement value as number
filterMeasurementValueAsNumber <- eventReactive(input$updateMeasurementCodeUse, ({
if (is.null(dataFiltered$measurement_value_as_number)) {
validate("No measurement value as number in results")
}
result <- dataFiltered$measurement_value_as_number |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$cohort_name %in% shared_cohort_names())
validateFilteredResult(result)
return(result)
}))
## Table measurement_value_as_number -----
createMeasurementValueAsNumberGT <- shiny::reactive({
tbl <- MeasurementDiagnostics::tableMeasurementValueAsNumber(
filterMeasurementValueAsNumber(),
header = input$measurement_value_as_number_gt_header,
groupColumn = input$measurement_value_as_number_gt_groupColumn,
hide = input$measurement_value_as_number_gt_hide
) |>
tab_header(
title = "Summary of measurement values (numeric)",
subtitle = "Only codes from measurements which results are numeric are shown."
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
output$measurement_value_as_number_tbl <- shiny::renderUI({
createMeasurementValueAsNumberGT()
})
output$measurement_value_as_number_gt_download <- shiny::downloadHandler(
filename = "summarise_measurement_value_as_number_gt.docx",
content = function(file){
gt::gtsave(data = createMeasurementValueAsNumberGT(), filename = file)
}
)
## Plot measurement_value_as_number ----
getPlotMeasurementValueAsNumber <- shiny::reactive({
result <- filterMeasurementValueAsNumber()
MeasurementDiagnostics::plotMeasurementValueAsNumber(
result,
x = input$measurement_value_as_number_x,
plotType = input$measurement_value_as_number_plottype,
facet = input$measurement_value_as_number_facet,
colour = input$measurement_value_as_number_colour
)
})
output$plot_measurement_value_as_number <- shiny::renderPlot({
getPlotMeasurementValueAsNumber()
})
output$plot_measurement_value_as_number_download <- shiny::downloadHandler(
filename = "output_ggplot2_measurement_value_as_number.png",
content = function(file) {
obj <- getPlotMeasurementValueAsNumber()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$plot_measurement_value_as_number_download_width),
height = as.numeric(input$plot_measurement_value_as_number_download_height),
units = input$plot_measurement_value_as_number_download_units,
dpi = as.numeric(input$plot_measurement_value_as_number_download_dpi)
)
}
)
# summarise drug diagnostics -----
filterDrugDiagnostics<- eventReactive(input$updateDrugDiagnostics, ({
req(shared_cdm_names())
req(shared_cohort_names())
if (is.null(dataFiltered$summarise_drug_use)) {
validate("No drug diagnostics in results")
}
result <- dataFiltered$summarise_drug_use |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$cohort_name %in%
shared_cohort_names()) |>
omopgenerics::filterGroup(.data$codelist_name %in%
input$summarise_drug_use_codelist_name) |>
omopgenerics::filterGroup(.data$route %in%
input$summarise_drug_use_route) |>
omopgenerics::filterGroup(.data$drug_type %in%
input$summarise_drug_use_drug_type)
if(isFALSE(input$drug_use_overall)){
result <- result |>
dplyr::filter(str_detect(group_name, "concept_name"))
}
if(isFALSE(input$drug_use_by_concept)){
result <- result |>
dplyr::filter(str_detect(group_name, "concept_name", negate = TRUE))
}
validateFilteredResult(result)
return(result)
}))
## Table drug diagnostics -----
createDrugDiagnosticsGT <- shiny::reactive({
res <- filterDrugDiagnostics()
tbl <- res |>
dplyr::arrange(group_name, group_level) |>
visOmopResults::visOmopTable(header = input$drug_diagnostics_gt_header,
groupColumn = input$drug_diagnostics_gt_groupColumn,
estimateName = c(N = "<count>",
`Median [Q01, Q05, Q25 to Q75, Q95, Q99]` = "<median> [<q01>, <q05>, <q25> to <q75>, <q95>, <q99>]",
Range = "<min> to <max>",
`Percentage missing` = "<percentage_missing> %"),
hide = input$drug_diagnostics_gt_hide ) |>
tab_header(
title = "Drug exposure diagnostics"
) |>
tab_options(
heading.align = "left"
)
return(tbl)
})
createDrugDiagnosticsInteractive <- shiny::reactive({
res <- filterDrugDiagnostics()
tbl <- res |>
dplyr::arrange(group_name, group_level) |>
visOmopResults::visOmopTable(header = input$drug_diagnostics_gt_header,
groupColumn = input$drug_diagnostics_gt_groupColumn,
estimateName = c(N = "<count>",
`Median [Q01, Q05, Q25 to Q75, Q95, Q99]` = "<median> [<q01>, <q05>, <q25> to <q75>, <q95>, <q99>]",
Range = "<min> to <max>",
`Percentage missing` = "<percentage_missing> %"),
hide = input$drug_diagnostics_gt_hide,
type = "tibble")
names(tbl) <-stringr::str_remove_all(names(tbl),
"\\[header_name\\]CDM name\\n\\[header_level\\]")
names(tbl) <- stringr::str_remove_all(names(tbl),
"Estimate name\n\\[header_level\\]")
names(tbl) <- stringr::str_replace_all(names(tbl),
"\n\\[header_name\\]",
": ")
return(tbl)
})
output$drug_diagnostics_tbl <- shiny::renderUI({
if(isFALSE(input$drug_diagnostics_interactive)){
tbl <- createDrugDiagnosticsGT()
return(tbl)
} else {
tbl <- createDrugDiagnosticsInteractive()
tbl <- tbl |>
dplyr::mutate("Cohort name - Codelist name" =
paste0(.data[["Cohort name"]], " - ", .data[["Codelist name"]])) |>
dplyr::select(-c("Cohort name", "Codelist name")) |>
dplyr::relocate("Cohort name - Codelist name")
# column ordering by codelist and first column with a count
order <- list("Cohort name - Codelist name" = "asc")
tbl <- reactable(tbl,
groupBy = c("Cohort name - Codelist name"),
columns = getColsForTbl(tbl,
sortNALast = FALSE,
names = c("Standard concept ID", "Source concept ID")),
defaultSorted = order,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Drug diagnostics",
font_size = 25,
font_weight = "normal")
}
tbl
})
output$drug_diagnostics_gt_download <- shiny::downloadHandler(
filename = "summarise_drug_diagnostics_gt.docx",
content = function(file){
gt::gtsave(data = createDrugDiagnosticsGT(), filename = file)
}
)
# summarise_cohort_count -----
filterCohortCount <- eventReactive(input$updateCohortCount, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_cohort_count)) {
validate("No cohort count in results")
}
result <- dataFiltered$summarise_cohort_count |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% shared_cohort_names())
if(isFALSE(input$cohort_count_person_count)){
result <- result |>
dplyr::filter(.data$variable_name != "Number subjects")
}
if(isFALSE(input$cohort_count_record_count)){
result <- result |>
dplyr::filter(.data$variable_name != "Number records")
}
validateFilteredResult(result)
return(result)
}))
## Table summarise_cohort_count ----
createTableCohortCount <- shiny::reactive({
res <- filterCohortCount()
CohortCharacteristics::tableCohortCount(res,
hide = c("variable_level",
"estimate_name",
settingsColumns(res))) |>
tab_header(
title = "Cohort count",
subtitle = "Number of records and subjects in the study cohorts."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_cohort_count_gt <- gt::render_gt({
createTableCohortCount()
})
output$summarise_cohort_count_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_count_gt.docx",
content = function(file) {
obj <- createTableCohortCount()
gt::gtsave(data = obj, filename = file)
}
)
# summarise_cohort_attrition -----
filterCohortAttrition <- eventReactive(input$updateCohortCount,({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_cohort_attrition)) {
validate("No cohort attrition in results")
}
result <- dataFiltered$summarise_cohort_attrition |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% shared_cohort_names())
if(isFALSE(input$cohort_count_person_count)){
result <- result |>
dplyr::filter(!stringr::str_detect(.data$variable_name, "subjects"))
}
if(isFALSE(input$cohort_count_record_count)){
result <- result |>
dplyr::filter(!stringr::str_detect(.data$variable_name, "records"))
}
validateFilteredResult(result)
return(result)
}))
## Table summarise_cohort_attrition ----
createTableCohortAttrition <- shiny::reactive({
filterCohortAttrition() |>
CohortCharacteristics::tableCohortAttrition() |>
tab_header(
title = "Cohort attrition",
subtitle = "Attrition of the study cohorts."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_cohort_attrition_gt <- gt::render_gt({
createTableCohortAttrition()
})
output$summarise_cohort_attrition_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_attrition_gt.docx",
content = function(file) {
obj <- createTableCohortAttrition()
gt::gtsave(data = obj, filename = file)
}
)
## Diagram summarise_cohort_attrition -----
createDiagramCohortAttrition <- shiny::reactive({
result <- filterCohortAttrition()
n <- result |>
select(cdm_name, group_level) |>
distinct() |>
nrow()
CohortCharacteristics::plotCohortAttrition(
result
)
})
output$summarise_cohort_attrition_grViz <- DiagrammeR::renderGrViz({
createDiagramCohortAttrition()
})
output$summarise_cohort_attrition_grViz_download <- shiny::downloadHandler(
filename = "summarise_cohort_attrition_diagram.png",
content = function(file) {
createDiagramCohortAttrition() |>
DiagrammeRsvg::export_svg() |>
charToRaw() |>
rsvg::rsvg_png(file,
width = input$summarise_cohort_attrition_grViz_download_width,
height = input$summarise_cohort_attrition_grViz_download_height)
}
)
# summarise_characteristics -----
filterSummariseCharacteristics <- eventReactive(input$updateCohortCharacteristics, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_characteristics)) {
validate("No cohort characteristics in results")
}
selectedCohorts <- shared_cohort_names()
if(isTRUE(input$summarise_characteristics_include_matched)){
selectedCohorts <- as.vector(t(outer(selectedCohorts, c("", "_sampled", "_matched"), paste0)))
}
result <- dataFiltered$summarise_characteristics |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% selectedCohorts) |>
dplyr::mutate(group_level = factor(group_level, levels = selectedCohorts)) |>
arrange(group_level)
validateFilteredResult(result)
return(result)
}))
## Table summarise_characteristics -----
createTableSummariseCharacteristics <- shiny::reactive({
filterSummariseCharacteristics() |>
CohortCharacteristics::tableCharacteristics(
header = input$summarise_characteristics_gt_header,
groupColumn = input$summarise_characteristics_gt_groupColumn,
hide = c(input$summarise_characteristics_gt_hide,
"table_name", "value", "window", "table",
"diagnostic", "cohort_sample", "matched_sample", "phenotyper_version")
) |>
tab_header(
title = "Patient characteristics",
subtitle = "Summary of patient characteristics relative to cohort entry. Please be aware that statistics are calculated by record, not by subject."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_characteristics_gt <- gt::render_gt({
createTableSummariseCharacteristics()
})
output$summarise_characteristics_gt_download <- shiny::downloadHandler(
filename = "summarise_characteristics_gt.docx",
content = function(file) {
obj <- createTableSummariseCharacteristics()
gt::gtsave(data = obj, filename = file)
}
)
## Plot age_pyramid ----
createAgePyramid <- eventReactive(input$updateCohortCharacteristics, ({
summarise_characteristics <- filterSummariseCharacteristics()
summarise_table <- dataFiltered$summarise_table |>
filter(cdm_name %in% shared_cdm_names())
selectedCohorts <- shared_cohort_names()
if(isTRUE(input$summarise_characteristics_include_matched)){
selectedCohorts <- as.vector(t(outer(selectedCohorts, c("", "_sampled", "_matched"), paste0)))
}
summarise_table <- summarise_table |>
dplyr::filter(.data$group_level %in% selectedCohorts) |>
dplyr::mutate(group_level = factor(group_level, levels = selectedCohorts)) |>
arrange(group_level)
if (nrow(summarise_table) == 0 || nrow(summarise_characteristics) == 0 ) {
validate("No results found for selected inputs")
}
if (nrow(summarise_table) == 0 || nrow(summarise_characteristics) == 0 ) {
validate("No results found for selected inputs")
}
plotAgeDensity(summarise_table, summarise_characteristics, input$summarise_characteristics_add_interquantile_range)
}))
output$plot_age_pyramid <- shiny::renderPlot({
createAgePyramid()
})
output$plot_age_pyramid_download <- shiny::downloadHandler(
filename = "age_pyramid_plot.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)
)
}
)
# summarise_large_scale_characteristics -----
filterLargeScaleCharacteristics <- eventReactive(input$updateLSC, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
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 != "-") |>
visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_table_name,
analysis %in% input$summarise_large_scale_characteristics_analysis) |>
dplyr::filter(cdm_name %in% shared_cdm_names()) |>
dplyr::filter(group_level %in% shared_cohort_names()) |>
dplyr::filter(variable_level %in% input$summarise_large_scale_characteristics_variable_level)
validateFilteredResult(lsc_data)
return(lsc_data)
}))
## Table summarise_characteristics -----
tidyLargeScaleCharacteristics <- shiny::reactive({
tidy_lsc <- filterLargeScaleCharacteristics()
tidy_lsc <- tidy_lsc |>
tidy() |>
mutate(concept = paste0(variable_name, " (",
concept_id, ")"))
if("source_concept_id" %in% colnames(tidy_lsc)){
tidy_lsc <- tidy_lsc |>
mutate(source_concept = paste0(source_concept_name, " (",
source_concept_id, ")"))
}
tidy_lsc <- tidy_lsc |>
dplyr::select(dplyr::any_of(c("cdm_name",
"cohort_name",
"concept",
"source_concept",
"time_window" = "variable_level",
"count",
"percentage")))
return(tidy_lsc)
})
## Table summarise_large_scale_characteristics -----
output$summarise_large_scale_characteristics_tidy <- shiny::renderUI({
tbl_data <- tidyLargeScaleCharacteristics()
if("source_concept" %in% colnames(tbl_data)){
tbl_data <- tbl_data |>
rename("CDM name" = "cdm_name",
"Cohort" = "cohort_name",
"Time window" = "time_window",
"Concept name (concept ID)" = "concept",
"Source concept name (concept ID)" = "source_concept")
cols <- list("Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
"Source concept name (concept ID)" = colDef(name = "Source concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
count = colDef(format = colFormat(separators = TRUE)),
percentage = colDef(format = colFormat(percent = TRUE))
)
} else {
tbl_data <- tbl_data |>
rename("CDM name" = "cdm_name",
"Cohort" = "cohort_name",
"Time window" = "time_window",
"Concept name (concept ID)" = "concept")
cols <- list("Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
count = colDef(format = colFormat(separators = TRUE)),
percentage = colDef(format = colFormat(percent = TRUE))
)
}
reactable(tbl_data |>
mutate(percentage = percentage / 100), # to use colFormat
defaultSorted = list("percentage" = "desc"),
columns = cols,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE) |>
reactablefmtr_add_title("Large scale characteristics",
font_size = 25,
font_weight = "normal") |>
reactablefmtr_add_subtitle("Summary of all records from clinical tables within a time window. The sampled cohort represents individuals from the original cohort, the matched cohort comprises individuals of similar age and sex from the database.",
font_size = 15,
font_weight = "normal")
})
output$summarise_large_scale_characteristics_tidy_download <- shiny::downloadHandler(
filename = "summarise_large_scale_characteristics_tidy.csv",
content = function(file) {
tidyLargeScaleCharacteristics() |>
readr::write_csv(file = file)
}
)
## Table summarise_large_scale_characteristics -----
createTableLargeScaleCharacteristics <- shiny::reactive({
lsc_data <- filterLargeScaleCharacteristics()
lsc_data |>
CohortCharacteristics::tableTopLargeScaleCharacteristics(
topConcepts = input$summarise_large_scale_characteristics_top_concepts) |>
tab_header(
title = "Top concepts in large scale characteristics",
subtitle = "Summary of the most prevalent concepts by percentage across each cohort."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_large_scale_characteristics_gt <- gt::render_gt({
createTableLargeScaleCharacteristics()
})
output$summarise_large_scale_characteristics_gt_download <- shiny::downloadHandler(
filename = "summarise_large_scale_characteristics_gt.docx",
content = function(file) {
obj <- createTableLargeScaleCharacteristics()
gt::gtsave(data = obj, filename = file)
}
)
# compare large_scale_characteristics ----
getComparedCohorts <- eventReactive(input$updateCompareLSC, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
cohort <- shared_cohort_names()
if(length(cohort) > 1){
validate("Please select only one cohort")
}
if(length(cohort) == 0){
validate("Please select a cohort")
}
cohort1 <- switch(input$compare_large_scale_characteristics_cohort_1,
"original" = cohort,
"sampled" = paste0(cohort,"_sampled"),
"matched" = paste0(cohort,"_matched"))
cohort2 <- switch(input$compare_large_scale_characteristics_cohort_2,
"original" = input$compare_large_scale_characteristics_cohort_compare,
"sampled" = paste0(input$compare_large_scale_characteristics_cohort_compare,"_sampled"),
"matched" = paste0(input$compare_large_scale_characteristics_cohort_compare,"_matched"))
return(list("cohort1" = cohort1,
"cohort2" = cohort2))
}))
filterCompareLargeScaleCharacteristics <- shiny::reactive({
shiny::observeEvent(shared_cdm_names(), {
updatePickerInput(session, "compare_large_scale_characteristics_cdm_name", selected = shared_cdm_names())
})
shiny::observeEvent(shared_cohort_names(), {
updatePickerInput(session, "compare_large_scale_characteristics_cohort_name", selected = shared_cohort_names())
})
if (is.null(dataFiltered$summarise_large_scale_characteristics)) {
validate("No large scale characteristics in results")
}
cohorts <- getComparedCohorts()
cohort1 <- cohorts$cohort1
cohort2 <- cohorts$cohort2
lsc_filtered <- dataFiltered$summarise_large_scale_characteristics |>
visOmopResults::filterSettings(.data$table_name %in% input$compare_large_scale_characteristics_table_name,
.data$analysis %in% input$compare_large_scale_characteristics_analysis) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$group_level %in% c(cohort1, cohort2),
.data$variable_level %in% input$compare_large_scale_characteristics_variable_level)
validateFilteredResult(lsc_filtered)
return(lsc_filtered)
})
## Tidy compare large_scale_characteristics ----
createTidyDataCompareLargeScaleCharacteristics <- shiny::reactive({
lscFiltered <- filterCompareLargeScaleCharacteristics()
cohorts <- getComparedCohorts()
target_cohort <- cohorts$cohort1
comparator_cohort <- cohorts$cohort2
if("matchedSample" %in% (lscFiltered |> omopgenerics::settings() |> colnames())){
msg <- paste0("Matched cohort was created based on a subsample of ", omopgenerics::settings(lscFiltered) |> dplyr::pull("matchedSample") |> unique()," individuals.")
}else{
msg <- ""
}
lsc <- lscFiltered |>
dplyr::filter(.data$estimate_name == "percentage") |>
tidy() |>
tidyr::pivot_wider(names_from = cohort_name,
values_from = percentage)
if(isTRUE(input$compare_large_scale_characteristics_impute_missings)){
lsc <- lsc |>
dplyr::mutate(across(c(target_cohort, comparator_cohort), ~if_else(is.na(.x), 0, .x)))
}
lsc <- lsc |>
dplyr::mutate(across(c(target_cohort, comparator_cohort), ~ as.numeric(.x)/100)) |>
dplyr::mutate(smd = (!!sym(target_cohort) - !!sym(comparator_cohort))/sqrt((!!sym(target_cohort)*(1-!!sym(target_cohort)) + !!sym(comparator_cohort)*(1-!!sym(comparator_cohort)))/2)) |>
dplyr::mutate(smd = if_else(is.na(smd), 0, round(smd, 3))) |>
dplyr::arrange(desc(smd)) |>
mutate(concept = paste0(variable_name, " (",concept_id, ")"))
if("source_concept_name" %in% colnames(lsc)){
lsc <- lsc |>
mutate(source_concept = paste0(source_concept_name, " (",source_concept_id, ")"))
}
lsc <- lsc |>
select(dplyr::any_of(c(
"CDM name" = "cdm_name",
"Concept name (concept ID)" = "concept",
"Source concept name (concept ID)" = "source_concept",
"Table" = "table_name",
"Time window" = "variable_level",
target_cohort,
comparator_cohort,
"Standardised mean difference" = "smd"))) |>
dplyr::mutate(msg)
return(lsc)
})
output$compare_large_scale_characteristics_tidy <- reactable::renderReactable({
cohorts <- getComparedCohorts()
target_cohort <- cohorts$cohort1
comparator_cohort <- cohorts$cohort2
tbl <- createTidyDataCompareLargeScaleCharacteristics()
msg <- tbl$msg |> unique()
tbl <- tbl |> dplyr::select(-"msg")
if("Source concept name (concept ID)" %in% colnames(tbl)){
cols <- list(target_cohort = colDef(name = paste0(target_cohort, " percentage"),
format = colFormat(percent = TRUE),
sortNALast = TRUE),
comparator_cohort = colDef(name = paste0(comparator_cohort, " percentage"),
format = colFormat(percent = TRUE),
sortNALast = TRUE),
"Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
"Source concept name (concept ID)" = colDef(name = "Source concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
"Standardised mean difference" = colDef(name = "Standardised mean difference",
sortNALast = TRUE)
)
} else {
cols <- list(target_cohort = colDef(name = paste0(target_cohort, " percentage"),
format = colFormat(percent = TRUE),
sortNALast = TRUE),
comparator_cohort = colDef(name = paste0(comparator_cohort, " percentage"),
format = colFormat(percent = TRUE),
sortNALast = TRUE),
"Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
cell = function(value){
value_concept <- gsub(".*\\(|\\)","",value)
url <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
htmltools::tags$a(href = url, target = "_blank", as.character(value))
}),
"Standardised mean difference" = colDef(name = "Standardised mean difference",
sortNALast = TRUE)
)
}
names(cols)[1] <- target_cohort
names(cols)[2] <- comparator_cohort
table <- reactable::reactable(tbl,
defaultSorted = list("Standardised mean difference" = "desc"),
columns = cols,
filterable = TRUE,
searchable = TRUE,
defaultPageSize = 25,
highlight = TRUE,
striped = TRUE,
compact = TRUE,
showSortable = TRUE)
return(table)
})
output$compare_large_scale_characteristics_tidy_download <- shiny::downloadHandler(
filename = "compare_large_scale_characteristics_tidy.csv",
content = function(file) {
createTidyDataCompareLargeScaleCharacteristics() |>
readr::write_csv(file = file)
}
)
## Plot compare large_scale_characteristics ----
getPlotlyCompareLsc <- shiny::reactive({
cohorts <- getComparedCohorts()
plotComparedLsc(lsc = filterCompareLargeScaleCharacteristics(),
cohorts = c(cohorts$cohort1, cohorts$cohort2),
colour = c(input$compare_large_scale_characteristics_colour_1),
facet = c(input$compare_large_scale_characteristics_facet_1),
imputeMissings = input$compare_large_scale_characteristics_impute_missings
)
})
output$plotly_compare_lsc <- renderPlotly({
ggplotly(getPlotlyCompareLsc(), tooltip = "Details")
})
output$plot_compare_large_scale_characteristics_download <- shiny::downloadHandler(
filename = "output_ggplot2_compare_large_scale_characteristics.png",
content = function(file) {
obj <- getPlotlyCompareLsc()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$plot_compare_large_scale_characteristics_download_width),
height = as.numeric(input$plot_compare_large_scale_characteristics_download_height),
units = input$plot_compare_large_scale_characteristics_download_units,
dpi = as.numeric(input$plot_compare_large_scale_characteristics_download_dpi)
)
}
)
# summarise_cohort_overlap -----
filterCohortOverlap <- eventReactive(input$updateCompareCohorts, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_cohort_overlap)) {
validate("No cohort overlap in results")
}
result <- dataFiltered$summarise_cohort_overlap |>
visOmopResults::splitGroup(keep = TRUE) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$cohort_name_reference %in% shared_cohort_names(),
.data$cohort_name_comparator %in% input$summarise_cohort_overlap_cohort_comparator,
.data$variable_name %in% input$summarise_cohort_overlap_variable_name
) |>
dplyr::select(-visOmopResults::groupColumns(dataFiltered$summarise_cohort_overlap))
validateFilteredResult(result)
return(result)
}))
## Table cohort_overlap -----
createTableCohortOverlap <- shiny::reactive({
result <- filterCohortOverlap()
CohortCharacteristics::tableCohortOverlap(
result,
uniqueCombinations = input$summarise_cohort_overlap_gt_uniqueCombinations,
header = input$summarise_cohort_overlap_gt_header,
groupColumn = input$summarise_cohort_overlap_gt_groupColumn,
hide = c(input$summarise_cohort_overlap_gt_hide,
"overlap_by",
"diagnostic", "matchedSample", "phenotyper_version")
) |>
tab_header(
title = "Cohort overlap",
subtitle = "Overlap is where the same individual is in both cohorts. Note their cohort entries do not necessarily overlap."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_cohort_overlap_gt <- gt::render_gt({
createTableCohortOverlap()
})
output$summarise_cohort_overlap_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_overlap_gt.docx",
content = function(file) {
obj <- createTableCohortOverlap()
gt::gtsave(data = obj, filename = file)
}
)
## Plot cohort_overlap -----
createPlotCohortOverlap <- shiny::reactive({
result <- filterCohortOverlap()
CohortCharacteristics::plotCohortOverlap(
result,
colour = input$summarise_cohort_overlap_plot_colour,
facet = input$summarise_cohort_overlap_plot_facet,
uniqueCombinations = input$summarise_cohort_overlap_plot_uniqueCombinations
)
})
output$summarise_cohort_overlap_plot <- plotly::renderPlotly({
createPlotCohortOverlap()
})
output$summarise_cohort_overlap_plot_download <- shiny::downloadHandler(
filename = "summarise_cohort_overlap_plot.png",
content = function(file) {
obj <- createPlotCohortOverlap()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$summarise_cohort_overlap_plot_download_width),
height = as.numeric(input$summarise_cohort_overlap_plot_download_height),
units = input$summarise_cohort_overlap_plot_download_units,
dpi = as.numeric(input$summarise_cohort_overlap_plot_download_dpi)
)
}
)
# summarise_cohort_timing ----
filterCohortTiming <- eventReactive(input$updateCompareCohorts, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$summarise_cohort_timing)) {
validate("No cohort timing in results")
}
result <- dataFiltered$summarise_cohort_timing |>
visOmopResults::splitGroup(keep = TRUE) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names(),
.data$cohort_name_reference %in% shared_cohort_names(),
.data$cohort_name_comparator %in% input$summarise_cohort_overlap_cohort_comparator) |>
dplyr::select(-visOmopResults::groupColumns(dataFiltered$summarise_cohort_timing))
validateFilteredResult(result)
return(result)
}))
## Table cohort_timing -----
createTableCohortTiming <- shiny::reactive({
result <- filterCohortTiming()
CohortCharacteristics::tableCohortTiming(
result,
timeScale = input$summarise_cohort_timing_gt_time_scale,
uniqueCombinations = input$summarise_cohort_timing_gt_uniqueCombinations,
) |>
tab_header(
title = "Cohort timing",
subtitle = "Cohort timing refers to the time between an individual entering one cohort and another cohort."
) |>
tab_options(
heading.align = "left"
)
})
output$summarise_cohort_timing_gt <- gt::render_gt({
createTableCohortTiming()
})
output$summarise_cohort_timing_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_timing_gt.docx",
content = function(file) {
obj <- createTableCohortTiming()
gt::gtsave(data = obj, filename = file)
}
)
## Plot cohort_timing -----
createPlotCohortTiming <- shiny::reactive({
CohortCharacteristics::plotCohortTiming(
filterCohortTiming(),
plotType = "densityplot",
timeScale = input$summarise_cohort_timing_plot_time_scale,
uniqueCombinations = input$summarise_cohort_timing_plot_uniqueCombinations,
facet = input$summarise_cohort_timing_plot_facet,
colour = input$summarise_cohort_timing_plot_colour
)
})
output$summarise_cohort_timing_plot <- shiny::renderUI({
renderPlot(createPlotCohortTiming())
})
output$summarise_cohort_timing_plot_download <- shiny::downloadHandler(
filename = "summarise_cohort_timing_plot.png",
content = function(file) {
obj <- createPlotCohortTiming()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$summarise_cohort_timing_plot_download_width),
height = as.numeric(input$summarise_cohort_timing_plot_download_height),
units = input$summarise_cohort_timing_plot_download_units,
dpi = as.numeric(input$summarise_cohort_timing_plot_download_dpi)
)
}
)
# summarise cohort survival -----
filterCohortSurvival <- eventReactive(input$updateCohortSurvival, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$survival_estimates)) {
validate("No survival in results")
}
if(input$survival_porbability_include_matches){
cohorts <- c(paste0(shared_cohort_names(),"_sampled"),
paste0(shared_cohort_names(),"_matched"))
}else{
cohorts <- shared_cohort_names()
}
result <- omopgenerics::bind(
dataFiltered[str_detect(names(dataFiltered), "survival_")]) |>
dplyr::filter(.data$cdm_name %in% shared_cdm_names()) |>
visOmopResults::filterGroup(.data$target_cohort %in% cohorts)
validateFilteredResult(result)
return(result)
}))
getTimeScale <- eventReactive(input$updateCohortSurvival, ({
timeScale <- input$survival_probability_time_scale
return(timeScale)
}))
## Table cohort survival -----
createTableSurvival <- shiny::reactive({
result <- filterCohortSurvival()
timeScale <- getTimeScale()
table <- CohortSurvival::tableSurvival(result,
timeScale = timeScale,
header = input$survival_table_header,
groupColumn = input$survival_table_groupColumn) |>
tab_header(
title = "Single Event Survival Summary",
subtitle = "Time from cohort entry to death"
) |>
tab_options(
heading.align = "left"
)
return(table)
})
output$summarise_cohort_survival_gt <- gt::render_gt({
createTableSurvival()
})
output$summarise_cohort_survival_gt_download <- shiny::downloadHandler(
filename = "summarise_cohort_survival_gt.docx",
content = function(file) {
obj <- createTableSurvival()
gt::gtsave(data = obj, filename = file)
}
)
## Plot cohort survival ----
createPlotSurvival <- shiny::reactive({
result <- filterCohortSurvival()
timeScale <- getTimeScale()
CohortSurvival::plotSurvival(result,
timeScale = timeScale,
ribbon = input$survival_plot_ribbon,
facet = input$survival_plot_facet,
colour = input$survival_plot_colour,
logLog = input$survival_plot_log_log,
cumulativeFailure = input$survival_plot_cf) +
labs(color = "Color") +
guides(fill = "none")
})
output$summarise_cohort_survival_plot <- shiny::renderUI({
if(isTRUE(input$survival_plot_interactive)){
plot <- plotly::ggplotly(createPlotSurvival())
} else {
plot <- renderPlot(createPlotSurvival())
}
plot
})
output$summarise_cohort_survival_plot_download <- shiny::downloadHandler(
filename = "summarise_cohort_survival_plot.png",
content = function(file) {
obj <- createPlotSurvival()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$summarise_cohort_survival_plot_download_width),
height = as.numeric(input$summarise_cohort_survival_plot_download_height),
units = input$summarise_cohort_survival_plot_download_units,
dpi = as.numeric(input$summarise_cohort_survival_plot_download_dpi)
)
}
)
# incidence -----
filterIncidence <- eventReactive(input$updateIncidence, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$incidence)) {
validate("No incidence in results")
}
result <- dataFiltered$incidence |>
filter(cdm_name %in% shared_cdm_names()) |>
filterGroup(outcome_cohort_name %in% shared_cohort_names()) |>
filterSettings(denominator_age_group %in%
input$incidence_denominator_age_group,
denominator_sex %in%
input$incidence_denominator_sex,
denominator_days_prior_observation %in%
input$incidence_denominator_days_prior_observation) |>
filterAdditional(analysis_interval %in%
input$incidence_analysis_interval)
validateFilteredResult(result)
return(result)
}))
## Table incidence -----
createTableIncidence <- shiny::reactive({
IncidencePrevalence::tableIncidence(
filterIncidence(),
groupColumn = c("cdm_name", "outcome_cohort_name"),
hide = "denominator_cohort_name",
settingsColumn = c("denominator_age_group",
"denominator_sex",
"denominator_days_prior_observation",
"outcome_cohort_name")
) |>
tab_header(
title = "Incidence estimates",
subtitle = "Incidence rates estimated for outcomes of interest"
) |>
tab_options(
heading.align = "left"
)
})
output$incidence_gt <- gt::render_gt({
createTableIncidence()
})
output$incidence_gt_download <- shiny::downloadHandler(
filename = "incidence_gt.docx",
content = function(file) {
obj <- createTableIncidence()
gt::gtsave(data = obj, filename = file)
}
)
## Plot incidence -----
createPlotIncidence <- shiny::reactive({
result <- filterIncidence()
x <- input$incidence_plot_x
y <- input$incidence_plot_y
facet <- input$incidence_plot_facet
facet_free <- input$incidence_plot_facet_free
colour <- input$incidence_plot_colour
# Plot incidence estimates
if(y == "Incidence"){
plot <- IncidencePrevalence::plotIncidence(
result,
x = x,
ribbon = FALSE,
facet = facet,
colour = colour
)
plot$data <- plot$data |>
filter(incidence_100000_pys > 0)
if(!is.null(facet) && isTRUE(facet_free)){
plot <- plot +
facet_wrap(facets = facet, scales = "free")
}
}else{
# Plot incidence population
y_input <- case_when(
y == "Denominator count" ~ "denominator_count",
y == "Denominator person years" ~ "person_years",
y == "Outcome count" ~ "outcome_count"
)
if(!is.null(facet) && isTRUE(facet_free)){
plot <- plotIncidencePopulation(x = x,
y = y_input,
result = result,
facet = NULL,
colour = colour
) +
facet_wrap(facets = facet, scales = "free")
} else {
plot <- plotIncidencePopulation(x = x,
y = y_input,
result = result,
facet = facet,
colour = colour
)
}
}
return(plot)
})
output$incidence_plot <- shiny::renderUI({
if(isTRUE(input$incidence_plot_interactive)){
plot <- plotly::ggplotly(createPlotIncidence())
} else {
plot <- renderPlot(createPlotIncidence())
}
plot
})
output$incidence_plot_download <- shiny::downloadHandler(
filename = "incidence_plot.png",
content = function(file) {
obj <- createPlotIncidence()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$incidence_plot_download_width),
height = as.numeric(input$incidence_plot_download_height),
units = input$incidence_plot_download_units,
dpi = as.numeric(input$incidence_plot_download_dpi)
)
}
)
# prevalence -----
filterPrevalence <- eventReactive(input$updatePrevalence, ({
req(shared_cdm_names())
req(shared_cohort_names())
req(inputs_initialized())
if (is.null(dataFiltered$prevalence)) {
validate("No prevalence in results")
}
result <- dataFiltered$prevalence |>
filter(cdm_name %in% shared_cdm_names()) |>
filterGroup(outcome_cohort_name %in% shared_cohort_names()) |>
filterSettings(denominator_age_group %in%
input$prevalence_denominator_age_group,
denominator_sex %in%
input$prevalence_denominator_sex,
denominator_days_prior_observation %in%
input$prevalence_denominator_days_prior_observation) |>
filterAdditional(analysis_interval %in%
input$prevalence_analysis_interval)
validateFilteredResult(result)
return(result)
}))
## Table prevalence ----
createTablePrevalence <- shiny::reactive({
result <- filterPrevalence()
IncidencePrevalence::tablePrevalence(
result,
groupColumn = c("cdm_name", "outcome_cohort_name"),
hide = "denominator_cohort_name",
settingsColumn = c("denominator_age_group",
"denominator_sex",
"denominator_days_prior_observation",
"outcome_cohort_name")
) |>
tab_header(
title = "Prevalence estimates",
subtitle = "Prevalence rates estimated for outcomes of interest"
) |>
tab_options(
heading.align = "left"
)
})
output$prevalence_gt <- gt::render_gt({
createTablePrevalence()
})
output$prevalence_gt_download <- shiny::downloadHandler(
filename = "prevalence_gt.docx",
content = function(file) {
obj <- createTablePrevalence()
gt::gtsave(data = obj, filename = file)
}
)
## Plot prevalence ----
createPlotPrevalence <- shiny::reactive({
result <- filterPrevalence()
x <- input$prevalence_plot_x
y <- input$prevalence_plot_y
facet <- input$prevalence_plot_facet
facet_free <- input$prevalence_plot_facet_free
colour <- input$prevalence_plot_colour
if(y == "Prevalence"){
plot <- IncidencePrevalence::plotPrevalence(
result,
x = x,
ribbon = FALSE,
facet = facet,
colour = colour
)
plot$data$prevalence_95CI_lower <- round(plot$data$prevalence_95CI_lower, 6)
plot$data$prevalence_95CI_upper <- round(plot$data$prevalence_95CI_upper, 6)
plot$data <- plot$data |>
dplyr::mutate(prevalence = round((outcome_count/denominator_count),6))
if(!is.null(facet) && isTRUE(facet_free)){
plot <- plot +
facet_wrap(facets = facet, scales = "free")
}
}else{
y_input <- case_when(
y == "Denominator count" ~ "denominator_count",
y == "Outcome count" ~ "outcome_count"
)
if(!is.null(facet) && isTRUE(input$facet_free)){
plot <- IncidencePrevalence::plotPrevalencePopulation(
result = result,
x = x,
y = y_input,
facet = NULL,
colour = colour) +
facet_wrap(facets = facet, scales = "free")
} else {
plot <- IncidencePrevalence::plotPrevalencePopulation(
result = result,
x = x,
y = y_input,
facet = facet,
colour = colour
)
}
}
return(plot)
})
output$prevalence_plot <- shiny::renderUI({
if(isTRUE(input$prevalence_plot_interactive)){
plot <- plotly::ggplotly(createPlotPrevalence())
} else {
plot <- renderPlot(createPlotPrevalence())
}
plot
})
output$prevalence_plot_download <- shiny::downloadHandler(
filename = "prevalence_plot.png",
content = function(file) {
obj <- createPlotPrevalence()
ggplot2::ggsave(
filename = file,
plot = obj,
width = as.numeric(input$prevalence_plot_download_width),
height = as.numeric(input$prevalence_plot_download_height),
units = input$prevalence_plot_download_units,
dpi = as.numeric(input$prevalence_plot_download_dpi)
)
}
)
# log file -----
output$summarise_log_file_gt <- gt::render_gt({
dataFiltered$summarise_log_file |>
omopgenerics::tidy() |>
dplyr::mutate(log_id = as.integer(log_id)) |>
dplyr::arrange("cdm_name", "log_id") |>
dplyr::select(cdm_name, variable_name,
elapsed_time) |>
dplyr::mutate(elapsed_time =
dplyr::if_else(!is.na(elapsed_time),
sprintf("%d hours, %d minutes, %d seconds",
lubridate::hour(elapsed_time),
lubridate::minute(elapsed_time),
lubridate::second(elapsed_time)),
NA_character_)) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "0 hours, 0 minutes, ", "")) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "0 hours, ", "")) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "1 hours", "1 hour")) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "1 minutes", "1 minute")) |>
dplyr::mutate(elapsed_time = stringr::str_replace(
elapsed_time, "1 seconds", "1 second")) |>
dplyr::rename("task" = "variable_name",
estimate_value = "elapsed_time") |>
dplyr::mutate(estimate_type = "character",
estimate_name = "Time taken") |>
visOmopResults::visTable(
header = c("cdm_name", "estimate_name"),
rename = c("Database name" = "cdm_name"),
hide = "estimate_type") |>
gt::tab_options(container.width = "100%")
})
# expectations ----
createExpectationsOutput <- function(trigger_input, output_id) {
filteredExpectations <- eventReactive(trigger_input(), {
req(shared_cohort_names())
req(inputs_initialized())
validateExpectations(expectations)
section_name <- gsub("_expectations","",output_id)
result <- expectations |>
dplyr::filter(.data$cohort_name %in% shared_cohort_names())
section_name <- gsub("_expectations","",output_id)
if("diagnostics" %in% colnames(expectations)){
result <- result |>
mutate(diagnostics = strsplit(diagnostics, ",\\s*")) |>
unnest(diagnostics)
validateExpectationSections(result)
result <- result |>
dplyr::filter(.data$diagnostics %in% section_name)
}
if(nrow(result) == 0){
section_name_nice <- stringr::str_replace_all(section_name, "_", " ")
validate(glue::glue("No expectations for {section_name_nice} results."))
}
result
})
output[[output_id]] <- reactable::renderReactable({
filteredExpectations() |>
PhenotypeR::tableCohortExpectations()
})
}
createExpectationsOutput(reactive(input$updateCohortCount), "cohort_count_expectations")
createExpectationsOutput(reactive(input$updateCohortCharacteristics), "cohort_characteristics_expectations")
createExpectationsOutput(reactive(input$updateLSC), "large_scale_characteristics_expectations")
createExpectationsOutput(reactive(input$updateCompareLSC), "compare_large_scale_characteristics_expectations")
createExpectationsOutput(reactive(input$updateCompareCohorts), "compare_cohorts_expectations")
createExpectationsOutput(reactive(input$updateCohortSurvival), "cohort_survival_expectations")
}
Try the PhenotypeR package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.