library(shiny)
library(shinyjs)
library(dplyr)
library(DWHtools2)
library(multimodalPhewas)
library(ggplot2)
library(plotly)
library(DT)
library(future)
options(shiny.sanitize.errors = FALSE)
options(shiny.maxRequestSize=3000*1024^2) # maximum upload size = 3GB
#local = .local
#bio_file = .bio_file
#concepts_file = .concepts_file
#cim_file = .icd_file
data(scale1)
data(anabio_loinc)
if(local) {
# load(bio_file)
# load(icd_file)
# load(concepts_file)
#
# concepts_local <- concepts
# cim_local <- cim
# bio_local <- bio
}
shinyServer(function(input, output,session) {
cores = future::availableCores()
if(local) {
shinyjs::hide("loading-content")
shinyjs::show("files_upload")
shinyjs::show("analysis_parameters")
}
icd_prefix = 'CIM10:'
shinyjs::disable("report")
shinyjs::disable("result_data")
num_cohorts = ""
results <- function() {}
if(!local) {
config <- getConfig(config_file)
}
concepts_col_remove = list( "-CI_inf", "-CI_sup", "-cases0","-control0")
bio_col_remove = list( "-CI_inf", "-CI_sup", "-cases0","-control0", "-fit")
cim_col_remove = list( "-CI_inf", "-CI_sup", "-cases0","-control0", "-fit")
if(!local) {
cohorts <- DWHtools2::get_cohorts_list(username = config$username, only_num = FALSE,config = config)
num_cohorts <- reactive( {
cohorts_for_select <- list()
num_cohorts <- cohorts$NUM_COHORTE
names(num_cohorts) <- paste0(cohorts$TITRE_COHORTE,' (',cohorts$N_PATIENTS,' patients)')
num_cohorts
})
observeEvent(num_cohorts(), {
shinyjs::hide("loading-content")
if(!local) shinyjs::show("patients_selection")
shinyjs::show("analysis_parameters")
})
} else {
cohorts <- data.frame(NUM_COHORTE = c(1,2), TITRE_COHORTE = c('RETT', 'RETT controls'), N_PATIENTS = c(12, 24))
}
output$controls_cases <- renderUI(selectInput('cases','cases', num_cohorts()))
output$control_type <- renderUI(if(!is.null(num_cohorts())) {
radioButtons('control_type',label = "Type of controls", choices= list(`Automatic matching`='match', `Cohort` = "cohort" ))
})
if(!local) {
controls_num_temp_list = reactive({
num_cohorts()[num_cohorts() != input$cases]
})
}
output$biotab <-renderUI(renderTab(input$boot, 'results_bio', 'dumbbell_bio', input$plot_height ))
output$conceptstab <-renderUI(renderTab(input$boot, 'results_concepts', 'dumbbell_concepts', input$plot_height ))
output$cimtab <- renderUI(renderTab(input$boot, 'results_cim', 'dumbbell_cim' , input$plot_height))
renderTab <- function(boot, manhattan, dumbbell, plot_height) {
if (boot == 'TRUE') {
return((fluidRow(
column(6,
plotly::plotlyOutput(outputId = manhattan, width = 'auto', height = plot_height)
),
column(6,
plotly::plotlyOutput(outputId = dumbbell, width = 'auto', height = plot_height)
)
)))
} else {
return((fluidRow(
column(12,
plotly::plotlyOutput(outputId = manhattan, width = 'auto', height = plot_height)
)
)))
}
}
output$controls_trigger <- renderUI(if(input$control_type == 'cohort') {
if (!local) {
if (!is.null(controls_num_temp_list())) {
selectInput('controls','controls', controls_num_temp_list())
}
}
})
if (!local) {
observe(if (input$control_type == 'cohort' & is.null(controls_num_temp_list()))
{
showNotification("There is no other cohort available in the results table", type = 'warning')
})
}
output$match_save <- renderUI(if(input$control_type == 'match') {
radioButtons('match_save',label = "Save matched cohort", choices= list(`No` = FALSE, `Yes`=TRUE ))
})
output$match_save_title <- renderUI(if(input$control_type == 'match' & !is.null(input$match_save) ) {
if (input$match_save) {
default_title = paste0(cohorts$TITRE_COHORTE[cohorts$NUM_COHORTE == input$cases], ' - ', Sys.time(), ' controls for multiphewas' )
textInput('match_save_title', 'Name for the matching cohort', value = default_title)
}
})
# Get cases ------------
cases <-reactive(
{
progress_cases <- shiny::Progress$new(session, min = 0, max = 4)
on.exit(progress_cases$close())
progress_cases$set(message = "get data", value = 0)
if(!local) {
data_ <- get_data_from_num(cohorte_num = input$cases,
num_type = 'cohorte',
cohort = 'cases',
neg = FALSE,
progress = progress_cases,
icd_prefix = icd_prefix,
config = config, step_p = 0)
data_
}
})
# ----------
# Get controls -----------
control_cohort <- reactive({
progress_match <- shiny::Progress$new(session, min = 0, max = 4)
on.exit(progress_match$close())
progress_match$set(message = "Matching", value = 0)
if(!local) {
if (input$control_type == 'match') {
control_cohort <- match_patients(cohorte_num = input$cases,
num_type = 'cohorte',
birth_range = input$birth_range,
concepts_range=input$concept_range, n_match=input$n_match,
match_save = as.logical(input$match_save),
match_save_title= input$match_save_title,
config = config
)
} else if (input$control_type == 'cohort') {
control_cohort = list(control_num = input$controls, control_num_type = 'cohorte')
}
control_cohort
}
})
controls <-reactive(
{
progress_controls <- shiny::Progress$new(session, min = 0, max = 4)
on.exit(progress_controls$close())
progress_controls$set(message = "get data", value = 0)
if(!local) {
data_ <- get_data_from_num(cohorte_num = control_cohort()$control_num,
num_type = control_cohort()$control_num_type,
cohort = 'control',
neg = FALSE,
progress = progress_controls,
icd_prefix = icd_prefix,
config = config, step_p = 0)
data_
}
})
# --------------
# Extract data ----------
patients <- reactive({
if(!local) {
patients <- controls()$patients[,names(controls()$patients) %in% names(cases()$patients)] %>%
rbind(cases()$patients)
#save(patients, file= '~/Sync/multimodalPhewas/patients_mecp2.RData')
} else {
if (is.null(input$patients_csv)) {
patients <- NULL
} else {
patients <- read.csv(input$patients_csv$datapath, stringsAsFactors = F)
}
}
str(patients)
patients
})
concepts <- reactive({
if(!local) {
if (!is.null(cases()$concepts)) {
concepts <- rbind(cases()$concepts, controls()$concepts)
concepts <- concepts %>% dplyr::filter(PHENOTYPE == 1 | GENOTYPE == 1, !is.na(PARENT_LABEL))
}
}else {
if (is.null(input$concepts_csv)) {
concepts <- NULL
} else {
concepts <- read.csv(input$concepts_csv$datapath, stringsAsFactors = F)
}
}
concepts <- merge(concepts, subset(patients(), select = c('PATIENT_NUM','SEX', 'BIRTH_YEAR')), by = 'PATIENT_NUM')
concepts <- preprocess_umls_concepts(concepts, nb_occurrences = input$nb_occurrences_concept)
concepts
})
bio <- reactive({
if(!local) {
if (!is.null(cases()$bio)) {
bio <- rbind(cases()$bio, controls()$bio)
}
} else {
if (is.null(input$bio_csv)) {
bio <- NULL
} else {
bio <- read.csv(input$bio_csv$datapath, stringsAsFactors = F)
}
}
str(bio)
bio <- merge(bio, subset(patients(), select = c('PATIENT_NUM','SEX', 'BIRTH_YEAR')), by = 'PATIENT_NUM')
bio <- preprocess_bio_concepts(bio, type = 'encounter', nb_occurrences =input$nb_occurrences_bio, map_loinc = ifelse(local, FALSE, TRUE))
bio
})
cim <- reactive({
if (!local) {
if (!is.null(cases()$cim)) {
cim <- rbind(cases()$cim, controls()$cim)
}
} else {
if (is.null(input$cim_csv)) {
cim <- NULL
} else {
cim <- read.csv(input$cim_csv$datapath, stringsAsFactors = F)
}
}
cim <- merge(cim, subset(patients(), select = c('PATIENT_NUM','SEX', 'BIRTH_YEAR')), by = 'PATIENT_NUM')
cim <- preprocess_cim(cim, scale1, icd_prefix = icd_prefix, nb_occurrences = input$nb_occurrences_icd)
cim
})
# -------------
# Compute PheWAS ----------
result_concepts <- eventReactive(eventExpr = (input$submit_loc),{
shinyjs::disable("report")
shinyjs::disable("result_data")
if ('free_text' %in% input$sources & (!local | !is.null(input$concepts_csv))) {
progress<- shiny::Progress$new(session, min = 0, max = 2)
on.exit(progress$close())
progress$set(message = "Concepts", value = 0)
str(concepts())
res <- compute_phewas(concepts(),patients(),
concepts_min_occur = input$concepts_min_occur,
with_boot= as.logical(input$boot), perm = input$boot_perm, fdr_threshold = input$fdr_threshold,
, progress = progress, cores = cores)
shinyjs::enable("report")
shinyjs::enable("result_data")
res
}
})
result_bio <- eventReactive(eventExpr = input$submit_loc,{
shinyjs::disable("report")
shinyjs::disable("result_data")
if('bio' %in% input$sources & (!local | !is.null(input$bio_csv))) {
progress<- shiny::Progress$new(session, min = 0, max = 2)
on.exit(progress$close())
progress$set(message = "Bio", value = 0)
bio_sup <- compute_bio_phewas(bio(), patients(), direction = "SUP", bio_min_occur = 1,
zero_controls_add = 2, patients_min_concept = NULL, analysis_type = input$bio_family,
with_boot = as.logical(input$boot), perm = input$boot_perm,
fdr_threshold = input$fdr_threshold,progress= progress, cores = cores )
bio_inf <- compute_bio_phewas(bio(), patients(), direction = "INF", bio_min_occur = 1,
zero_controls_add = 2, patients_min_concept = NULL, analysis_type = input$bio_family,
with_boot = as.logical(input$boot), perm = input$boot_perm , fdr_threshold = input$fdr_threshold
,progress= progress, cores = cores)
res <- list()
res$result <- rbind(bio_sup$result, bio_inf$result)
res$boot <- bio_sup$boot
shinyjs::enable("report")
shinyjs::enable("result_data")
res
}
})
result_cim <- eventReactive(eventExpr = input$submit_loc,{
shinyjs::disable("report")
shinyjs::disable("result_data")
if('icd' %in% input$sources & (!local | !is.null(input$cim_csv))) {
progress<- shiny::Progress$new(session, min = 0, max = 2)
on.exit(progress$close())
progress$set(message = "ICD", value = 0)
res <- compute_cim_phewas(cim(), patients(), cim_min_occur = input$concepts_min_occur,
with_boot = as.logical(input$boot), perm = input$boot_perm, fdr_threshold = input$fdr_threshold,
progress = progress, cores = cores)
res$result$CAT <- phewas_categories(res$result$CODE)
shinyjs::enable("report")
shinyjs::enable("result_data")
res
}
})
# -----------
# Manhattan output -----------
manhattan_concepts <- reactive({
req(input$plot_height)
if(nrow(result_concepts()$result) > 0) {
make_manhattan(result_concepts()$result, 'p.value','concepts', plot_height = input$plot_height)
} else {
ggplot(data.frame(x=0,y=0)) + theme_void()
}})
output$results_concepts <- plotly::renderPlotly(
manhattan_concepts()
)
manhattan_bio <- reactive({
req(input$plot_height)
if(nrow(result_bio()$result) > 0) {
make_manhattan(result_bio()$result, 'p.value','bio', plot_height =input$plot_height)
} else {
ggplot(data.frame(x=0,y=0)) + theme_void()
}})
output$results_bio <- plotly::renderPlotly(
manhattan_bio()
)
manhattan_cim <- reactive({
req(input$plot_height)
if(nrow(result_cim()$result) > 0) {
make_manhattan(result_cim()$result, 'p.value','cim', plot_height = input$plot_height)
} else {
ggplot(data.frame(x=0,y=0)) + theme_void()
}})
output$results_cim <- plotly::renderPlotly(
manhattan_cim()
)
# ------------
# Dumbbell output --------
dumbbell_plot_bio <- reactive( {
if(result_bio()$boot == TRUE) {
input$plot_height
make_dumbbell(result_bio()$result, plot_height = input$plot_height, db_type = input$db_type)
}
})
dumbbell_plot_cim <- reactive( {
if(result_cim()$boot == TRUE) {
input$plot_height
make_dumbbell(result_cim()$result, plot_height = input$plot_height, db_type = input$db_type)
}
})
dumbbell_plot_concepts <- reactive( {
if(result_concepts()$boot == TRUE) {
input$plot_height
make_dumbbell(result_concepts()$result, plot_height = input$plot_height , db_type = input$db_type)
} else {
g <- ggplot(data.frame(x=0,y=0)) + theme_void()
ggplotly(g)
}
})
output$dumbbell_bio <- plotly::renderPlotly(dumbbell_plot_bio())
output$dumbbell_concepts <- plotly::renderPlotly(dumbbell_plot_concepts())
output$dumbbell_cim <- plotly::renderPlotly(dumbbell_plot_cim())
# --------------
# Table output -----------
output$table_concepts <- DT::renderDataTable(
make_print_table(result_concepts()$result, cols_to_remove = concepts_col_remove, result_concepts()$boot)
)
#output$results_bio <- plotly::renderPlotly(make_manhattan(result_bio()$result, 'p.value','bio'))
output$table_bio <- DT::renderDataTable(
make_print_table(result_bio()$result, cols_to_remove = bio_col_remove, result_bio()$boot)
)
#output$results_cim <- plotly::renderPlotly(make_manhattan(result_cim()$result, 'p.value','cim', plot_height = input$plot_height))
output$table_cim <- DT::renderDataTable(
make_print_table(result_cim()$result, cols_to_remove = cim_col_remove, result_cim()$boot)
)
# ------------
#
# Patients description ---------
patients_desc <- reactive({
patients() %>%
group_by(group) %>%
mutate(BIRTH_YEAR = as.numeric(BIRTH_YEAR),
UNIQ_CONCEPTS = as.numeric(UNIQ_CONCEPTS)) %>%
summarise(n = n(),
BIRTH_YEAR = median(BIRTH_YEAR, na.rm = T),
BIRTH_YEAR_q25 = quantile(BIRTH_YEAR, probs = c(0.25)),
BIRTH_YEAR_q75 = quantile(BIRTH_YEAR, probs = c(0.75)),
NB_MALES = sum(SEX == 'M'),
GENDER_RATIO = sum(SEX == 'M') / n(),
NB_DISTINCT_CONCEPTS = median(UNIQ_CONCEPTS, na.rm = T),
NB_DISTINCT_CONCEPTS_q25 = quantile(UNIQ_CONCEPTS, probs = c(0.25)),
NB_DISTINCT_CONCEPTS_q75 = quantile(UNIQ_CONCEPTS, probs = c(0.75))) %>%
mutate(BIRTH_YEAR = paste0(round(BIRTH_YEAR,0), ' [',round(BIRTH_YEAR_q25,0),'-',round(BIRTH_YEAR_q75,0),']'),
GENDER_RATIO = paste0(NB_MALES,'/',n,' (',round(GENDER_RATIO,2),')'),
NB_DISTINCT_CONCEPTS = paste0(round(NB_DISTINCT_CONCEPTS,0), ' [',round(NB_DISTINCT_CONCEPTS_q25,0),'-',round(NB_DISTINCT_CONCEPTS_q75,0),']')) %>%
select(group, n, BIRTH_YEAR, GENDER_RATIO, NB_DISTINCT_CONCEPTS)
})
output$table_patients <- DT::renderDataTable(patients_desc())
# ---------------
# Dynamic report ---------
output$report <- downloadHandler(
# For PDF output, change this to "report.pdf"
filename = "report.html",
content = function(file) {
# Copy the report file to a temporary directory before processing it, in
# case we don't have write permissions to the current working dir (which
# can happen when deployed).
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("report.Rmd", tempReport, overwrite = TRUE)
# Set up parameters to pass to Rmd document
# if (input$boot == 'TRUE') {
# db_concepts = ifelse('free_text' %in% input$sources,dumbbell_plot_concepts(), NA)
# db_bio = ifelse('bio' %in% input$sources,dumbbell_plot_bio(), NA)
# db_cim = ifelse('bio' %in% input$sources,dumbbell_plot_cim(),NA)
# } else {
# db_concepts = NA
# db_bio = NA
# db_cim = NA
# }
cases = cohorts %>%
filter(NUM_COHORTE == input$cases) %>%
mutate(name = paste0(TITRE_COHORTE,' (',N_PATIENTS,' patients)',' (NUM = ',NUM_COHORTE,')' ))
if (input$control_type == 'match') {
controls = list()
controls$name = 'Automatic matching'
if (input$match_save == 'TRUE') {
controls$name = paste0(controls$name, ' (saved as "', input$match_save_title, '")')
}
} else {
controls = cohorts %>%
filter(NUM_COHORTE == input$controls) %>%
mutate(name = paste0(TITRE_COHORTE,' (',N_PATIENTS,' patients)',' (NUM = ',NUM_COHORTE,')' ))
}
manhattan_concepts_rep <- NA
table_concepts_rep <- NA
dumbbell_concepts_rep <- NA
manhattan_bio_rep <- NA
table_bio_rep <- NA
dumbbell_bio_rep <- NA
manhattan_cim_rep <- NA
table_cim_rep <- NA
dumbbell_cim_rep <- NA
if ('icd' %in% input$sources) table_cim_rep <- make_print_table(result_cim()$result, cim_col_remove, input$boot)
if ('icd' %in% input$sources) manhattan_cim_rep <- manhattan_cim()
if ('icd' %in% input$sources & input$boot == 'TRUE') dumbbell_cim_rep <- dumbbell_plot_cim()
if ('bio' %in% input$sources) table_bio_rep <- make_print_table(result_bio()$result, bio_col_remove, input$boot)
if ('bio' %in% input$sources) manhattan_bio_rep <- manhattan_bio()
if ('bio' %in% input$sources & input$boot == 'TRUE') dumbbell_bio_rep <- dumbbell_plot_bio()
if ('free_text' %in% input$sources) table_concepts_rep <- make_print_table(result_concepts()$result, concepts_col_remove, input$boot)
if ('free_text' %in% input$sources) manhattan_concepts_rep <- manhattan_concepts()
if ('free_text' %in% input$sources & input$boot == 'TRUE') dumbbell_concepts_rep <- dumbbell_plot_concepts()
params <- list(cases = cases$name,
controls = controls$name,
patients = patients_desc(),
manhattan_concepts = manhattan_concepts_rep,
table_concepts = table_concepts_rep,
dumbbell_concepts = dumbbell_concepts_rep,
manhattan_bio = manhattan_bio_rep,
table_bio = table_bio_rep,
dumbbell_bio = dumbbell_bio_rep,
manhattan_cim = manhattan_cim_rep,
table_cim = table_cim_rep,
dumbbell_cim = dumbbell_cim_rep)
# Knit the document, passing in the `params` list, and eval it in a
# child of the global environment (this isolates the code in the document
# from the code in this app).
rmarkdown::render(tempReport, output_file = file,
params = params,
envir = new.env(parent = globalenv())
)
}
)
concepts_dl <- reactiveValues()
observe({
if(!is.null(result_concepts()$result))
isolate(
result_dl <<- result_concepts()$result
)
})
bio_dl <- reactiveValues()
observe({
if(!is.null(result_bio()$result))
isolate(
bio_dl <<- result_bio()$result
)
})
icd_dl <- reactiveValues()
observe({
if(!is.null(result_cim()$result))
isolate(
icd_dl <<- result_cim()$result
)
})
output$result_data <- downloadHandler(
# For PDF output, change this to "report.pdf"
filename = "multimodalPhewas.RData",
content = function(file) {
save(concepts_dl,bio_dl,icd_dl, file = file)
#write.csv(result()$result, file = file)
}
)
# -------------
output$panels = renderUI({
tabs = list()
input$plot_height
i = 1
if ('free_text' %in% input$sources) {
tabs[[i]] <- tabPanel("UMLS concepts from free text reports", uiOutput('conceptstab'), fluidRow(column(12,DT::dataTableOutput('table_concepts'))))
i = i + 1
}
if ('bio' %in% input$sources) {
tabs[[i]] <- tabPanel("Biological test results", uiOutput('biotab'), fluidRow(column(12,DT::dataTableOutput('table_bio'))))
i = i + 1
}
if ('icd' %in% input$sources) {
tabs[[i]] <- tabPanel("Billing codes (ICD10)", uiOutput('cimtab'), fluidRow(column(12,DT::dataTableOutput('table_cim'))))
i = i + 1
}
if (!local) {
tabs[[i]] <- tabPanel("Patients Description", DT::dataTableOutput('table_patients'))
i = i + 1
}
tabs[[i]] <- tabPanel("Parameters",
tags$h3('Patients selection'),
tags$h4('Matching parameters'),
numericInput('n_match', label = 'Number of control patients to match', value = 5, min = 1, max = 20),
numericInput('birth_range', label = 'Range for matching on birth years (e.g. between [year-range; year+range])', value = 2, min = 1, max = 20),
numericInput('concept_range', label = 'Range for matching on the number of concepts (e.g. between [n_concepts - n_concepts*range ; n_concepts + n_concepts*range])', value = 1, min = 0, max = 1),
tags$h3('Analysis'),
hidden(radioButtons('bio_family',label = "Bio analysis type",
choices= list( `Binomial`='binomial', `Poisson` = 'poisson' ))),
tags$h4('Minimum number of occurrences per patient'),
numericInput('nb_occurrences_concept', label = 'UMLS concept', value = 2, min = 1, max = 5),
numericInput('nb_occurrences_bio', label = 'Biological test results', value = 1, min = 1, max = 5),
numericInput('nb_occurrences_icd', label = 'ICD codes', value = 1, min = 1, max = 5),
tags$h4('Phenome-wide scan'),
numericInput('concepts_min_occur', label = 'Minimal number of occurrences of a concept (cohort wise)', value = 5, min = 5, max = 200),
tags$h4('Bootstrap'),
numericInput('boot_perm', label = 'Number of permutations', value = 1000, min = 10, max = 1e6),
numericInput('fdr_threshold', label = 'FDR corrected p-value threshold for bootstrap', value = 0.05, min = 0, max = 1),
tags$hr(id='line2'),
tags$h3(id = 'controls_title3','Visualisation parameters'),
radioButtons('db_type', label = 'Type of results for dumbbell plot', choices = list(`OR` = 'OR', `P value`='p.value')),
sliderInput("plot_height", "Plot Height", 200, 1200, 900))
do.call(tabsetPanel,tabs)
})
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.