R/app_server.R
In cparsania/FungiExpresZ: FungiExpresZ: Fungal gene expression data analysis and visualizations
Defines functions
app_server
Documented in
app_server
#' app server
#'
#' @param input session input
#' @param output session output
#' @param session session
#' @importFrom dplyr %>%
#' @importFrom dplyr add_count
#' @importFrom dplyr add_row
#' @importFrom dplyr add_rownames
#' @importFrom dplyr add_tally
#' @importFrom dplyr all_vars
#' @importFrom dplyr any_vars
#' @importFrom dplyr arrange
#' @importFrom dplyr arrange_all
#' @importFrom dplyr arrange_at
#' @importFrom dplyr arrange_if
#' @importFrom dplyr as_data_frame
#' @importFrom dplyr as_tibble
#' @importFrom dplyr bind_cols
#' @importFrom dplyr bind_rows
#' @importFrom dplyr case_when
#' @importFrom dplyr count
#' @importFrom dplyr count_
#' @importFrom dplyr data_frame
#' @importFrom dplyr distinct
#' @importFrom dplyr distinct_all
#' @importFrom dplyr distinct_at
#' @importFrom dplyr distinct_if
#' @importFrom dplyr distinct_prepare
#' @importFrom dplyr enquo
#' @importFrom dplyr enquos
#' @importFrom dplyr everything
#' @importFrom dplyr expr
#' @importFrom dplyr filter
#' @importFrom dplyr filter_all
#' @importFrom dplyr filter_at
#' @importFrom dplyr filter_if
#' @importFrom dplyr first
#' @importFrom dplyr funs
#' @importFrom dplyr glimpse
#' @importFrom dplyr group_by
#' @importFrom dplyr group_by_
#' @importFrom dplyr group_by_all
#' @importFrom dplyr group_by_at
#' @importFrom dplyr if_else
#' @importFrom dplyr intersect
#' @importFrom dplyr last
#' @importFrom dplyr last_col
#' @importFrom dplyr left_join
#' @importFrom dplyr mutate
#' @importFrom dplyr mutate_
#' @importFrom dplyr mutate_all
#' @importFrom dplyr mutate_at
#' @importFrom dplyr mutate_each
#' @importFrom dplyr mutate_if
#' @importFrom dplyr n
#' @importFrom dplyr n_distinct
#' @importFrom dplyr n_groups
#' @importFrom dplyr na_if
#' @importFrom dplyr order_by
#' @importFrom dplyr pull
#' @importFrom dplyr quo
#' @importFrom dplyr quo_name
#' @importFrom dplyr quos
#' @importFrom dplyr rename
#' @importFrom dplyr rename_all
#' @importFrom dplyr rename_at
#' @importFrom dplyr rename_if
#' @importFrom dplyr rename_vars
#' @importFrom dplyr rename_vars_
#' @importFrom dplyr right_join
#' @importFrom dplyr row_number
#' @importFrom dplyr rowwise
#' @importFrom dplyr same_src
#' @importFrom dplyr sample_frac
#' @importFrom dplyr sample_n
#' @importFrom dplyr select
#' @importFrom dplyr select_
#' @importFrom dplyr select_all
#' @importFrom dplyr select_at
#' @importFrom dplyr select_if
#' @importFrom dplyr select_var
#' @importFrom dplyr select_vars
#' @importFrom dplyr select_vars_
#' @importFrom dplyr slice
#' @importFrom dplyr slice_
#' @importFrom dplyr setdiff
#' @importFrom dplyr starts_with
#' @importFrom dplyr summarise
#' @importFrom dplyr summarise_
#' @importFrom dplyr summarise_all
#' @importFrom dplyr summarise_at
#' @importFrom dplyr summarise_each
#' @importFrom dplyr summarise_each_
#' @importFrom dplyr summarise_if
#' @importFrom dplyr summarize
#' @importFrom dplyr summarize_
#' @importFrom dplyr summarize_all
#' @importFrom dplyr summarize_at
#' @importFrom dplyr summarize_each
#' @importFrom dplyr summarize_each_
#' @importFrom dplyr summarize_if
#' @importFrom dplyr tally
#' @importFrom dplyr tally_
#' @importFrom dplyr tbl
#' @importFrom dplyr tbl_df
#' @importFrom dplyr tibble
#' @importFrom dplyr top_n
#' @importFrom dplyr tribble
#' @importFrom dplyr ungroup
#' @importFrom dplyr union
#' @importFrom dplyr union_all
#' @importFrom dplyr vars
#' @importFrom dplyr contains
#' @importFrom dplyr if_else
#' @importFrom tidyr %>%
#' @importFrom tidyr drop_na
#' @importFrom tidyr gather
#' @importFrom tidyr nest
#' @importFrom tidyr replace_na
#' @importFrom tidyr separate
#' @importFrom tidyr separate_rows
#' @importFrom tidyr spread
#' @importFrom tidyr unite
#' @importFrom tidyr unnest
#' @importFrom magrittr %>%
#' @importFrom readr read_csv
#' @importFrom readr read_delim
#' @importFrom readr read_file
#' @importFrom readr read_lines
#' @importFrom readr read_rds
#' @importFrom readr read_tsv
#' @importFrom readr type_convert
#' @importFrom readr write_csv
#' @importFrom readr write_csv2
#' @importFrom readr write_delim
#' @importFrom readr write_file
#' @importFrom readr write_lines
#' @importFrom readr write_rds
#' @importFrom readr write_tsv
#' @importFrom rlang as_function
#' @importFrom purrr as_mapper
#' @importFrom purrr as_vector
#' @importFrom purrr compact
#' @importFrom purrr compose
#' @importFrom purrr is_list
#' @importFrom purrr keep
#' @importFrom purrr map
#' @importFrom purrr map_at
#' @importFrom purrr map_chr
#' @importFrom purrr map_dbl
#' @importFrom purrr map_depth
#' @importFrom purrr map_df
#' @importFrom purrr map_dfc
#' @importFrom purrr map_dfr
#' @importFrom purrr map_if
#' @importFrom purrr map_int
#' @importFrom purrr map_lgl
#' @importFrom purrr map_raw
#' @importFrom purrr map2
#' @importFrom purrr map2_chr
#' @importFrom purrr map2_dbl
#' @importFrom purrr map2_df
#' @importFrom purrr map2_dfc
#' @importFrom purrr map2_dfr
#' @importFrom purrr map2_int
#' @importFrom purrr map2_lgl
#' @importFrom purrr map2_raw
#' @importFrom purrr negate
#' @importFrom purrr partial
#' @importFrom purrr safely
#' @importFrom purrr set_names
#' @importFrom purrr splice
#' @importFrom tibble add_column
#' @importFrom tibble add_row
#' @importFrom tibble as_data_frame
#' @importFrom tibble as_tibble
#' @importFrom tibble as.tibble
#' @importFrom tibble column_to_rownames
#' @importFrom tibble data_frame
#' @importFrom tibble enframe
#' @importFrom tibble glimpse
#' @importFrom tibble repair_names
#' @importFrom tibble rowid_to_column
#' @importFrom tibble rownames_to_column
#' @importFrom tibble tibble
#' @importFrom glue glue
#' @importFrom stringr str_c
#' @importFrom stringr str_extract
#' @importFrom stringr str_extract_all
#' @importFrom stringr str_glue
#' @importFrom stringr str_length
#' @importFrom stringr str_match
#' @importFrom stringr str_match_all
#' @importFrom stringr str_order
#' @importFrom stringr str_pad
#' @importFrom stringr str_remove
#' @importFrom stringr str_remove_all
#' @importFrom stringr str_replace
#' @importFrom stringr str_replace_all
#' @importFrom stringr str_replace_na
#' @importFrom stringr str_sort
#' @importFrom stringr str_split
#' @importFrom stringr str_wrap
#' @importFrom forcats %>%
#' @importFrom forcats as_factor
#' @importFrom forcats fct_c
#' @importFrom forcats fct_drop
#' @importFrom forcats fct_expand
#' @importFrom forcats fct_inorder
#' @importFrom forcats fct_match
#' @importFrom forcats fct_other
#' @importFrom forcats fct_recode
#' @importFrom forcats fct_relabel
#' @importFrom forcats fct_relevel
#' @importFrom forcats fct_reorder
#' @importFrom forcats fct_reorder2
#' @importFrom clipr clear_clip
#' @importFrom clipr read_clip
#' @importFrom clipr read_clip_tbl
#' @importFrom clipr write_clip
#' @importFrom clipr write_last_clip
#' @importFrom rlang :=
#' @importFrom rlang !!
#' @importFrom rlang !!!
#' @importFrom rlang %@%
#' @importFrom rlang %@%<-
#' @importFrom rlang %|%
#' @importFrom rlang %||%
#' @importFrom rlang enquo
#' @importFrom rlang enquos
#' @importFrom rlang quo
#' @importFrom rlang quos
#' @importFrom rlang set_names
#' @importFrom tm Corpus
#' @importFrom tm Docs
#' @importFrom tm DocumentTermMatrix
#' @importFrom tm removeNumbers
#' @importFrom tm removePunctuation
#' @importFrom tm removeSparseTerms
#' @importFrom tm removeWords
#' @importFrom tm SimpleCorpus
#' @importFrom tm stemDocument
#' @importFrom tm stopwords
#' @importFrom tm TermDocumentMatrix
#' @importFrom tm termFreq
#' @importFrom tm Terms
#' @importFrom tm tm_filter
#' @importFrom tm tm_index
#' @importFrom tm tm_map
#' @importFrom tm tm_parLapply
#' @importFrom tm tm_parLapply_engine
#' @importFrom tm tm_reduce
#' @importFrom tm tm_term_score
#' @importFrom tm VCorpus
#' @importFrom tm VectorSource
#' @importFrom tm content_transformer
#' @importFrom tm stripWhitespace
#' @importFrom MASS kde2d
#' @importFrom janitor clean_names
#' @importFrom broom tidy
#' @importFrom rio convert
#' @importFrom scales squish
#' @import ggupset
#' @keywords internal
app_server <- function(input, output,session) {
# List the first level callModules here
options(shiny.maxRequestSize = 30 * 1024^2)
## prepare user applied filters' (while selecting pre loaded data) expressions .
## NOTE : following filter expressions will be used to filter the sample_info (pre loaded data) table.
## Therefore, column names - `Organism` and `strain` (given as names of vector) must be identical to the column names of the sample_info table.
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Display, filter and select existing data ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
### strains by species
strains_by_species <- reactive({
req(sample_info)
sample_info %>%
dplyr::select(species, strain, genotype) %>%
dplyr::group_by(species) %>%
dplyr::summarise(genotype = list(genotype) , strain = list(strain))
})
## Update species on sra sample info table
observe({
req(strains_by_species())
## all species
available_species <- base::unique(strains_by_species()$species)
shinyWidgets::updatePickerInput(session = session,
inputId = "select_species",
choices = available_species,
selected = "Aspergillus nidulans")
})
## get selected species strain
selected_species_strains <- reactive({
req(input$select_species ,strains_by_species())
## strains for selected species
available_strains <- strains_by_species() %>%
dplyr::filter(species == input$select_species) %>%
dplyr::select(strain) %>%
tidyr::unnest(cols = strain) %>%
tidyr::drop_na() %>%
pull(1) %>%
unique() %>%
sort()
return(available_strains)
})
## update strain info
observe({
req(selected_species_strains())
shinyWidgets::updatePickerInput(session = session,
inputId = "select_strain",
choices = selected_species_strains())
})
## reset strain filter
observeEvent(input$reset_strain_filter , {
shinyWidgets::updatePickerInput(session = session,
inputId = "select_strain",
choices = selected_species_strains())
})
## get genotypes for selected species
selected_species_genotype <- reactive({
req(input$select_species ,strains_by_species())
## genotype for selected species
available_genotype <- strains_by_species() %>%
dplyr::filter(species == input$select_species) %>%
dplyr::select(genotype) %>%
tidyr::unnest(cols = genotype) %>%
tidyr::drop_na() %>%
pull(1) %>%
unique() %>%
sort()
return(available_genotype)
})
## update genotype info
observe({
req(selected_species_genotype())
shinyWidgets::updatePickerInput(session = session,
inputId = "select_genotype",
choices = selected_species_genotype())
})
## reset genotype filter
observeEvent(input$reset_genotype_filter , {
shinyWidgets::updatePickerInput(session = session,
inputId = "select_genotype",
choices = selected_species_genotype())
})
## show number of rows selected
user_selected_rows <- reactive({
if(is.null(input$pre_loaded_data_sra_sample_info_rows_selected)){
return(0)
}else{
return(length(input$pre_loaded_data_sra_sample_info_rows_selected))
}
})
## Render text for number of rows selected
output$sra_info_number_of_rows_selected <- renderText(
paste(user_selected_rows() ,"row(s) selected")
)
## Update strain on sra sample info table
user_filters_expressions <- reactive({
u_filters_vals <- c(species = input$select_species,
strain = input$select_strain ,
genotype = input$select_genotype)
u_filters_expr <- lapply(names(u_filters_vals), function(col) {
my_filter(col, "==", value = u_filters_vals[[col]])
})
return(u_filters_expr)
})
## SRA sample info table user display
sra_sample_info_user_display <- reactive({
## add ncbi urls whereever possible
dd <- sample_info %>%
dplyr::filter(!!!user_filters_expressions())
return(dd)
})
## pre loaded data
output$pre_loaded_data_sra_sample_info <- DT::renderDataTable({
return(sra_sample_info_user_display()) #%>%
# dplyr::mutate(run_accession =
# map_chr(run_accession ,
# ~ tags$a( .x, href = paste("https://www.ncbi.nlm.nih.gov/sra/" ,
# .x ,
# sep = "") , target = "blank") %>%
# as.character()
# ))
},
selection = "multiple",
class = "cell-border stripe",
rownames = FALSE,
extensions = c("Buttons"),
server = F,
options = list(
scrollX = TRUE,
dom = "Blfrtip",
autoWidth = TRUE,
searchHighlight = TRUE,
columnDefs = list(
list(width = '700px', targets = c(5, 6,9)), # Fix width columns
list(targets = c(2,3, 8:18), visible = FALSE)# The column number must be identical to the columns in colvis extension
),
buttons =
list("copy",
list(extend = "collection", buttons = c("csv", "excel", "pdf"), text = "Download"),
list(extend = "colvis", columns = c(2,3,8:18))
), # end of buttons customization
lengthMenu = list(
c(10, 20 ,50, 70, 100,500 ) # declare values
, c(10, 20 ,50, 70, 100,500 ) # declare titles
),
pageLength = 10
), ## end of options
)
## reset rows selection in preloaded data sample information
observeEvent(input$deselect_all_rows, {
proxy <- DT::dataTableProxy("pre_loaded_data_sra_sample_info")
DT::selectRows(proxy = proxy, NULL)
})
## select all rows in preloaded data sample information
observe({
#req(pre_loaded_data_sra_sample_info())
proxy = DT::dataTableProxy("pre_loaded_data_sra_sample_info")
if (is.null(input$sra_sample_info_select_all_rows)) {
DT::selectRows(proxy = proxy, NULL)
} else if(input$sra_sample_info_select_all_rows == "TRUE") {
DT::selectRows(proxy = proxy, input$pre_loaded_data_sra_sample_info_rows_all)
}
})
## user selected SRA id sample info
user_selected_sra_id_sample_info <- eventReactive(input$submit_user_sra_samples, {
req(input$pre_loaded_data_sra_sample_info_rows_selected)
selected_rows <- input$pre_loaded_data_sra_sample_info_rows_selected
n_select <- selected_rows %>% length()
n_max_sra_limit <-1000
if(n_select > n_max_sra_limit){
shinyWidgets::sendSweetAlert(session = session ,
type = "warning",
title = "Warning...!!" ,
text = paste("Due to memory limit, current version allows maximum",
n_max_sra_limit,
"samples. You have selected " ,
n_select, "." ,
"Application will continue with first",
n_max_sra_limit, "samples.",
sep = " "))
selected_rows <- selected_rows[1:n_max_sra_limit]
}
## process user applied filter expressions
user_selected_data_sra_ids <- sra_sample_info_user_display() %>%
dplyr::slice(selected_rows)
})
## prepare tibble having sra_id and bioproject_id columns
user_selected_sra_id_to_bioproject_id <- reactive({
user_selected_sra_id_sample_info() %>% dplyr::select(bio_project , run_accession) %>%
dplyr::mutate_all( ~replace_na(. ,"--NA--"))
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## User selected SRA data ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## user selected data
user_selected_sra_id_data <- eventReactive(input$submit_user_sra_samples,{
req(user_selected_sra_id_sample_info() )
## process user applied filter expressions
user_selected_data_sra_ids <- user_selected_sra_id_sample_info()%>%
dplyr::select(23) %>% ## column 23 is Run/SRA id. IMP: change this, if column order in the sample_info table changed.
dplyr::pull(1)
## Objective : load species specific data.
## Reference annotation name of respective species will be used to load species specific data
## 1st step is to get the user reference annotation name (e.g FungiDB-39_AnidulansFGSCA4 for Aspergillus nidulans and FungiDB-39_CalbicansSC5314 for Candida albicans)
## Once reference annotation name obtained, use it to get the respective species expression .rds file name.
## Reference annotations to .rds file name mapping given in the rds object "reference_annotation_to_expr_map.rds"
## once the name of .rds file obtained, load it and get the user selected data
user_selected_species_ref_annot <- sra_sample_info_user_display()%>%
dplyr::select(2) %>% ## column 2 is get the name of ref annot
dplyr::pull(1) %>%
as.character() %>%
.[1]
#ref_annot_to_expr_rds contains two cols ---> 'reference_annotation' , 'expression_mat_data_file'
## load respective expression mat
expr_data_mat_rds_file <- ref_annot_to_expr_rds %>%
dplyr::filter(.data$reference_annotation == !!user_selected_species_ref_annot) %>%
dplyr::select(2) %>% ## 2nd column is expression_mat_data_file
pull(1) %>%
.[1] ### it make sure that if reference annot match to multiple rows, it only returns .rds data mat file for first match.
## load expr data
withProgress(message = "Loadind data from .rds" , {
incProgress(0.5)
#print("expr_mat_file_path")
#print(paste(get_expression_mats_dir_path() , expr_data_mat_rds_file , sep = "/"))
expr_data_mat <- readr::read_rds(paste(get_expression_mats_dir_path() , expr_data_mat_rds_file , sep = "/"))
incProgress(1)
})
user_selected_sra_id_data <- expr_data_mat %>%
dplyr::select(1, !!user_selected_data_sra_ids)
return(user_selected_sra_id_data)
})
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
### display active group info in the in side panel ----
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#observe(group_info,{
callModule(module = display_active_groups_server ,
id = "display_active_groups",
group_data = reactive(group_info)
)
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
### display sample info for user selected sample info in side panel ----
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
observeEvent(user_selected_sra_id_sample_info(),{
req(user_selected_sra_id_sample_info())
callModule(module = display_sra_sample_info_server ,
id = "user_selected_sra_id_sample_info" ,
user_selected_sra_sample_info_tibble = reactive(user_selected_sra_id_sample_info())
)
})
## set output status for sra sample info display on the side panel.
## UI will displayed only if sra samples selected by users
output$display_sra_sample_info_in_side_panel <- reactive({
req(user_selected_sra_id_sample_info())
return(TRUE)
})
outputOptions(x = output , name = "display_sra_sample_info_in_side_panel" , suspendWhenHidden = FALSE)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Process user uploaded data ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## user upoaded data
user_uploaded_data <- eventReactive(input$submit_user_uploaded_data,{
req(input$upload_data_source)
upload_data_source <- input$upload_data_source
data_from_user = tryCatch({
if(upload_data_source == "upload_from_file"){
req(input$file1)
data_from_user <- readr::read_delim(file = input$file1$datapath, delim = input$sep, col_names = T, trim_ws = T)
}else if(upload_data_source == "upload_from_clipboard") {
data_from_user <- text_to_tibble(text = input$user_pasted_data , sep = input$sep)
}
}, error = function(e) {
print(paste("File uploading error." , e, sep = " "))
return(NULL)
} , warning = function(w){
print(paste("File uploaded with warnings." , w, sep = " "))
return(NULL)
})
## show alert/error if error produced while reading file.
if(is.null(data_from_user)){
shinyWidgets::sendSweetAlert(session = session ,type = "error",title = "Error...!!" ,text = paste("Error while reading the data. Probably unsupported file format (if uploaded from file) or uncorrect pasted data.", sep = " "))
return(NULL)
}
## error if first column is not type char
if(!purrr::map_lgl(data_from_user[1], is.character) ){
shinyWidgets::sendSweetAlert(session = session ,type = "error",title = "Error...!!" ,text = paste("First column must be of type character.", sep = " "))
return(NULL)
}
## other than 1st column, all must be of type nueric
if( ! all(purrr::map_lgl(data_from_user[-1], is.numeric)) ){
shinyWidgets::sendSweetAlert(session = session ,type = "error",title = "Error...!!" ,text = paste("Other than first column, all must be of type numeric.", sep = " "))
return(NULL)
}
## column 1 must not have duplicates.
if(any(base::duplicated(data_from_user[[1]]))){
shinyWidgets::sendSweetAlert(session = session ,type = "error" ,title = "Error...!!" ,text = paste("Column 1 must have unique values.", sep = " "))
return(NULL)
}
## uploded data must have atleast two columns
if(base::ncol(data_from_user) < 2){
shinyWidgets::sendSweetAlert(session = session ,type = "error",title = "Error...!!" ,text = paste("Uploaded data must have atleast 2 columns.\n Make sure that you have selected correct separator.", sep = " "))
return(NULL)
}
## remove genes which are 0 in all samples
processed_data <- data_from_user %>%
tidyr::drop_na() %>% ## genes will be dropped if any column contain NA
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
## log2 trasform user uploaded data
if(input$log_transform_user_upload_data == "log2"){
processed_data <- processed_data %>%
dplyr::filter_if(is.numeric , dplyr::any_vars( . > 0)) %>% ## remove genes having negative values (value < 0) in any sample
dplyr::mutate_if(is.numeric , ~(log2( . + 1)))
}
## log10 trasform user uploaded data
if(input$log_transform_user_upload_data == "log10"){
processed_data <- processed_data %>%
dplyr::filter_if(is.numeric , dplyr::any_vars( . > 0)) %>%## remove genes having negative values (value < 0) in any sample
dplyr::mutate_if(is.numeric , ~(log10( . + 1)))
}
## remove na and round the values.
processed_data <- processed_data %>%
dplyr::mutate_if(is.numeric, round, 4) %>% ## 4 digits after decimal
as_tibble() %>%
tidyr::drop_na() ## rows containing NA (after log transform) will be removed
## check the number of rows in the processed data. if number of row remain zero throw error.
if(base::nrow(processed_data) == 0 ){
warning_text <- paste("All genes have value NA after log transformation (if selected) in one of the sample or value 0 in all the samples. Please upload correct data. If log transformation used, make sure that values are non-negative. ")
shinyWidgets::sendSweetAlert(session = session ,
type = "error",
title = "Error...!!" ,
text = warning_text)
return(NULL)
}
## Update alert type depending on number of genes remained after removing NA.
## if number of rows in the processed data less than user uploaded rows, throw warning.
if(base::nrow(processed_data) < base::nrow(data_from_user)){
genes_removed <- dplyr::setdiff(data_from_user[[1]] , processed_data[[1]])
type = "warning"
title = "Data upload with warning...!!!"
numb_of_genes_removed <- base::nrow(data_from_user) - base::nrow(processed_data)
text <- tags$h5(numb_of_genes_removed,
" genes have been removed due to one of the following reasons...",
tags$br(),tags$br(),
"1). Genes have value NA in one of the sample. NA found either directly from uploaded data or due to log transformation (if selected).",
tags$br(),tags$br(),
"2). Genes have value 0 in all the samples.",
tags$br(),tags$br(),
"Removed genes are ...",
tags$br(),tags$br(),
tags$h5(paste0(genes_removed , collapse = ","),
style = "height: 50px;white-space:nowrap;overflow-x:auto;"), style = "text-align:justify;")
## if number of rows in the processed data equal to the user uploaded rows, show success.
} else if(base::nrow(processed_data) == base::nrow(data_from_user)) {
type = "success"
title = "Success...!!!"
text <- paste("Data uploaded successfully.")
}
shinyWidgets::sendSweetAlert(session = session ,
type = type,
title = title ,
text = text )
## column names replace space to "_", this must be applied to groups also when group info uploaded from file
user_uploaded_processed_data <- processed_data %>%
rename_all(function(.){gsub(pattern = " " , "_" , .)})
return(user_uploaded_processed_data)
})
## disable UI elems if upload example data checked on
observe({
if(input$upload_sample_data){
shinyjs::hide(id ="user_data_upload_section")
shinyWidgets::updateProgressBar(session = session , id = "upload_sample_data_pb" , value = 100)
} else {
shinyjs::show(id ="user_data_upload_section")
shinyWidgets::updateProgressBar(session = session , id = "upload_sample_data_pb" , value = 0)
}
## enable disable data upload. at a time either of the upload from file or upload from clipboard will be enabled
if(input$upload_data_source == "upload_from_file"){
shinyjs::enable(id = "file1")
} else{
shinyjs::disable(id = "file1")
}
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Finalize active plot data ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
plot_data <- reactiveVal(NULL)
## when user hit action button on sra sample info page, update plot data.
observeEvent(input$submit_user_sra_samples ,{
req(user_selected_sra_id_data())
final_data <- user_selected_sra_id_data() %>%
tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
if(nrow(final_data) == 0 ){ ## send error if number of rows remained after removing na is 0.
sendSweetAlert(
session = session,
title = "Error...",
text = "All the rows have atleast one missing or NA value found. Input file needs to be fixed.",
type = "error"
)
plot_data(NULL)
}
## display success alert when data uploaded
sendSweetAlert(
session = session,
title = paste(final_data %>% ncol() - 1 , "data selected"),
text = paste("Selected data now available for analysis.\n\nRun accession will be used as identifier for downstream analysis.\n\nClose selection window to use data further.\n\n"),
type = "success"
)
plot_data(final_data)
})
## if user upload the data , make it plot data
observeEvent(user_uploaded_data(),{
req(user_uploaded_data()) ## to execute this user data must be available
final_data <- user_uploaded_data() %>%
tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(final_data)
})
## make plot data to example data when th eaction button input$upload_sample_data triggered
observeEvent(input$upload_sample_data,{
if(input$upload_sample_data){
example_data_file = system.file("app", "cartoon_data" ,"cartoon_log2fpkm_log2fc.txt" ,package = "FungiExpresZ" )
example_data <- readr::read_delim(file = example_data_file , delim = "\t") %>%
tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(example_data)
}
## if input$upload_sample_data == FALSE set NULL
else {
plot_data(NULL)
}
})
## when submit_user_uploaded_data triggered and join data button is on
observeEvent(input$submit_user_uploaded_data,{
req(input$join_user_data, user_uploaded_data()) ## to execute this user data must be available
user_upload_join_by <- colnames(user_uploaded_data())[1]
merge_data <- user_uploaded_data() %>%
dplyr::left_join(user_selected_sra_id_data() , by = set_names("geneName" , user_upload_join_by))
merge_data <- merge_data %>% tidyr::drop_na() ## rows with NA after merger will be removed.
## send warning if number of rows remained after removing na is < user_uploaded_data()
if(merge_data %>% nrow() < user_uploaded_data() %>% nrow() && merge_data %>% nrow() > 0){
sendSweetAlert(
session = session,
title = "Warning...!",
text = paste0("Only ", merge_data %>% nrow(), " out of " , user_uploaded_data() %>% nrow() , " genes matched to database ID. Application will continue with ", merge_data %>% nrow() , " genes."),
type = "warning"
)
final_data <- merge_data %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(final_data)
}
## send warning if number of rows remained after removing na is 0 return user uploaded data
if(nrow(merge_data) == 0 ){
sendSweetAlert(
session = session,
title = "Warning...",
text = "None of the ID from first column of uploaded data match with database id. Either fix the input id or application continue with uploaded data.",
type = "warning"
)
final_data <- user_uploaded_data() %>%
tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(final_data)
}
## send success message if All the IDs from the first column of uploaded data match with database id
if(merge_data %>% nrow() >= user_uploaded_data() %>% nrow()){
sendSweetAlert(
session = session,
title = "Data joined successfully...",
text = "All the IDs from the first column of uploaded data matched with database id.",
type = "success"
)
final_data <- merge_data %>% tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(final_data)
}
})
## print final plot data on terminal
observe({
req(plot_data())
# print("plot_data dims")
# print(dim(plot_data()))
# print("plot_data")
# print(plot_data())
})
## preserve plot data original row order
plot_data_original_row_order <- reactive({
req(plot_data())
orig_row_ord <- plot_data() %>%
dplyr::select(1) %>%
dplyr::mutate(!!generate_random_strings(1) := dplyr::row_number())
return(orig_row_ord)
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Define groups ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
##reactive values containing group info
group_info <- reactiveValues()
## User defined column groups
user_defined_column_groups <- callModule(module = add_sample_group , id = "sample_group" ,
sample_names = reactive(base::colnames(plot_data())[-1]) ,
bioproject_groups = reactive(user_selected_sra_id_to_bioproject_id()))
## Assign user groups to reactive values. Below observe will be executed if user_defined_groups changed
observe({
group_info$column_groups <- user_defined_column_groups()
})
## User defined row groups
user_defined_row_groups <- callModule(module = add_gene_groups , session = session,
id = "gene_groups" ,
gene_names = reactive( plot_data() %>% .[[1]] ))
## Assign user defined row groups
observe({
group_info$row_groups <- user_defined_row_groups()
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Reset UI elems of each plot panel based on data being uploaded or selected from pre-loaded ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
### if no rows selected, remove x/y choices
observe({
# if ((input$data_selection == "select_sample" &
# base::is.null(input$pre_loaded_data_sra_sample_info_rows_selected)) |
# (input$data_selection == "upload_user_data" & base::is.null(input$file1))
# ) {
if(is.null(plot_data())){
## update scatter x
updateSelectInput(
session = session,
inputId = "scatter_x",
choices = character(0)
)
## update scatter y
updateSelectInput(
session = session,
inputId = "scatter_y",
choices = character(0)
)
## update multi scatter x
updateSelectInput(
session = session,
inputId = "multi_scatter_vars",
choices = character(0)
)
## update density x
updateSelectInput(
session = session,
inputId = "density_x",
choices = character(0)
)
## update box x
updateSelectInput(
session = session,
inputId = "box_x",
choices = character(0)
)
## update line x
updateSelectInput(
session = session,
inputId = "lineplot_x",
choices = character(0)
)
## joy plot
updateSelectInput(
session = session,
inputId = "joy_plot_x",
choices = character(0)
)
## heatmap vars
updateSelectInput(
session = session,
inputId = "heatmap_vars",
choices = character(0)
)
## pca plot
updateSelectInput(
session = session,
inputId = "pca_plot_vars",
choices = character(0)
)
## corr heat box
updateSelectInput(
session = session,
inputId = "corr_heatbox_vars",
choices = character(0)
)
## violin
updateSelectInput(
session = session,
inputId = "violin_x",
choices = character(0)
)
## histogram
updateSelectInput(
session = session,
inputId = "histogram_x",
choices = character(0)
)
## bar
updateSelectInput(
session = session,
inputId = "barplot_vars",
choices = character(0)
)
}
### if no file uploaded, remove x/y choices
# if (input$data_selection == "upload_user_data" & base::is.null(input$file1)) {
#
# ## update scatter x
# updateSelectInput(
# session = session,
# inputId = "scatter_x",
# choices = character(0)
# )
#
# ## update scatter y
# updateSelectInput(
# session = session,
# inputId = "scatter_y",
# choices = character(0)
# )
#
# ## update multi scatter x
# updateSelectInput(
# session = session,
# inputId = "multi_scatter_vars",
# choices = character(0)
# )
#
#
# ## update density x
# updateSelectInput(
# session = session,
# inputId = "density_x",
# choices = character(0)
# )
#
# ## update box x
# updateSelectInput(
# session = session,
# inputId = "box_x",
# choices = character(0)
# )
#
# ## update line x
# updateSelectInput(
# session = session,
# inputId = "lineplot_x",
# choices = character(0)
# )
#
# ## joy plot
# updateSelectInput(
# session = session,
# inputId = "joy_plot_x",
# choices = character(0)
# )
#
# ## heatmap vars
# updateSelectInput(
# session = session,
# inputId = "heatmap_vars",
# choices = character(0)
# )
#
# ## pca plot
# updateSelectInput(
# session = session,
# inputId = "pca_plot_vars",
# choices = character(0)
# )
#
# ## corr heat box
# updateSelectInput(
# session = session,
# inputId = "corr_heatbox_vars",
# choices = character(0)
# )
#
# ## violin
# updateSelectInput(
# session = session,
# inputId = "violin_x",
# choices = character(0)
# )
# ## histogram
# updateSelectInput(
# session = session,
# inputId = "histogram_x",
# choices = character(0)
# )
#
# ## bar
# updateSelectInput(
# session = session,
# inputId = "barplot_vars",
# choices = character(0)
# )
#
#
# }
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Fix reference annotations ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
genome_for_annotations <- reactiveVal(NULL)
## reference annot when user choose SRA data
observeEvent(input$submit_user_sra_samples , {
#if(input$data_selection == "select_sample"){ ## when data selected from existing one
req(input$pre_loaded_data_sra_sample_info_rows_selected)
genome_for_annotations <- sample_info %>% ## sample_info is pre loaded data
dplyr::filter(!!!user_filters_expressions()) %>% ## filter by user applied filters
dplyr::select(2) %>% ## column 2 is reference_annotation columns. it contains genome name identical to fungidb annotations. IMP: change this, if column order in the sample_info table changed.
dplyr::slice(input$pre_loaded_data_sra_sample_info_rows_selected)%>% ## user selected rows
dplyr::pull(1)
genome_for_annotations(genome_for_annotations[1])
})
## reference annot when user upload data or select example data
observe({
genome_for_annotations(input$user_selected_species)
if(input$upload_sample_data){
genome_for_annotations("FungiDB-64_CalbicansSC5314")
}
})
## Check current annotations
observe({
req(genome_for_annotations())
#print(paste("User selected geneome", genome_for_annotations() ,sep = " "))
})
## For selected genome sample ids
output$sample_selected_species_gene_id <- renderText({
req(genome_for_annotations())
sample_ids_to_display <- tryCatch({
ah_data_summary2 %>%
dplyr::filter(genome == genome_for_annotations()) %>%
dplyr::select(gr_cols) %>%
tidyr::unnest(cols = gr_cols) %>%
dplyr::pull(ID) %>% sample(20) %>% paste0(collapse = ", ")
}, error = function(x){
return("Trouble to get Ids")
})
return(sample_ids_to_display)
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# scatter plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
## Question : Both evenReactive and observeEvent can be invalidated by action button.
## Then, why am I using eventReactive here ? Why not observeEvent ??
## Ans :: eventReactive is there to delay the reactions. Given the reactive value, it triggers the chunk of code and
## return some values, which can be cached and used further in the app. While, observeEvent is also there to trigger the action
## on the basis of given reactive values but it does not return anything. It has side effects. Side effects are the actions due
## to functions but without returning anything.
## check whether x and y are numeric type
scatter_vars_validated <- eventReactive(input$generate_scatter, {
req(input$scatter_x, input$scatter_y, plot_data())
x_vals <- plot_data()[, input$scatter_x][[1]]
y_vals <- plot_data()[, input$scatter_y][[1]]
## validate user selected variables
if (!is.numeric(x_vals)) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = "X must be of type numeric",
type = "error"
)
return(FALSE)
} else if (!is.numeric(y_vals)) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = "Y must be of type numeric",
type = "error"
)
return(FALSE)
}
return(TRUE)
})
## update plot axis limits, reason to use observe event is,
## it won't cache the values in the computer memory. Whenever user clicks on "Generate Plot" (input$plot) invalidated
## the axis limits will be updated.
observeEvent(input$generate_scatter, {
req(scatter_vars_validated())
# selected x y cols
x_vals <- plot_data()[, input$scatter_x][[1]]
y_vals <- plot_data()[, input$scatter_y][[1]]
# calculate axis limits
# xlim
x_range <- round(range(x_vals), 3)
# ylim
y_range <- round(range(y_vals), 3)
# update UI
# X min and max
updateNumericInput(
session = session,
inputId = "plot_xmin",
min = x_range[1],
max = x_range[2],
value = x_range[1]
)
updateNumericInput(
session = session,
inputId = "plot_xmax",
min = x_range[1],
max = x_range[2],
value = x_range[2]
)
# Y min and max
updateNumericInput(
session = session,
inputId = "plot_ymin",
min = y_range[1],
max = y_range[2],
value = y_range[1]
)
updateNumericInput(
session = session,
inputId = "plot_ymax",
min = y_range[1],
max = y_range[2],
value = y_range[2]
)
})
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "scatter_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
## update y
updatePickerInput(
session = session,
inputId = "scatter_y",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## scatter plot user selected gene group data
scatter_plot_data <- callModule(module = gene_group_selection ,
id = "scatter_plot_select_gene_groups" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_scatter),
current_session_data_matrix = plot_data)
### current scatter plot genome, updates only when generate scatter hits.
current_scatter_plot_genome <- eventReactive(input$generate_scatter , {
return(genome_for_annotations())
})
## get scatter plot elements : corr value, density, intercept , slope and base ggplot
scatter_plot_elems <- eventReactive(input$generate_scatter, {
req(scatter_plot_data())
xvar <- scatter_plot_data() %>% dplyr::pull(input$scatter_x)
yvar <- scatter_plot_data() %>% dplyr::pull(input$scatter_y)
# linear model param
mm <- lm(formula = yvar ~ xvar)
linear_model_param <- broom::tidy(mm)
# calculte corr value
xvar <- scatter_plot_data() %>% dplyr::pull(input$scatter_x)
yvar <- scatter_plot_data() %>% dplyr::pull(input$scatter_y)
corr <- cor(xvar, yvar)
scatter_xy_corr <- format(round(corr, 3), nsmall = 2) ## restric digits after decimal
# calculate density
x_y_density <- get_density(scatter_plot_data()[, input$scatter_x][[1]], scatter_plot_data()[, input$scatter_y][[1]])
# xy scatter plot
gp <- ggplot(scatter_plot_data(), aes_string(x = as.symbol(input$scatter_x), y = as.symbol(input$scatter_y)))
gff_feat = ah_data_summary2 %>%
dplyr::filter(genome == current_scatter_plot_genome()) %>%
dplyr::select(gr_cols) %>%
tidyr::unnest(cols = gr_cols)
return(list(linear_model_param = linear_model_param,
scatter_xy_corr = scatter_xy_corr, gp = gp,
x_y_density = x_y_density,
gff_feat = gff_feat))
})
# observe({
# req(scatter_plot_data())
# #print(scatter_plot_data())
# })
## scatterplot condition panel:show only if variable (x, y) validated and displayed on UI
output$scatter_plot_status <- reactive({
req(final_scatter())
return(TRUE)
})
outputOptions(output, "scatter_plot_status", suspendWhenHidden = FALSE)
## final scatter plot
final_scatter <- reactive({
req(scatter_vars_validated() , scatter_plot_elems() ,
input$plot_xmin, input$plot_xmax,input$plot_ymin, input$plot_ymax
)
# req(input$plot_xmax,input$plot_xmin) ## all four xmin, xmax, ymin and ymax must be there to generate the plot
withProgress(message = "Preparing scatter plot", {
incProgress(0.5)
## color by density, default colors
if (input$scatter_color_chooser == "default") {
gp <- scatter_plot_elems()$gp +
geom_point(aes(color = scatter_plot_elems()$x_y_density),
alpha = input$scatter_alpha , size= input$scatter_point_size) +
viridis::scale_color_viridis()
}
## color by density, user defined colors
if (input$scatter_color_chooser == "manual") {
gp <- scatter_plot_elems()$gp +
geom_point(aes(color = scatter_plot_elems()$x_y_density), alpha = input$scatter_alpha , size= input$scatter_point_size) +
scale_color_gradientn(colours = c(input$scatter_col_low, input$scatter_col_medium, input$scatter_col_high))
}
## color by genesets , default colors
if (input$scatter_color_chooser == "by_gene_groups") {
gp <- scatter_plot_elems()$gp +
geom_point(aes(color = gene_groups), alpha = input$scatter_alpha , size= input$scatter_point_size) +
scale_color_discrete()
}
# real time change of axis limits.
gp <- gp +
xlim(input$plot_xmin, input$plot_xmax) +
ylim(input$plot_ymin, input$plot_ymax)
## default plot title
gp <- callModule(module = plot_title_and_axis_label_server ,
id = "scatter_plot_title_and_labels",
my_ggplot = gp ,
plot_title = base::paste("Pearson correlation:",
scatter_plot_elems()$scatter_xy_corr, sep = ""),
axis_x_title = shiny::isolate(input$scatter_x),
axis_y_title = shiny::isolate(input$scatter_y),
x_tick_angle = 0,
color_legend_title = ifelse(input$scatter_color_chooser == "by_gene_groups" , "Groups", "Density")
)
## add / remove regression line
if (input$scatter_diagonal_line == "manual") {
gp <- gp + geom_abline(slope = input$manual_slope, intercept = input$manual_intercept)
}
if (input$scatter_diagonal_line == "from_data") {
i_cept <- scatter_plot_elems()$linear_model_param %>% dplyr::filter(term == "(Intercept)") %>% pull(estimate)
slope <- scatter_plot_elems()$linear_model_param %>% dplyr::filter(term == "xvar") %>% pull(estimate)
gp <- gp + geom_abline(intercept = i_cept, slope = slope )
}
incProgress(1)
})
return(gp)
})
## render scatter plot
output$scatter_plot <- renderPlot({
req(final_scatter())
final_scatter()
},
height = function() {
return(session$clientData$output_scatter_plot_width) ## dynamic height
},
width = function() {
return(session$clientData$output_scatter_plot_width) ## dynamic height
}, res = 96
) ## dynamic resolution
## render corr value
output$scatter_xy_corr <- renderText({
return(scatter_plot_elems()$scatter_xy_corr)
})
## brush table for scatter plot
scatter_plot_brushed_points <- eventReactive(input$plot_brush, {
req(scatter_plot_data())
scatter_plot_brushed_points <- brushedPoints(
df = scatter_plot_data(),
brush = input$plot_brush,
xvar = scatter_plot_elems()$gp$labels$x, #input$scatter_x
yvar = scatter_plot_elems()$gp$labels$y
)
#map metadata info to geneNames
join_col_x <- base::colnames(scatter_plot_brushed_points)[1] ## first column containing geneNames
join_col_y <- base::colnames(scatter_plot_elems()$gff_feat)[7] ## "id" column
display_data <- scatter_plot_brushed_points %>%
left_join(scatter_plot_elems()$gff_feat, by = setNames(join_col_y, join_col_x)) %>%
dplyr::select(1,c("seqnames", "start", "end","width", "strand", "description"), dplyr::everything())
return(display_data)
})
## render brushed data
output$brush_table <- DT::renderDataTable({
req(scatter_plot_brushed_points())
return(scatter_plot_brushed_points() %>%
dplyr::mutate_all(funs(replace_na(as.character(.),"--NA--"))) %>%
dplyr::mutate_if(is.numeric , round , 2))
},selection = "none",
server = F,
extensions = c("Buttons"),
options = list(
deferRender = TRUE,
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy",
list(extend ="collection",
buttons = c("csv", "excel", "pdf"), text = "Download"
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500 ) # declare values
, c(10, 50, 100, 500) # declare titles
),
pageLength = 10
)
)
## call module to download scatter plot
callModule(module = export_plot,
id = "export_scatter",
file_name = "scatter",
plot = final_scatter
)
## call module for scatter plot functional analysis
callModule(module = functional_analysis_server ,
id = "scatterplot_functional_analysis_ui" ,
ui_id = "scatterplot_functional_analysis_ui",
session = session,
gene_set = reactive(split(x = scatter_plot_brushed_points()[[1]], ## genename
f = "1")) ,
genome = reactive(genome_for_annotations()) )
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# multi scatter plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## check whether x and y are numeric type
multi_scatter_vars_validated <- eventReactive(input$generate_multi_scatter, {
req(input$multi_scatter_vars)
selected_vars <- plot_data() %>% dplyr::select(input$multi_scatter_vars)
col_class <- plot_data() %>%
dplyr::select(input$multi_scatter_vars) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather()
if (!all(col_class$value)) {
non_numeric_cols <- col_class %>% dplyr::filter(!value)
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0(paste0(non_numeric_cols$key, collapse = " "), " must be of type numeric", collapse = ""),
type = "error"
)
return(FALSE)
}
if (length(input$multi_scatter_vars) > 5) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Due to memory limit, maximum 5 variables allowed at moment. Try CorrHeatBox for more than 5 variables."),
type = "error"
)
return(FALSE)
}
else {
return(TRUE)
}
})
## multi scatterplot condition panel:show only if variable (x, y) validated and displayed on UI
output$multi_scatter_plot_status <- reactive({
req(final_multi_scatter_plot())
return(TRUE)
})
outputOptions(output, "multi_scatter_plot_status", suspendWhenHidden = FALSE)
## update x variables
observe({
req(plot_data())
## update x
updatePickerInput(
session = session,
inputId = "multi_scatter_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## multi scatter plot user selected gene group data
multi_scatter_plot_data <- callModule(module = gene_group_selection ,
id = "multi_scatter_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_multi_scatter),
current_session_data_matrix = plot_data
)
## prepare multi scatter plot
ggpair_plot <- eventReactive(input$generate_multi_scatter, {
req(multi_scatter_plot_data() , multi_scatter_vars_validated())
gp <- GGally::ggpairs(multi_scatter_plot_data(),
columns = c(input$multi_scatter_vars),
upper = list(continuous = GGally::wrap("cor",
size = input$multi_scatter_corr_text_text_size ,
color = input$multi_scatter_corr_text_col)))
return(gp)
})
## multi scatter final plot
final_multi_scatter_plot <- reactive({
req(ggpair_plot())
multi_scatter_gp <- ggpair_plot()
## decorate multi scatter through module
multi_scatter_gp <- callModule(module = plot_title_and_axis_label_server ,
id = "multi_scatter_plot_title_and_labels" ,
my_ggplot = multi_scatter_gp ,
axis_x_title = "Value" ,
axis_y_title = "Value",
x_tick_angle = 0 ,
aspect_ratio =NULL)
return(multi_scatter_gp)
})
output$multi_scatter_plot <- renderPlot({
req(final_multi_scatter_plot())
return(
withProgress(message = "Display multi-scatter plot in progress",{
incProgress(0.5)
print(final_multi_scatter_plot())
incProgress(1)
})
)
},
height = function() {
return(session$clientData$output_multi_scatter_plot_width)
}, ## dynamic height
width = function() {
return(session$clientData$output_multi_scatter_plot_width)
}
) ## dynamic width
## call module to export multi scatter plot
callModule(module = export_plot,
id = "export_multi_scatter" ,
file_name = "multi_scatter_plot",
plot = final_multi_scatter_plot )
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# CorrHeatBox server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "corr_heatbox_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## check whether selected x var(s) are of numeric type
corr_heatbox_vars_validated <- eventReactive(input$generate_corr_heatbox, {
req(input$corr_heatbox_vars)
## validate selected variables
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$corr_heatbox_vars)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## corr_heatbox status
output$corr_heatbox_status <- reactive({
req(final_corr_heatbox())
return(TRUE)
})
outputOptions(output, "corr_heatbox_status", suspendWhenHidden = FALSE)
## corr heat box user selected gene group data
corr_heatbox_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "corr_heat_box_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_corr_heatbox),
current_session_data_matrix = plot_data
)
## prepare corr_heatbox data
corr_heatbox_data <- eventReactive(input$generate_corr_heatbox, {
req(input$corr_heatbox_vars, corr_heatbox_vars_validated() , corr_heatbox_user_selected_gene_group_data())
withProgress(message = "Preparing CorrHeatBox " , {
incProgress(0.5)
## tibble to data.frame with row names
corr_heatbox_data <- corr_heatbox_user_selected_gene_group_data() %>%
dplyr::select(1,c(input$corr_heatbox_vars)) %>%
as.data.frame() %>%
tibble::column_to_rownames(colnames(corr_heatbox_user_selected_gene_group_data())[1])
## calculate correlation
corr_mat <- tryCatch({
cor_mat <- stats::cor(corr_heatbox_data)
},error = function(e){
return(NULL)
})
incProgress(1)
})
return(corr_mat)
})
## show error if corr data is NULL
observe({
if(is.null(corr_heatbox_data())){
shinyWidgets::sendSweetAlert(session = session,title = "Error..!",
text = "Error while calculating correlation (stats::cor). Please check the data.")
}
})
## final corrHeatBox
final_corr_heatbox <- reactive({
req(corr_heatbox_data())
chb <- tryCatch({
chb <- ggcorrplot::ggcorrplot(corr = corr_heatbox_data() ,
method = input$heatbox_method ,
type = input$heatbox_type,
hc.order = input$cluster_heatbox,
show.diag = as.logical(input$heatbox_show_diag),
lab_col = input$heatbox_corr_text_col ,
lab_size = input$heatbox_corr_text_text_size,
lab = input$heatbox_show_corr_value
)
},error = function(e){
return(NULL)
})
## return NULL (at function) if ggcorrplot::ggcorrplot throws an error
if(is.null(chb)){
return(NULL)
}
## set color scale auto:
if(input$corr_heatbox_scale_manual == "auto"){
chb <- chb +
scale_fill_gradientn(colours = viridis::viridis(n = input$corr_heatbox_colors) %>% rev())
}
## set color scale manual
if(input$corr_heatbox_scale_manual == "manual"){
chb <- chb +
scale_fill_gradientn(colours = viridis::viridis(n = input$corr_heatbox_colors) %>% rev(),
limits = c(input$corr_heatbox_scale_manual_min , input$corr_heatbox_scale_manual_max) , oob=scales::squish)
}
## decorate plot
chb <- callModule(plot_title_and_axis_label_server,
id = "corr_heatbox_title_and_labels" ,
my_ggplot = chb, x_tick_angle = 45 ,
fill_legend_title = "Corr",
apply_theme =FALSE)
return(chb)
})
## show error if corr data is NULL
observe({
if(is.null(final_corr_heatbox())){
shinyWidgets::sendSweetAlert(session = session,title = "Error..!",
type = "error",
text = "Error while generating corr plot (ggcorrplot::ggcorrplot). Make sure that you selected at least two samples or else check input data.")
}
})
## render corr_heatbox
output$corr_heatbox <- renderPlot({
req(final_corr_heatbox())
return(print(final_corr_heatbox()))
}, height = function() {
return(session$clientData$output_corr_heatbox_width)
}, width = function() {
return(session$clientData$output_corr_heatbox_width)
}, res = 90)
## render corr heat box data
output$corr_heatbox_data <- DT::renderDataTable({
req(corr_heatbox_data())
return(corr_heatbox_data() %>%
as.data.frame() %>%
rownames_to_column("RowNames") %>%
as_tibble() %>%
dplyr::mutate_if(is.numeric, function(i){round(i,2)}))
},selection = "none",
server = F,
extensions = "Buttons",
options = list(
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy",
list(extend ="collection",
buttons = c("csv", "excel", "pdf"), text = "Download"
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500, -1) # declare values
, c(10, 50, 100, 500, "All") # declare titles
),
pageLength = 10
)
)
## export corr heat box
callModule(module = export_plot,
id = "export_corr_heatbox" ,
file_name = "corr_heatbox",
plot = final_corr_heatbox )
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# density plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "density_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## check whether selected x var(s) are of numeric type
density_vars_validated <- eventReactive(input$generate_density, {
req(input$density_x)
## validate selected variables
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$density_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## density plot status
output$density_plot_status <- reactive({
req(final_density_plot())
return(TRUE)
})
outputOptions(output, "density_plot_status", suspendWhenHidden = FALSE)
## density plot user selected gene group data
density_plot_data <- callModule(module = gene_group_selection ,
id = "density_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_density),
current_session_data_matrix = plot_data
)
## density plot
dp <- eventReactive(input$generate_density, {
req(density_plot_data() , density_vars_validated())
withProgress(message = "Preparing density plot" , {
incProgress(0.5)
plot_data <- density_plot_data() %>%
dplyr::select(c(input$density_x , !!as.symbol("gene_groups")))
melted <- plot_data %>%
tidyr::gather(samples, value , -gene_groups) %>%
left_join(group_info$column_groups , by = c (samples = "group_members")) %>% ## addd sample groups
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::arrange(groups , samples)%>%
dplyr::mutate(samples = forcats::fct_inorder(samples))
incProgress(1)
})
## base density plot
dp <- ggplot(melted, aes(x = value, fill = samples))
return(dp)
})
## final density plot
final_density_plot <- reactive({
## dynamic alpha
req(dp())
dp <- dp() + geom_density(alpha = input$density_plot_alpha) #+ theme_bw()
## fill and facet density plot
out <- callModule(module = ggplot_fill_and_facet ,
id = "density_plot_fill_and_facet" ,
ggplot = dp , allow_x_var_selection = FALSE)
dp <- out$plot
## decorate plot
dp <- callModule(plot_title_and_axis_label_server ,
id = "decorate_density_plot" ,
my_ggplot = dp ,
axis_x_title = "Value",
x_tick_angle = 0,
axis_y_title = "Density",
fill_legend_title = out$fill_var,
color_legend_title = out$fill_var
)
return(dp)
})
## render density plot
output$density_plot <- renderPlot({
return(print(final_density_plot()))
}, height = function() {
return(session$clientData$output_density_plot_width)
}, width = function() {
return(session$clientData$output_density_plot_width)
}, res = 90)
## prepare density plot data to be shown as table
density_filtered_column <- eventReactive(dp(), {
dd <- plot_data()
return(dd)
})
## render density plot data
output$density_filtered_column_display <- DT::renderDataTable({
return(density_filtered_column())
})
callModule(module = export_plot, id = "export_density" , file_name = "density_plot", plot = final_density_plot )
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# histogram server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "histogram_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## check whether selected x var(s) are of numeric type
histogram_vars_validated <- eventReactive(input$generate_histogram, {
req(input$histogram_x)
## validate selected variables
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$histogram_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## histogram status
output$histogram_status <- reactive({
req(final_histogram())
return(TRUE)
})
outputOptions(output, "histogram_status", suspendWhenHidden = FALSE)
## get histogram gene group specific data
histogram_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "histogram_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_histogram),
current_session_data_matrix = plot_data)
## histogram
hg <- eventReactive(input$generate_histogram, {
req(input$histogram_x, histogram_vars_validated() , histogram_user_selected_gene_group_data())
withProgress(message = "Preparing histogram" , {
incProgress(0.5)
plot_data <- histogram_user_selected_gene_group_data() %>%
dplyr::select(c(input$histogram_x , !!as.symbol("gene_groups")))
melted <- plot_data %>%
tidyr::gather(samples, value , -gene_groups) %>%
left_join(group_info$column_groups , by = c (samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::arrange(groups , samples)%>%
dplyr::mutate(samples = forcats::fct_inorder(samples))
incProgress(1)
})
hg <- ggplot(melted, aes(x = value, fill = samples, col = samples))
return(hg)
})
## final histogram
final_histogram <- reactive({
## dynamic alpha
req(hg())
hg <- hg() + geom_histogram(alpha = input$histogram_alpha ,
position = input$histogram_positions ,
bins = input$histogram_number_of_bins , col ="black")
## fill and facet histogram
out <- callModule(module = ggplot_fill_and_facet ,
id = "histogram_fill_and_facet" ,
ggplot = hg , allow_x_var_selection = FALSE)
hg <- out$plot
## decorate plot
hg <- callModule(plot_title_and_axis_label_server ,
id = "decorate_histogram" ,
my_ggplot = hg ,
axis_x_title = "Value",
x_tick_angle = 0,
axis_y_title = "Count",
fill_legend_title = out$fill_var,
color_legend_title = out$fill_var
)
## remove legend title
return(hg)
})
## render histogram
output$histogram <- renderPlot({
return(print(final_histogram()))
}, height = function() {
return(session$clientData$output_histogram_width)
}, width = function() {
return(session$clientData$output_histogram_width)
}, res = 90)
callModule(module = export_plot, id = "export_histogram" , file_name = "histogram", plot = final_histogram)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Joy plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "joy_plot_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## check whether selected x var(s) are of numeric type
joy_plot_vars_validated <- eventReactive(input$generate_joy_plot, {
req(input$joy_plot_x)
## validate selected variables
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$joy_plot_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## multi scatterplot condition panel:show only if variable (x, y) validated and displayed on UI
output$joy_plot_status <- reactive({
req(final_joy_plot())
return(TRUE)
})
outputOptions(output, "joy_plot_status", suspendWhenHidden = FALSE)
## joy plot user selected gene group data
joy_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "joy_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_joy_plot),
current_session_data_matrix = plot_data)
## joy plot
ggjoy_plot <- eventReactive(input$generate_joy_plot, {
req(input$joy_plot_x, joy_plot_vars_validated() , joy_plot_user_selected_gene_group_data())
plot_data <- joy_plot_user_selected_gene_group_data() %>%
dplyr::select(c(input$joy_plot_x) , gene_groups) %>%
tidyr::gather(samples, value , -gene_groups) %>%
left_join(group_info$column_groups , by = c(samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::mutate(samples = forcats::fct_inorder(samples)) %>% ## preserve original order
dplyr::mutate(groups = forcats::fct_inorder(groups))# %>%
ggjoy_plot <- ggplot(plot_data) + aes(x = value)
return(ggjoy_plot)
})
## final joy plot
final_joy_plot <- reactive({
req(ggjoy_plot())
## fill and facet
ggjoy_plot <- ggjoy_plot()
out <- callModule(module = joyplot_fill_and_facet , id = "joy_plot_fill_and_facet" , joyplot = ggjoy_plot)
ggjoy_plot <- out$plot
withProgress(message = "Preparing joy plot",{
incProgress(0.5)
ggjoy_plot <- ggjoy_plot +
scale_x_continuous(expand = c(0.01, 0)) +
scale_y_discrete(expand = c(0.01, 0)) #+
#theme_bw()
## decorate joy plot
ggjoy_plot <- callModule(plot_title_and_axis_label_server ,
id = "decorate_joy_plot" ,
my_ggplot = ggjoy_plot ,
axis_x_title = ggjoy_plot$mapping$x %>% rlang::quo_text(),
axis_y_title = ggjoy_plot$mapping$y %>% rlang::quo_text(),
x_tick_angle = 0,
fill_legend_title = out$fill_var)
incProgress(1)
})
return(ggjoy_plot)
})
## render density plot
output$joy_plot <- renderPlot({
## dynamic alpha
req(final_joy_plot())
return(print(final_joy_plot()))
}, height = function() {
return(session$clientData$output_joy_plot_width)
}, width = function() {
return(session$clientData$output_joy_plot_width)
}, res = 90)
callModule(module = export_plot , id = "export_joy_plot" , file_name = "joy_plot" , plot = final_joy_plot)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# box plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update box plot variables
observeEvent(plot_data(), {
updatePickerInput(
session = session,
inputId = "box_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## validate boxplot selected variables
box_vars_validated <- eventReactive(input$generate_box, {
req(input$box_x)
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$box_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## boxplot condition panel : show only if selected variable(s) validated and displayed on UI
output$box_plot_status <- reactive({
req(final_box_plot())
return(TRUE)
})
outputOptions(output, "box_plot_status", suspendWhenHidden = FALSE)
## box plot user selected gene group data
box_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "box_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_box),
current_session_data_matrix = plot_data)
## box plot
boxplt <- eventReactive(input$generate_box, {
req(input$box_x , box_vars_validated() , box_plot_user_selected_gene_group_data())
box_plot_data <- box_plot_user_selected_gene_group_data() %>%
dplyr::select(c(input$box_x , "gene_groups")) %>%
tidyr::gather(key = samples , value = value , -gene_groups) %>%
dplyr::left_join(group_info$column_groups , by = c(samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::mutate(samples = forcats::fct_inorder(samples)) %>%
dplyr::mutate(groups = forcats::fct_inorder(groups))# %>%
## base plot
bp <- ggplot(box_plot_data)
return(bp)
})
final_box_plot <- reactive({
req(boxplt())
withProgress(message = "Preparing box plot" , {
incProgress(0.5)
boxplt <- boxplt()
## y axis and alpha
boxplt <- boxplt + geom_boxplot(alpha = input$box_plot_alpha) +
aes(y = value)
## fill and facet box plot
out <- callModule(module = ggplot_fill_and_facet ,
id = "box_plot_fill_and_facet" ,
ggplot = boxplt)
boxplt <- out$plot
# dynamic display pvalue
if (input$box_plot_pvalue == "TRUE") {
box_x_var_type <- boxplt$data %>%
dplyr::pull(!!boxplt$mapping$x) %>%
unique() %>% as.character()
if(length(box_x_var_type) >= 2){
all_combin <- combn(box_x_var_type, 2, simplify = F)
boxplt <- boxplt +
ggpubr::stat_compare_means(comparisons = all_combin,
method = input$box_plot_pval_method)
}
}
## box plot dots
if(input$box_plot_show_dots %>% as.logical()){
boxplt <- boxplt + geom_jitter(width = input$boxplot_dots_width , color = input$boxplot_dots_color , alpha = input$boxplot_dots_transprancy)
}
## decorate box plot
boxplt <- callModule(module = plot_title_and_axis_label_server ,
id = "box_plot_label_and_title",
my_ggplot = boxplt,
axis_x_title = boxplt$mapping$x %>% rlang::quo_text(),
axis_y_title = boxplt$mapping$y %>% rlang::quo_text(),
fill_legend_title = boxplt$mapping$fill %>% rlang::quo_text(),
x_tick_angle = 90,
)
incProgress(1)
})
return(boxplt)
})
## render boxplot
output$box_plot <- renderPlot({
req(final_box_plot())
return(print(final_box_plot()))
}, height = function() {
return(session$clientData$output_box_plot_width)
}, width = function() {
return(session$clientData$output_box_plot_width)
}, res = 96)
## export box plot
callModule(module = export_plot , id = "export_box_plot" , file_name = "box_plot" ,plot = final_box_plot)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# violin plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update violin plot variables
observeEvent(plot_data(), {
updatePickerInput(
session = session,
inputId = "violin_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## validate violin plot selected variables
violin_vars_validated <- eventReactive(input$generate_violin, {
req(input$violin_x)
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$violin_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## violin plot condition panel : show only if selected variable(s) validated and displayed on UI
output$violin_plot_status <- reactive({
req(final_violin_plot())
return(TRUE)
})
outputOptions(output, "violin_plot_status", suspendWhenHidden = FALSE)
## violin plot data
violin_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "violin_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_violin),
current_session_data_matrix = plot_data)
## violin plot
violinplt <- eventReactive(input$generate_violin, {
req(input$violin_x , violin_vars_validated() , violin_plot_user_selected_gene_group_data())
violin_plot_data <- violin_plot_user_selected_gene_group_data() %>%
dplyr::select(c(input$violin_x) , gene_groups) %>%
tidyr::gather(key = samples , value = value , -gene_groups) %>%
left_join(group_info$column_groups , by = c(samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::mutate(samples = forcats::fct_inorder(samples)) %>%
dplyr::mutate(groups = forcats::fct_inorder(groups))# %>%
## fill violin plot by variable, default
vp <- ggplot(violin_plot_data)
return(vp)
})
final_violin_plot <- reactive({
req(violinplt())
withProgress(message = "Preparing violin plot" , {
incProgress(0.5)
violin_plot_vars <- isolate(input$violin_x)
violinplt <- violinplt()
#violinplt <- violinplt + aes(x = samples, y = value , fill = samples )
## y axis and alpha
violinplt <- violinplt +
geom_violin(alpha = input$violin_plot_alpha , draw_quantiles = c(input$violin_show_quantile))+
aes(y = value)
# # dynamic fill and alpha
# violinplt <- violinplt +
# geom_violin(alpha = input$violin_plot_alpha , draw_quantiles = c(input$violin_show_quantile))
#
#
## fill and facet violin plot
out <- callModule(module = ggplot_fill_and_facet ,
id = "violin_plot_fill_and_facet" ,
ggplot = violinplt)
violinplt <- out$plot
# dynamic display pvalue
if (input$violin_plot_pvalue == "TRUE") {
violin_x_var_type <- violinplt$data %>%
dplyr::pull(!!violinplt$mapping$x) %>%
unique() %>% as.character()
if(length(violin_x_var_type) >= 2){
all_combin <- combn(violin_x_var_type, 2, simplify = F)
violinplt <- violinplt +
ggpubr::stat_compare_means(comparisons = all_combin, method = input$violin_plot_pval_method)
}
}
# decorate box plot
violinplt <- callModule(module = plot_title_and_axis_label_server ,
id = "violin_plot_label_and_title",
my_ggplot = violinplt,
axis_x_title = violinplt$mapping$x %>% rlang::quo_text(),
axis_y_title = violinplt$mapping$y %>% rlang::quo_text(),
x_tick_angle = 90,
fill_legend_title = violinplt$mapping$fill %>% rlang::quo_text()
)
incProgress(1)
})
return(violinplt)
})
## render violine
output$violin_plot <- renderPlot({
req(final_violin_plot())
return(print(final_violin_plot()))
}, height = function() {
return(session$clientData$output_violin_plot_width)
}, width = function() {
return(session$clientData$output_violin_plot_width)
}, res = 96)
## export box plot
callModule(module = export_plot , id = "export_violin_plot" , file_name = "violin_plot" ,plot = final_violin_plot)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# bar plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update bar plot variables
observeEvent(plot_data(), {
updatePickerInput(
session = session,
inputId = "barplot_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## update bar plot genes
observeEvent(plot_data(), {
updatePickerInput(
session = session,
inputId = "barplot_select_genes",
choices = plot_data() %>% dplyr::pull(1), ## first column is gene name
selected = plot_data() %>% dplyr::pull(1) %>% .[1]
)
})
## validate barplot selected variables
barplot_vars_validated <- eventReactive(input$generate_barplot, {
req(input$barplot_vars)
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$barplot_vars)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## barplot condition panel : show only if selected variable(s) validated and displayed on UI
output$barplot_status <- reactive({
req(final_barplot())
return(TRUE)
})
outputOptions(output, "barplot_status", suspendWhenHidden = FALSE)
## barplot
barplot <- eventReactive(input$generate_barplot, {
req(input$barplot_vars , barplot_vars_validated(),input$barplot_select_genes)
barplot_data <- plot_data() %>%
dplyr::rename_at(1 , funs(return("GeneNames"))) %>%## set first column name as geneNames
dplyr::select(1, c(input$barplot_vars)) %>%
dplyr::filter(GeneNames %in% input$barplot_select_genes) %>%
tidyr::gather(key = samples , value = value , -GeneNames) %>%
left_join(group_info$column_groups , by = c(samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::mutate(samples = forcats::fct_inorder(samples)) %>% ## order by first appearance
dplyr::mutate(groups = forcats::fct_inorder(groups))# %>% ## order by first appearance
## if user groups uploaded chunk below make sure that order in each group is as per user uploaded samples
if(TRUE){ ## original (user supplied) sample order
barplot_data <- barplot_data %>%
dplyr::mutate(samples = forcats::fct_relevel(samples ,group_info$column_groups %>% pull(2) %>%
as.character() %>% unique() )) #%>% ## order by group members
}
if(TRUE){ ## original (user supplied) column group order
barplot_data <- barplot_data %>%
dplyr::mutate(groups = forcats::fct_relevel(groups ,group_info$column_groups %>% pull(1) %>%
as.character() %>% unique()))
}
## barplot base ggplot
barplot <- ggplot(barplot_data)
return(barplot)
})
final_barplot <- reactive({
req(barplot())
withProgress(message = "Preparing bar plot" , {
incProgress(0.5)
barplot <- barplot()
## current bar plot data
current_bar_plot_data <- barplot$data
## dynamic color aesthatic (color_by_var) is opposite to x axis aesthatic.
## can be one of the : samples or GeneNames. is the gene column is always named as GeneName ?
color_by_var <- ifelse(input$barplot_xaxis_choices == "samples" , "GeneNames" , "samples")
barplot <- barplot +
geom_col(aes(x = !!as.symbol(input$barplot_xaxis_choices),
y = value , col = !!(as.symbol(color_by_var)) ) , position = "dodge" ,
alpha = input$barplot_alpha) +
scale_color_manual(breaks = current_bar_plot_data[[color_by_var]] %>% unique(),
values = c(rep("black", current_bar_plot_data[[color_by_var]] %>%
unique() %>% length() ))) +
guides(color = FALSE, size = FALSE)
## fill by groups or variable.
if(input$fill_barplot != "identical"){
barplot <- barplot + aes(fill = !!as.name(input$fill_barplot))
}
## fill bar plot identical
if (input$fill_barplot == "identical") {
barplot <- barplot +
aes(fill = input$barplot_color_chooser) + ## fake aesthatic
scale_fill_manual(breaks = current_bar_plot_data[[color_by_var]] %>% unique(),
values = c(rep(input$barplot_color_chooser, current_bar_plot_data[[color_by_var]] %>%
unique() %>% length() )))
}
## facet bar plot
if(input$barplot_facet_value != "none") {
barplot <- barplot +
facet_wrap(~ eval(as.symbol(input$barplot_facet_value)) , scales = c(input$barplot_yscale ))
}
## decorate box plot
barplot <- callModule(module = plot_title_and_axis_label_server ,
id = "barplot_label_and_title",
my_ggplot = barplot,
axis_x_title = input$barplot_xaxis_choices,
axis_y_title = "Value",
x_tick_angle = 90,
fill_legend_title = input$fill_barplot
)
incProgress(1)
})
return(barplot)
})
## render barplot
output$barplot <- renderPlot({
req(final_barplot())
return(print(final_barplot()))
}, height = function() {
return(session$clientData$output_barplot_width)
}, width = function() {
return(session$clientData$output_barplot_width)
}, res = 96)
## export barplot
callModule(module = export_plot , id = "export_barplot" , file_name = "barplot" ,plot = final_barplot)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# line plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x variables
observe({
# update x
updatePickerInput(
session = session,
inputId = "lineplot_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## validate line plot parameters
line_plot_params_validated <- eventReactive(input$generate_lineplot, {
req(input$lineplot_x)
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$lineplot_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
## check if selected variables are of type numeric
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
}
## atleast 2 variable req to generate line plot
if(length(input$lineplot_x) == 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Select atleast two columns to draw line plot"),
type = "error"
)
return(FALSE)
}
## value given for the `lineplot_top_n_genes` must be of type numeric
if(!is.numeric(input$lineplot_top_n_genes)) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("`# top variable genes to show` value must be of type numeric"),
type = "error"
)
return(FALSE)
}
## value given for the `line_plot_nclust` must be of type numeric
if(!is.numeric(input$line_plot_nclust)) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("`# of clusters (k-means)` value must be of type numeric"),
type = "error"
)
return(FALSE)
}
else {
return(TRUE)
}
})
## line plot condition panel : show only if selected variable(s) validated and displayed on UI
output$line_plot_status <- reactive({
req(line_plt())
return(TRUE)
})
outputOptions(output, "line_plot_status", suspendWhenHidden = FALSE)
## line plot user selected gene group data
line_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "line_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_lineplot),
current_session_data_matrix = plot_data)
## preapre line plot data.
line_plot_data <- eventReactive(eventExpr = input$generate_lineplot, {
req(line_plot_params_validated())
withProgress(message = 'Preparing line plot data', {
# Update progress
incProgress(0.5) ## display 50% task finished when it start
# Long Running Task
set.seed(1234)
## handle error if generated while performing clustering
clustered <- tryCatch({
clustered <- tibble_to_row_clusters(x = line_plot_user_selected_gene_group_data(),
row_ident = 1 ,
cols_to_use = input$lineplot_x,
use_z_score_for_clustering = ifelse(input$lineplot_cluster_value_type == 'zscore' ,
TRUE, FALSE) ,
num_of_top_var_rows = ifelse(input$lineplot_genes_selection == 'top_variable_genes',input$lineplot_top_n_genes , -1),
nclust = ifelse(input$line_plot_cluster_genes_by == "kmeans",
as.numeric(input$line_plot_nclust) , 1 ) ## if user selects cluster by gene groups, value of nclust = 1
)
## add count to cluster name
}, error = function(x){
shinyWidgets::sendSweetAlert(session = session ,
type = "error",
title = "Error" ,
text = tags$h5(tags$code(x)))
return(NULL)
})
# Update progress
incProgress(1)
}) ## with progress ends
## return NULL if oject clustered in NULL
if(is.null(clustered)){
return(NULL)
}
## select which value to display on plot, zscore or raw value.
if(input$lineplot_display_value_type == "zscore"){
forPlot <- clustered$zscore %>% left_join(clustered$clusters)
} else{
forPlot <- clustered$raw_value %>% left_join(clustered$clusters)
}
## if cluster by gene_groups assign user defined groups
if(input$line_plot_cluster_genes_by == "gene_groups"){
## tibble of two cols, where 1st column is gene names and 2nd is user supplied gene_groups
user_gene_groups <- line_plot_user_selected_gene_group_data() %>%
dplyr::select(1, dplyr::last_col())
## get column names to use them inside left_join
left_col <- colnames(forPlot)[1]
right_col <- colnames(user_gene_groups)[1]
## get the name of target column which is going to join as a result of left join.
## the name of resulted joined column will be used later to remove column from the df.
column_to_be_joined <- colnames(user_gene_groups)[2]
forPlot <- forPlot %>%
left_join(user_gene_groups , setNames(right_col, left_col)) %>%
dplyr::mutate(clust = !!as.symbol(column_to_be_joined)) %>%
dplyr::select(-!!as.symbol(column_to_be_joined))
}
## Add gene count in cluster name
forPlot <- forPlot %>%
dplyr::group_by(clust) %>%
dplyr::add_count() %>%
dplyr::ungroup() %>%
dplyr::mutate(clust = paste(clust, ":(N=" ,n , ")" , sep = "")) %>%
dplyr::select(-n)
## plot all lines vs avg line based on tick of activate_avg_line_plot
if (input$activate_avg_line_plot == "average") {
forPlot <- forPlot %>%
dplyr::group_by(clust) %>%
dplyr::summarise_if(is.numeric, input$avg_line_type)
}
forPlot <- forPlot %>%
tidyr::gather(key = "variable", value = "value" , input$lineplot_x) %>%
dplyr::mutate(variable = forcats::fct_inorder(variable)) %>% ## preserve original order of samples
dplyr::group_by(variable)
return(forPlot)
})
## plot
line_plt <- eventReactive(eventExpr = input$generate_lineplot, {
req(line_plot_data())
### plot
gp <- line_plot_data() %>%
dplyr::mutate(clust = forcats::fct_relevel(clust, as.numeric(clust) %>%
unique %>%
sort %>% as.character)) %>% ## numeric cluster to ordered factor
dplyr::mutate(row_num = 1:n()) %>%
ggplot2::ggplot(aes(x = variable,
y = value, group = row_num , alpha = 1))
return(gp)
})
## final line plot
final_line_plot <- reactive({
req(line_plt())
validate(need(is.numeric(input$line_plot_ncols) ,
message = "Number of columns must be numeric"))
## line plot geoms
line_plt <- line_plt() +
geom_point(size = input$lineplot_point_size) +
#geom_line(aes(col = clust) , size = input$lineplot_line_size) +
ggalt::geom_xspline(aes(col = clust),
spline_shape=input$line_plot_splin_shape,
size=input$lineplot_line_size)+
theme(legend.position = "none", axis.text.x = element_text(angle = 90, vjust = 0.4))
## line plot color identical
if(input$line_plot_color_by == 'identical'){
## get number of clusters
n_clust <- line_plt$data %>%
dplyr::pull(clust) %>% ## pull cluster var column
base::unique() %>%
as.character() %>% length()
## generate colors for each cluster
colrs <- c(rep(input$line_plot_color_chooser, n_clust))
## color and fill manual
line_plt <- line_plt +
scale_fill_manual(values = colrs) +
scale_color_manual(values = colrs)
}
## line plot manual alpha
line_plt <- line_plt +
scale_alpha(range = input$line_plot_line_transparancy) + ## override alpha in the plot
guides(alpha = FALSE ,
color = guide_legend(override.aes = list(alpha = input$line_plot_line_transparancy))) ## override alpha in the legend
## lie plot facet
if(input$line_plot_separate_by == 'gene_groups'){
line_plt <- line_plt + facet_wrap(~clust, ncol = input$line_plot_ncols ,
scales = input$line_plot_facet_scale_free)
}
## decorate line plot
line_plot <- callModule(module = plot_title_and_axis_label_server ,
id = "decorate_line_plot" ,
my_ggplot = line_plt ,
axis_x_title = "Samples",
axis_y_title = "Value",
color_legend_title = "Cluster",
x_tick_angle = 90
)
# ## fill color identical
# line_plot <- callModule(module = ggplot_fill_colour , "line_plot_color_identical" ,
# gp = line_plot , times = input$line_plot_nclust)
return(line_plot)
})
## render line plot
output$line_plot <- renderPlot({
req(final_line_plot())
return(print(final_line_plot()))
#return(
# withProgress(message = "Display line plot in progress", {
# incProgress(0.5)
#print(final_line_plot())
#incProgress(1)
#})
#)
}, height = function() {
return(session$clientData$output_line_plot_width)
}, width = function() {
return(session$clientData$output_line_plot_width)
}, res = 96)
## lineplot data to display
line_plot_data_disply <- eventReactive(input$generate_lineplot , {
req(line_plot_data())
display_data <- line_plot_data() %>%
tidyr::spread(key = "variable" , value = "value")%>%
dplyr::select(1,input$lineplot_x,dplyr::everything())
})
## genome annotation for line plot
## global genome annotations object cannot be used in following scenario
## For example : user has generated one lineplot Now accidently or purposely user selected / uploaded data
## for different species than the previous lineplot generated. In this scenario, global reference genome will
## be updated , and therefore, annotations in the existing lineplot will also be affected.
## To prepvent this seprate heatmap ref genome from global annot. lineplot ref annot will be updated only when
## plot lineplot submit button hit
lineplot_reference_annot <- eventReactive(input$generate_lineplot , {
req(genome_for_annotations())
return(genome_for_annotations())
})
## line plot output table
output$line_plot_clustred_data <- DT::renderDataTable({
## map gene features if average line not asked
if(isolate(input$activate_avg_line_plot != "average")){
user_selected_species_annot <- ah_data_summary2 %>%
dplyr::filter(genome == lineplot_reference_annot())%>%
dplyr::select(gr_cols) %>%
tidyr::unnest(cols = gr_cols)
join_col_x <- base::colnames(line_plot_data_disply())[1] ## first column containing geneNames
join_col_y <- base::colnames(user_selected_species_annot)[7] ## "id" column
line_plot_data_to_show <- line_plot_data_disply()%>%
left_join(user_selected_species_annot, by = setNames(join_col_y, join_col_x)) %>%
dplyr::select(1,c("seqnames", "start", "end", "strand", "description"), colnames(line_plot_data_disply())) %>%
dplyr::mutate_if(is.numeric, round, 4)%>%
dplyr::mutate_all(funs(replace_na(as.character(.),"--NA--")))
}else{
line_plot_data_to_show <- line_plot_data_disply()
}
return(line_plot_data_to_show %>% dplyr::arrange(clust) %>%
dplyr::mutate_if(is.numeric , round , 3))
},
selection = "none",
server = F,
extensions = "Buttons",
options = list(
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy", list(
extend =
"collection", buttons =
c("csv", "excel", "pdf"), text = "Download"
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500, -1) # declare values
, c(10, 50, 100, 500, "All") # declare titles
),
pageLength = 10
) ## end of options
)
## export line plot
callModule(module = export_plot ,id = "export_line_plot" ,file_name = "line_plot" , plot = final_line_plot)
## line plot functional analysis
callModule(module = functional_analysis_server , id = "lineplot_functional_analysis_ui" ,
ui_id = "lineplot_functional_analysis_ui",
session = session,
gene_set = reactive(split(x = line_plot_data_disply()[[1]], ## genename
f = line_plot_data_disply()$clust)) ,
genome = reactive({lineplot_reference_annot()}))
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# PCA plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## check whether x and y are numeric type
pca_plot_vars_validated <- eventReactive(input$generate_pca_plot, {
req(input$pca_plot_vars)
withProgress(message = "validate data" , {
incProgress(0.3)
selected_vars <- plot_data() %>% dplyr::select(input$pca_plot_vars)
col_class <- plot_data() %>% dplyr::select(input$pca_plot_vars) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather()
incProgress(0.5)
if (!all(col_class$value)) {
non_numeric_cols <- col_class %>% dplyr::filter(!value)
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0(paste0(non_numeric_cols$key, collapse = " "), " must be of type numeric", collapse = ""),
type = "error"
)
return(FALSE)
}
incProgress(0.7)
if(length(input$pca_plot_vars) == 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Select atleast two columns to perfrom PCA."),
type = "error"
)
return(FALSE)
}
else {
return(TRUE)
}
incProgress(1)
})
})
## update x variables
observe({
req(plot_data())
# update x
updatePickerInput(
session = session,
inputId = "pca_plot_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## pca plot user selected gene group data
pca_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "pca_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_pca_plot),
current_session_data_matrix = plot_data)
## prepare PCA input matrix , where columns are gene names and rows are sample names
pca_input_matrix <- eventReactive(eventExpr = input$generate_pca_plot,{
req(pca_plot_vars_validated() , pca_plot_user_selected_gene_group_data())
withProgress(message = "Prepare PCA data",{
incProgress(0.3)
plot_data_t <- pca_plot_user_selected_gene_group_data() %>%
dplyr::select(1, input$pca_plot_vars) %>%
dplyr::select_if(function(.) {
!all(. == 0)
}) %>% ## remove if all values are 0 in the sample
tidyr::gather(key = sname, value, -1) %>%
tidyr::spread(1, value) ## transpose data --> genes will be column and samples will be row
## conver dt to matrix for prcomp input
pca_input_data <- plot_data_t %>%
as.data.frame() %>%
column_to_rownames("sname")
})
return(pca_input_data)
})
## prform PCA
pca_plot_pr_comp <- eventReactive(eventExpr = input$generate_pca_plot,{
req(pca_input_matrix())
withProgress(message = "Perform PCA" , {
# perform pca
pr <- tryCatch({
prcomp(pca_input_matrix()) ## remove last column having sample groups
} , error = function(x){
sendSweetAlert(session = session ,title = "Error while performing PCA" ,
text = tags$h4("Error message from function :" ,
tags$code("prcomp()"),br(),br(), tags$code(x)) ,
type = "error")
return(NULL)
})
})
return(pr)
})
### perform pca sample k-means
pca_data_sample_kmeans <- reactive({
req(pca_input_matrix())
validate(
need(is.numeric(input$pca_sample_sample_kmeans_n) &&
(input$pca_sample_sample_kmeans_n > 0 ) , message = "Number of cluster must be numeric")
)
## perform kmenas
km_data <- tryCatch({
set.seed(12345)
km <- kmeans(pca_input_matrix() , centers = input$pca_sample_sample_kmeans_n )
tt <- tibble::tibble(sname = rownames(pca_input_matrix()) , kmeans_clust = km$cluster )
}, error = function(x){
sendSweetAlert(session = session ,title = "PCA sample K-means error!!!" ,
text = tags$h4("Putting all samples in one group.",br(),
"Error message from function :" ,
tags$code("kmeans()"),br(),br(), tags$code(x)) ,
type = "error")
tt <- tibble::tibble(sname = rownames(pca_input_matrix()) , kmeans_clust = "All samples")
return(tt)
})
return(km_data)
})
## Attach % variance with each PC
my_pr_comp_names <- reactive({
req(pca_plot_pr_comp())
## get proportion of variance for each PC
pc_prop_of_var <- summary(pca_plot_pr_comp())$importance %>%
#summary(pr)$importance %>%
as.data.frame() %>%
rownames_to_column(var = "feature_type") %>%
tidyr::gather(pc , value , -feature_type) %>%
dplyr::filter(feature_type == "Proportion of Variance") %>%
dplyr::select(-feature_type) %>%
dplyr::mutate(value = round(value * 100 ,1)) %>% ## convert to percentage
dplyr::mutate(with_var = paste(pc ," (" , value ,"%",")" , sep = "")) %>%
dplyr::select(-value)
## return named vector
pc_prop_of_var %>% dplyr::pull(with_var) %>% rlang::set_names( pc_prop_of_var$pc)
})
## Get PCs from prcomp obtained object. pr_comp_derieved_tibble is a tibble where columns are PCs and rows are samples.
pr_comp_derieved_tibble <- reactive({
req(pca_plot_pr_comp())
## get pr_comp tibble, and map sample and group info
pr_comp_tbl <- pca_plot_pr_comp()$x %>%
as.data.frame() %>%
dplyr::rename_all(~(my_pr_comp_names())) %>%
tibble::rownames_to_column("sname") %>%
as_tibble() ## rename column names. new column names are with 'prop of var' attached.
## create column sname (sample names ) from row names
## prevent rendering from global sample group update
isolate({
pr_comp_tbl_grps <- pr_comp_tbl %>%
left_join(group_info$column_groups , by = c (sname = "group_members")) %>% ## add column groups denoting sample groups
tidyr::replace_na(list(groups = "No groups assigned")) ## in the column groups replace NA to "No groups assigned"
})
## add sample kmeans data
pr_comp_tbl_grps <- pr_comp_tbl_grps %>%
left_join(pca_data_sample_kmeans() , by = "sname") %>%
tidyr::replace_na(list(kmeans_clust = "No groups assigned")) ## in the column groups
return(pr_comp_tbl_grps)
})
## PCA plot update show / hide sample groups. It allows user to exclude sample groups directly from PCA plot
observe({
req(pr_comp_derieved_tibble())
if(input$pca_plot_colour == "groups"){
shinyWidgets::updateMultiInput(inputId = "pca_plot_hide_sample_groups" , session = session,
choices = pr_comp_derieved_tibble() %>% pull("groups") %>% unique()
)
}
if(input$pca_plot_colour == "kmeans"){
shinyWidgets::updateMultiInput(inputId = "pca_plot_hide_sample_groups" , session = session,
choices = pr_comp_derieved_tibble() %>% pull("kmeans_clust") %>% unique()
)
}
})
### Remove user excluded groups before final PCA plot
pca_data_after_groups_excluded_by_user <- reactive({
#req(input$pca_plot_hide_sample_groups)
user_excluded_groups <- input$pca_plot_hide_sample_groups
plot_data <- pr_comp_derieved_tibble() %>%
dplyr::filter(! xor((groups %in% user_excluded_groups),(kmeans_clust %in% user_excluded_groups)))
## make sure pca_data_after_groups_excluded_by_user() > 1 row.
### This is necessary to check when user exclude all the groups
validate(
need(plot_data %>% nrow() > 1 , "Atleast one sample group must be selected" )
)
return(plot_data)
})
## update PC choices
observe({
req(my_pr_comp_names())
available_pc <- my_pr_comp_names()
default_pc <- available_pc[1:2] ## default PCs
updateSelectizeInput(session = session ,
inputId = "select_pcs_to_plot" ,
choices = available_pc %>% unname(),
selected = default_pc ,server = TRUE)
})
## get names of PC columns
pcs_to_plot <- reactive({
validate(
need(input$select_pcs_to_plot %>% length() == 2 , "Select 2 Pcs.")
)
return(input$select_pcs_to_plot)
})
## pca plot
pca_gp <- reactive({
req(all(pcs_to_plot() %in% my_pr_comp_names()))
withProgress(message = "Preparing PCA plot",{
incProgress(0.5)
## add group information
plot_data <- pca_data_after_groups_excluded_by_user()
#print("PCA plot data")
#print(plot_data %>% dplyr::select(sname, groups))
## PCs to plot
pc_x = pcs_to_plot()[1]## PC1
pc_y = pcs_to_plot()[2] ## PC2
## plot , default PC1 and PC2
pca_gp <- ggplot(data = plot_data ,
aes_string(x = as.symbol(pc_x), y = as.symbol(pc_y) )) +
geom_point(size = input$pca_sample_dot_size) #+ theme_bw()
## whether sample names should be shown or not
if(input$pca_display_sample_names) {
pca_gp <- pca_gp +
ggrepel::geom_text_repel(aes(label = sname),
size = input$pca_plot_sample_names_size)
}
### color groups
if(input$pca_plot_colour == "groups") {
pca_gp <- pca_gp + aes(color = groups) +
scale_color_manual(values = get_gg_colors(pr_comp_derieved_tibble() %>%
pull(groups) %>%
as_factor() %>% levels()) )
}
## color by sample kmeans
if(input$pca_plot_colour == "kmeans") {
pca_gp <- pca_gp + aes(color = factor(kmeans_clust)) +
scale_color_manual(values = get_gg_colors(pr_comp_derieved_tibble() %>%
dplyr::pull(kmeans_clust) %>%
forcats::as_factor() %>% levels()))
}
## color identical , NOTE: using breaks = NULL explicitly will be helpful to getrid of legends
if(input$pca_plot_colour == "identical") {
pca_gp <- pca_gp + aes(col = "") +
scale_color_manual( breaks = NULL , values = input$pca_sample_name_color)
}
incProgress(1)
})
return(pca_gp)
})
## final pca plot
final_pca_plot <- reactive({
req(pca_gp())
withProgress(message = "Decorate PCA plot",{
incProgress(0.5)
pca_gp <- callModule(module = plot_title_and_axis_label_server ,
id = "decorate_pca_plot" ,
my_ggplot = pca_gp() ,
axis_x_title = pca_gp()$labels$x,
axis_y_title = pca_gp()$labels$y ,
x_tick_angle = 0,
color_legend_title = input$pca_plot_colour)
pca_gp <- pca_gp +
scale_x_continuous(expand = expand_scale(mult = 0.2)) + # expand x scale
scale_y_continuous(expand = expand_scale(mult = 0.2)) # expand y scale
incProgress(1)
return(pca_gp)
})
})
## render pca
output$pca_plot <- renderPlot({
req(final_pca_plot())
final_pca_plot()
#return(print(final_pca_plot()))
},
height = function() {
req(final_pca_plot())
return(session$clientData$output_pca_plot_width)
}, ## dynamic height
width = function() {
req(final_pca_plot())
return(session$clientData$output_pca_plot_width)
}, res = 96
) ## dynamic width
## export pca plot
callModule(module = export_plot , id = "export_pca_plot" , file_name = "pca_plot" , plot = final_pca_plot)
## current pca plot SRA sample info, update only when generate pca plot submit button hit
current_pca_plot_sra_sample_info <- eventReactive(eventExpr = input$generate_pca_plot,{
return(user_selected_sra_id_sample_info())
})
### pla plot brush data
pca_brushed_data <- eventReactive(input$pca_plot_brush , {
pc_x = pcs_to_plot()[1] ## PC1
pc_y = pcs_to_plot()[2] ## PC2
## subset brushed points data
bp <- brushedPoints(df = pca_data_after_groups_excluded_by_user() ,
brush = input$pca_plot_brush ,
xvar = pc_x,
yvar = pc_y)
## map required sample info
display_pca_data <- current_pca_plot_sra_sample_info() %>%
dplyr::filter(run_accession %in% bp$sname) %>%
dplyr::select(-c("reference_annot" , "taxon_id","scientific_name" , "instrument_model" , "updated_date"))
return(display_pca_data)
})
## render PCA brushed data
output$pca_brushed_datatable <- DT::renderDataTable({
req(pca_brushed_data())
return(pca_brushed_data() %>%
dplyr::mutate_all(funs(replace_na(as.character(.),"--NA--"))) %>%
dplyr::mutate_if(is.numeric , round , 2))
},selection = "none",
server = F,
extensions = c("Buttons"),
options = list(
deferRender = TRUE,
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
columnDefs = list(
list(targets = c(6:15), visible = FALSE) # The column number must be identical to the columns in colvis extension
),
buttons =
list("copy",
list(extend = "collection",
buttons = c("csv", "excel", "pdf"), text = "Download"
),
list(extend = "colvis",
columns = c(6:15)
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500, -1) # declare values
, c(10, 50, 100, 500, "All") # declare titles
),
pageLength = 10
)
)
## pca plot brushed data table status , decide whether should be displayed or not
output$pac_plot_brushed_data_table_status <- reactive({
req(pca_brushed_data())
return(TRUE)
})
outputOptions(output,name = "pac_plot_brushed_data_table_status" , suspendWhenHidden = FALSE)
## pca plot condition panel:show only if variable (x, y) validated and displayed on UI
output$pca_plot_status <- reactive({
req(pca_plot_pr_comp())
return(TRUE)
})
outputOptions(output, "pca_plot_status", suspendWhenHidden = FALSE)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# heatmap server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## check whether x and y are numeric type
heatmap_parmas_validated <- eventReactive(input$generate_heatmap, {
req(input$heatmap_vars)
selected_vars <- plot_data() %>% dplyr::select(input$heatmap_vars)
col_class <- plot_data() %>% dplyr::select(input$heatmap_vars) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather()
withProgress(message = "Validating inputs", {
incProgress(1/10)
if (!all(col_class$value)) {
non_numeric_cols <- col_class %>% dplyr::filter(!value)
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0(paste0(non_numeric_cols$key, collapse = " "), " must be of type numeric", collapse = ""),
type = "error"
)
return(FALSE)
}
incProgress(2/10)
## atleast two vars req to generate hm
if(length(input$heatmap_vars) == 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Select atleast two columns to draw heatmap"),
type = "error"
)
return(FALSE)
}
incProgress(3/10)
# check if number of genes given are of type numeric
if ((!is.numeric(input$heatmap_top_n_genes)) & (input$hm_genes_selection == "top_variable_genes")) {
sendSweetAlert(
session = session,
title = "Error...",
text = "'# top variable genes to show' must be numeric",
type = "error"
)
return(NULL)
}
incProgress(4/10)
## check if user given color scale min is valid
if (!is.numeric(input$heatmap_scale_min)) {
sendSweetAlert(
session = session,
title = "Error...",
text = "Heatmap color scale (minimum) must be numeric value",
type = "error"
)
return(NULL)
}
incProgress(5/10)
## check if user given color scale max valid or not
if (!is.numeric(input$heatmap_scale_max)) {
sendSweetAlert(
session = session,
title = "Error...",
text = "Heatmap color scale (maximum) must be numeric value",
type = "error"
)
return(NULL)
}
incProgress(6/10)
## check if number of cluster given are of type numeric.
if (!is.numeric(input$heatmap_row_nclust) || !is.numeric(input$heatmap_coulm_nclust)) {
sendSweetAlert(
session = session,
title = "Error...",
text = "'# of clusters (column / row k-means)' must be of type numeric",
type = "error"
)
return(NULL)
}
incProgress(7/10)
## check if number of cluster given are > 0 and <= total rows in the data or
if (input$heatmap_row_nclust == 0 ||
input$heatmap_coulm_nclust == 0 ||
input$heatmap_row_nclust >= nrow(plot_data()) ||
input$heatmap_row_nclust >= input$heatmap_top_n_genes ||
input$heatmap_coulm_nclust >= ncol(plot_data()) ||
input$heatmap_coulm_nclust >= length(input$heatmap_vars)
) {
sendSweetAlert(
session = session,
title = "Error...",
text = "'# of clusters (column / row k-means)' must be > 0 and < total rows (row clusters) or total columns (column clusters)",
type = "error"
)
return(NULL)
}
else {
return(TRUE)
}
incProgress(10/10)
})
})
## heatmap conditional panel
output$heatmap_status <- reactive({
req(heatmap_to_display())
return(TRUE)
})
outputOptions(output, "heatmap_status", suspendWhenHidden = FALSE)
## update x variables
observe({
req(plot_data())
## update x
updatePickerInput(
session = session,
inputId = "heatmap_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## heatmap user selected gene group data
heatmap_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "heatmap_select_gene_groups" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_heatmap),
current_session_data_matrix = plot_data)
## prepare heatmap data.
heatmap_top_variable_genes_df <- eventReactive(eventExpr = input$generate_heatmap, {
req(heatmap_parmas_validated(), heatmap_user_selected_gene_group_data())
withProgress(message = "Preparing heatmap data " , {
incProgress(0.1)
# fix number of genes to plot, default all genes (if any gene group selected, all the genes from selected gene group will be plotted)
num_of_genes_for_hm <- nrow(heatmap_user_selected_gene_group_data())
if (input$hm_genes_selection == "top_variable_genes") {
## if user given number of genes argument < total genes, all genes will be used in the plot.
if (nrow(heatmap_user_selected_gene_group_data()) < input$heatmap_top_n_genes) {
num_of_genes_for_hm <- nrow(heatmap_user_selected_gene_group_data())
} else {
num_of_genes_for_hm <- input$heatmap_top_n_genes
}
}
# max genes cannot be higher than 20k
max_hm_genes <- 20000
if (num_of_genes_for_hm > max_hm_genes) {
sendSweetAlert(
session = session,
title = "Error...",
text = paste("Number of genes cannot be higher than ", max_hm_genes, ".", sep = ""),
type = "error"
)
return(NULL)
}
incProgress(0.3 , message = "row wise clustering")
## get clusters and zscore data
clustered <- tryCatch({
tibble_to_row_clusters(x = heatmap_user_selected_gene_group_data(),
row_ident = 1 ,
cols_to_use = input$heatmap_vars,
use_z_score_for_clustering = ifelse(input$heatmap_cluster_value_type == 'zscore' , TRUE, FALSE),
#use_z_score_for_clustering = input$hm_use_zscore ,
num_of_top_var_rows = ifelse(input$hm_genes_selection == 'top_variable_genes',
num_of_genes_for_hm , -1),
nclust = as.numeric(input$heatmap_row_nclust)
)
} , error = function(x){
return(x)
})
## if error generated while clustering
if(inherits(clustered , "error")){
sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Row k-means error : ", clustered, collapse = " "),
type = "error"
)
return(NULL)
}
## select which value to display on plot, zscore or raw value.
if(input$heatmap_display_value_type == "zscore"){
heatmap_data <- clustered$zscore
#print(heatmap_data)
} else{
heatmap_data <- clustered$raw_value
#print(heatmap_data)
}
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## arrange heatmap input data in original order is important when user wants to have same order of genes in the heatmap which was uploaded.
## Following things must be kept in mind when arranging heatmap data matrix in the original order
## 1) output of the tibble_to_row_clusters function throws list containing raw_data_matrix, zscore_matrix and row_clusters
## if order of the rows in heatmap data matrix (zscore or raw data) change, order in the row clusters must change.
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
gene_name_col_names <- plot_data_original_row_order() %>% colnames() %>% .[1]
row_order_col_name <- plot_data_original_row_order() %>% colnames() %>% .[2]
heatmap_data <- heatmap_data %>%
left_join(plot_data_original_row_order() , by = setNames(gene_name_col_names , colnames(heatmap_data)[1])) %>%
dplyr::arrange(.data[[row_order_col_name]]) %>% ## arrange by original gene order
dplyr::select(-.data[[row_order_col_name]]) ## remove column
## as mentioned above change order in row clusters
row_splt <- clustered$clusters %>%
left_join(plot_data_original_row_order() , by = setNames(gene_name_col_names , colnames(clustered$clusters)[1])) %>%
dplyr::arrange(.data[[row_order_col_name]]) %>%
dplyr::select(-.data[[row_order_col_name]])
### which clusters to use ? kmeans or user defined
if(input$heatmap_row_clusters_choices == "kmeans") {
row_splt <- row_splt%>%
pull(2)
} else if(input$heatmap_row_clusters_choices == "gene_groups"){
## get user given row groups
row_splt = heatmap_data %>%
as_tibble() %>%
dplyr::left_join(group_info$row_groups ,
by = setNames(colnames(group_info$row_groups)[2] ,
colnames(heatmap_data)[1])) %>%
pull(colnames(group_info$row_groups)[1])
## set levels in the orginal order of user supplied groups
row_splt <- row_splt %>%
as.factor() %>%
fct_relevel(., group_info$row_groups %>%
pull(1) %>% unique())
}
## number of genes in each cluster
gene_count <- table(row_splt)
## Fix row cluster names
row_splt <- row_splt %>%
tibble(x = . ) %>%
dplyr::add_count(x) %>%
dplyr::mutate(cluster_name = paste(input$hm_cluster_prefix , x ,":(N=", n,")" , sep = "")) %>%
pull(cluster_name)
## convert tibble to data frame
heatmap_data <- heatmap_data %>%
as.data.frame()
##generate matrix with rownames as gene name
rownames(heatmap_data) <- heatmap_data[[1]]
heatmap_data <- heatmap_data[-1]
incProgress(0.7 , message = "column wise clustering")
## column clusters, which clusters to use ? kmeans or user defined
if(input$heatmap_column_clusters_choices == "kmeans"){ #
column_splt <- tryCatch({
set.seed(1234)
column_km_out <- kmeans(t(heatmap_data) ,centers = input$heatmap_coulm_nclust)
column_km_out$cluster
} , error = function(x){
return(x)
})
} else if(input$heatmap_column_clusters_choices == "sample_groups"){ # use sample groups as column cluster
## heatmap column names to user supplied grp names tibble
column_splt_ss = heatmap_data %>%
colnames() %>%
tibble(sname = .) %>%
left_join(group_info$column_groups , by = c (sname = "group_members")) #%>%
## arrange by user supplied column order
column_splt_ss <- column_splt_ss %>%
dplyr::mutate(sname = forcats::fct_relevel(as.character(sname) , group_info$column_groups %>% pull(2) %>% unique() ))
## get named vector of heatmap column names, where vector elems are group names and names are column names.
column_splt <- column_splt_ss %>%
pull(colnames(group_info$column_groups)[1]) %>% ## pull user supplied group columns
rlang::set_names( . ,column_splt_ss$sname)
## rearrange heatmap data as split order changed
heatmap_data <- heatmap_data %>% dplyr:: select(names(column_splt))
}
## Fix column cluster name
column_splt <- column_splt %>%
tibble(x = .) %>%
dplyr::add_count(x) %>%
dplyr::mutate(cluster_name = paste(input$hm_column_cluster_prefix , x ,"\n(N=", n,")" , sep = "")) %>%
pull(cluster_name) %>%
set_names(names(column_splt)) ## set orig names if it has
## handle column split error
if(inherits(column_splt , "error")){
sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Column k-means error : ", column_splt, collapse = " "),
type = "error"
)
return(NULL)
}
incProgress(0.9 , message = "final data")
## set heatmap data to a list
rr= NULL
rr$mat <- heatmap_data
rr$clust <- row_splt
rr$column_clusters <- column_splt
rr$row_sd <- rr$mat %>%
rownames %>%
tibble(geneName = . ) %>%
left_join(clustered$std_dev , by =c("geneName" = colnames(clustered$std_dev)[1])) %>%
as.data.frame() %>%
column_to_rownames("geneName") %>% as.matrix()
incProgress(0.1)
return(rr)
})
})
## update heatmap legend range
observe({
#req(heatmap_top_variable_genes_df())
if(input$heatmap_display_value_type == "zscore"){
updateNumericInput(session = session ,
inputId = "heatmap_scale_min",
value = -1.5)
updateNumericInput(session = session ,
inputId = "heatmap_scale_max",
value = 1.5)
}
if(input$heatmap_display_value_type != "zscore"){
updateNumericInput(session = session ,
inputId = "heatmap_scale_min",
value = 0)
updateNumericInput(session = session ,
inputId = "heatmap_scale_max",
value = 10)
}
})
## generate heatmap
heatmap <- eventReactive(input$generate_heatmap, {
req(heatmap_top_variable_genes_df())
withProgress(message = "Preparing heatmap",{
incProgress(0.5)
# generate heatmap
hm_row_threshold <- 2000 ##if number of genes higher than this, gene names will be disabled.
# ## hm colors
hm_colors <- tryCatch({
circlize::colorRamp2(
breaks = seq(from = input$heatmap_scale_min,
to = input$heatmap_scale_max , length.out = 3),
colors = c(input$heatmap_col_low, input$heatmap_col_medium, input$heatmap_col_high)
)
}, error = function(e){
## send warning if color function give error
sendSweetAlert(session = session , title = "Warning" ,
type = "warning" ,
text = tags$h4("Error while generating user defined colors",
br(),
"Error from" , tags$code("circlize::colorRamp2()"),
br(),
tags$code(e),br(),
"Default scale (-2 to 2) will be used."
))
## default color : get minimum and maximum from
circlize::colorRamp2(
breaks = seq(from = -2,
to = 2 , length.out = 3),
colors = c(input$heatmap_col_low, input$heatmap_col_medium, input$heatmap_col_high)
)
})
## prepare column annotations
column_ha = NULL ## default column annotations
## boxplot and column name annotations
if(!is.null(input$heatmap_anno_type)){ ## make sure atleast one annot selected
## convert NA to "No groups assigned"
no_grp_label <- "NA"
## get groups for hm cols
hm_selected_column_groups <- heatmap_top_variable_genes_df()$mat %>%
colnames() %>%
tibble(hm_cols = . ) %>%
left_join(group_info$column_groups , by = c(hm_cols = "group_members")) %>%
pull(groups) %>%
replace_na(no_grp_label)
### column grp annot
grp_colors <- get_gg_colors(x = hm_selected_column_groups %>% as_factor() %>% levels())
## column box annot
column_box_anno <- ComplexHeatmap::anno_boxplot(heatmap_top_variable_genes_df()$mat ,
axis = T ,
border = T ,
axis_param = list(gp = grid::gpar(fontsize = 8),
side = "left",
facing = "outside"
),
height = unit(input$heatmap_top_annot_height,"cm")
)
## display both grp and box annot
if(all(c("show_heatmap_column_groups" , "show_heatmap_column_boxplot") %in% input$heatmap_anno_type)){ ## all annotations
column_ha = ComplexHeatmap::HeatmapAnnotation(Groups = hm_selected_column_groups ,
Box = column_box_anno,
col = list(Groups = grp_colors)
)
## only grp annot
}else if(input$heatmap_anno_type == "show_heatmap_column_groups") {## sample group annotations
column_ha = ComplexHeatmap::HeatmapAnnotation(Groups = hm_selected_column_groups , col = list(Groups = grp_colors))
## only box annot
}else if(input$heatmap_anno_type == "show_heatmap_column_boxplot"){ ## box plot annotations
column_ha = ComplexHeatmap::HeatmapAnnotation(box = column_box_anno)
}
}
## final hm
hm <- ComplexHeatmap::Heatmap(heatmap_top_variable_genes_df()$mat,
#row_title = "cluster_%s",
cluster_column_slices = F,#input$hm_cluster_column_slice %>% as.logical() , ## it make sure that column clusters arrange in order
column_split = heatmap_top_variable_genes_df()$column_clusters %>%
factor(., levels = gtools::mixedsort(unique(.))),
show_column_names = input$show_hm_colum_names %>% as.logical(),
show_column_dend = input$show_hm_column_dend %>% as.logical(),
cluster_columns = input$hm_cluster_columns %>% as.logical(),
column_names_gp = grid::gpar(fontsize = input$hm_column_names_font_size),
top_annotation = column_ha,
column_title_rot = 90,
column_title_gp = grid::gpar(fontsize = 10),
# if SD heatmap AND sort by SD both on together, turn off row clustering.
cluster_rows = ifelse(input$sort_hm_by_std_dev %>% as.logical() &&
input$show_std_dev_hm %>% as.logical() , FALSE , as.logical(input$hm_cluster_rows)),
# if number of genes higher than hm_row_threshold disable genenames
show_row_names = ifelse(nrow(heatmap_top_variable_genes_df()$mat) <= hm_row_threshold, as.logical(input$show_hm_row_names), FALSE),
show_row_dend = input$show_hm_row_dend %>% as.logical() ,
#row_split = paste0("Clust_",heatmap_top_variable_genes_df()$clust),
row_split = heatmap_top_variable_genes_df()$clust %>% factor(., levels = gtools::mixedsort(unique(.))) ,
row_names_gp = grid::gpar(fontsize = input$hm_row_names_font_size),
row_order = if(all(input$sort_hm_by_std_dev %>% as.logical() , input$show_std_dev_hm %>% as.logical())) order(heatmap_top_variable_genes_df()$row_sd[,1]) else NULL,
cluster_row_slices = F, #input$hm_cluster_row_slice,
row_title_rot = 0,
row_title_gp = grid::gpar(fontsize = 10),
name = ifelse(input$heatmap_display_value_type == "zscore" , "zscore", input$heatmap_legend_name),
heatmap_legend_param = list(legend_direction = input$heatmap_legened_direction),
col = hm_colors,
border = input$hm_border %>% as.logical()
#width = unit(5 , "in"),
#height = unit(5 , "in")
)
incProgress(1)
})
return(hm)
})
## standard deviation heatmap
sd_heatmap <- eventReactive(input$generate_heatmap, {
req(heatmap_top_variable_genes_df())
hm_row_threshold = 2000
sd_hm <- ComplexHeatmap::Heatmap(heatmap_top_variable_genes_df()$row_sd,
row_split = heatmap_top_variable_genes_df()$clust,
show_row_names = ifelse(nrow(heatmap_top_variable_genes_df()$mat) <= hm_row_threshold, as.logical(input$show_hm_row_names), FALSE),
row_names_gp = grid::gpar(fontsize = input$hm_row_names_font_size),
heatmap_legend_param = list(legend_direction = input$heatmap_legened_direction),
name = "std_dev")
return(sd_hm)
})
## final heatmap : data heatmap or combined with SD heatmap
heatmap_to_display <- eventReactive(input$generate_heatmap , {
req(heatmap())
if(input$show_std_dev_hm %>% as.logical()) {
show_hm <- heatmap() + sd_heatmap() ## temparory SD heatmap de activted
}else{
show_hm <- heatmap()
}
return(show_hm)
})
## render heatmap
output$heatmap <- renderPlot({
#req(heatmap_to_display())
# heatmap display in progress
# withProgress(message = "Display heatmap in progress" , {
# incProgress(0.5)
# set.seed(123)
# #hm <- shiny::isolate(ComplexHeatmap::draw(heatmap_to_display() , heatmap_legend_side = input$heatmap_legend_pos))
# incProgress(1)
# })
return(heatmap_to_display())
},
height = function() {
req(heatmap_top_variable_genes_df())
minimum_height <- 400
ht <- minimum_height + (input$hm_row_height * nrow(heatmap_top_variable_genes_df()$mat))
return(ht)
}, ## dynamic height
width = function() {
req(heatmap_top_variable_genes_df())
minimum_width <- 500
wd <- minimum_width + (input$hm_col_width * ncol(heatmap_top_variable_genes_df()$mat))
return(wd)
}, res = 108
) ## dynamic width
# Export heatmap
callModule(module = export_base_graphics ,
id = "export_heatmap" ,
file_name = "heatmap" ,
plot = as_mapper(~heatmap_to_display()), ## pass as a function does not open device locally
legend_pos = reactive(input$heatmap_legend_pos))
## prepare heatmap data for display
active_heatmap_data <- reactive({
req(heatmap_to_display())
# clusts must be a list. However, if only 1 cluster (rowwise) given , `clusts` becomes vector.
# To overcome this, convert clusts to list explicitly when number of row clusters == 1.
if(heatmap()@matrix_param$row_split %>% pull(row_split) %>% unique() %>% length() == 1) { ## this can be improved
clusts <- list("1" = ComplexHeatmap::row_order(heatmap()))
} else {
## return list where names of each elem indicates the cluster name displyed in heatmap
clusts <- ComplexHeatmap::row_order(heatmap())
}
## prepare the tibble of two column where first column is cluster names and second column is row number of original data matrix given to the ComplexHeatmap::Heatmap function
names(clusts) <- as.character(names(clusts))
hm_clust <- data_frame(clust = names(clusts), row_num = clusts) %>%
tidyr::unnest()
##column order
hm_coloum_ord <- ComplexHeatmap::column_order(heatmap()) %>% unlist(use.names = F)
## final data to be shown below heatmap as heatmap data
hm_data <- heatmap_top_variable_genes_df()$mat %>% ## this is the original data supplied to the heatmap
as.data.frame() %>%
dplyr::select(hm_coloum_ord) %>%
rownames_to_column(var = "gene_name") %>%
as_data_frame() %>%
dplyr::mutate(row_num = dplyr::row_number()) %>%
right_join(hm_clust , by = "row_num") %>% ## two tibble will be join by row_num column
dplyr::select(-row_num) %>%
left_join(heatmap_top_variable_genes_df()$row_sd %>%
as.data.frame() %>%
tibble::rownames_to_column("gene_name") , by = "gene_name")## add std dev
return(hm_data %>%
dplyr::mutate_if(is.numeric, round, 4))
})
## genome annotation for heatmap
## global genome annotations object cannot be used in following scenario
## For example : user has generated one heatmap. Now accidently or purposely user selected / uploaded data
## for different species than the previous heatmap generated. In this scenario, global reference genome will
## be updated , and therefore, annotations in the existing heatmap will also be affected.
## To prepvent this seprate heatmap ref genome from global annot. Heatmap ref annot will be updated only when
## plot heatmap submit button hit
heatmap_reference_annot <- eventReactive(input$generate_heatmap , {
req(genome_for_annotations())
return(genome_for_annotations())
})
## render heatmap data
output$heatmap_data <- DT::renderDataTable({
## map species annotations while displaying heatmap data
user_selected_species_annot <- ah_data_summary2 %>%
dplyr::filter(genome == heatmap_reference_annot()) %>%
dplyr::select(gr_cols) %>%
tidyr::unnest(cols = gr_cols)
join_col_x <- base::colnames(active_heatmap_data())[1] ## first column containing geneNames
join_col_y <- base::colnames(user_selected_species_annot)[7] ## "id" column
heat_map_data_to_show <- active_heatmap_data() %>%
left_join(user_selected_species_annot, by = setNames(join_col_y, join_col_x)) %>%
dplyr::select(1,c("seqnames", "start", "end", "strand", "description"), colnames(active_heatmap_data()))%>%
dplyr::mutate_all(funs(replace_na(as.character(.),"--NA--")))
return(heat_map_data_to_show)
},rownames = T,
selection = "none",
server = T,
extensions = "Buttons",
options = list(
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy", list(
extend =
"collection", buttons =
c("csv", "excel"), text = "Download"
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500, -1) # declare values
, c(10, 50, 100, 500, "All") # declare titles
),
pageLength = 10
)
)
## prepare column cluster data
heatmap_column_cluster <- eventReactive(input$generate_heatmap,{
req(heatmap())
hm_column_labels <- heatmap()@column_names_param$labels
hm_column_ord <- ComplexHeatmap::column_order(heatmap())
named_list_from_vector <- purrr::as_mapper(~
if(!is_list(.x)){
list(`1` = .x)
}else{
.x
} )
## given a list of a char vector it returns a char vector where each elem of list collpase in a single vector elem.
colum_list_to_chr = as_mapper(~map_chr(., paste0 , collapse =","))
hm_column_ord_lst <- named_list_from_vector(hm_column_ord)
## wide format
wide <- tibble(cluster = names(hm_column_ord_lst) , column_order = hm_column_ord_lst) %>%
tidyr::unnest() %>%
dplyr::mutate(column_labels = hm_column_labels[column_order]) %>%
dplyr::select(-column_order) %>%
dplyr::group_by(cluster) %>%
dplyr::summarise(column_labels = list(column_labels)) %>%
dplyr::mutate(count = lengths(column_labels)) %>%
dplyr::mutate(column_labels = colum_list_to_chr(column_labels)) %>%
dplyr::select(cluster, count, column_labels) %>%
dplyr::slice(match(names(hm_column_ord_lst) , .$cluster )) ## arrange clusters in original heatmap order
## given a char vector , reeturns list of vectors. Each elem of char will be splitted by 'split' and all splitted elems will be strored in a vector
colum_chr_to_list = as_mapper(~map(., function(.) {strsplit(. , split = ",") %>% unlist() }))
## Long format
long <- wide %>%
dplyr::mutate(column_labels = colum_chr_to_list(column_labels)) %>%
tidyr::unnest(cols = column_labels)
list(wide = wide, long = long)
})
## prepare row cluster data
heatmap_row_cluster <-eventReactive(input$generate_heatmap,{
req(active_heatmap_data())
## get data from reactive elems
active_hm_data <- active_heatmap_data()
cols_of_interest <- c(colnames(active_hm_data)[1] , "clust")
wide <- active_hm_data %>%
dplyr::select(cols_of_interest) %>% ## select first (gene name) and row cluster column : 'clust'
dplyr::group_by(clust) %>%
dplyr::summarise(row_labels = list(!!as.symbol(cols_of_interest[1] ))) %>%
dplyr::mutate(count = lengths(row_labels)) %>%
dplyr::mutate(row_labels = map_chr(row_labels, ~paste0(.x , collapse = ","))) %>%
dplyr::select( clust, count , row_labels) %>%
dplyr::slice(match( active_heatmap_data()$clust %>% unique(), .$clust )) ## arrange in orginal order
## given a char vector , reeturns list of vectors. Each elem of char will be splitted by 'split' and all splitted elems will be strored in a vector
colum_chr_to_list = as_mapper(~map(., function(.) {strsplit(. , split = ",") %>% unlist() }))
long <- wide %>%
dplyr::mutate(row_labels = colum_chr_to_list(row_labels)) %>%
tidyr::unnest(cols = row_labels)
list(wide = wide, long = long )
})
# render heatmap cluster data
output$heatmap_display_cluster_data <- DT::renderDataTable({
if(input$heatmap_cluster_type == 'show_hm_row_side_clusters'){
return(heatmap_row_cluster()[[input$heatmap_cluster_data_format]])
} else if (input$heatmap_cluster_type == 'show_hm_column_side_clusters'){
return(heatmap_column_cluster()[[input$heatmap_cluster_data_format]] )
}
}, rownames = T,
selection = "none",
server = T,
extensions = "Buttons",
options = list(
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy",
list(extend = "collection",
buttons =c("csv", "excel"),
text = "Download"
)
), # end of buttons customization
# customize the length menu
pageLength = 10
))
## heatmap functional analysis
callModule(module = functional_analysis_server ,
id = "heatmap_functional_analysis_ui" ,
ui_id = "heatmap_functional_analysis_ui",
session = session,
gene_set = reactive(split(x = active_heatmap_data()$gene_name,
f = factor(active_heatmap_data()$clust , levels = active_heatmap_data()$clust %>% unique()))) ,
genome = reactive({heatmap_reference_annot()}) )
## update heatmap column cluster in the wordcloud
observeEvent(input$generate_heatmap,{
shinyWidgets::updatePickerInput(session = session ,
inputId = "wordcloud_column_cluster",
choices = heatmap_column_cluster()$wide$cluster %>% gtools::mixedsort())
})
## heatmap word cloud
hm_cluster_wise_sample_infor_ll <- eventReactive(input$generate_heatmap, {
## get samples / column labels for user selected cluster
cluster_name_column_lable_tbl <- heatmap_column_cluster()$long %>%
dplyr::select(cluster, column_labels )
## get abstract from selected labels
join_col_x <- cluster_name_column_lable_tbl %>% colnames() %>% .[2] ## column having hm column labels
join_col_y <- user_selected_sra_id_sample_info() %>% colnames()%>% .[23] ## column having SRA id
cluster_wise_sample_infor_tbl <- cluster_name_column_lable_tbl %>%
left_join(user_selected_sra_id_sample_info() ,
by = setNames(join_col_y,join_col_x)) %>%
dplyr::group_by(cluster) %>%
tidyr::nest()
cluster_wise_sample_infor_ll <- cluster_wise_sample_infor_tbl %>%
dplyr::pull(2)
names(cluster_wise_sample_infor_ll) <- cluster_wise_sample_infor_tbl %>%
pull(1)
return(cluster_wise_sample_infor_ll)
})
observe({
callModule(id = "hm_sample_infor" ,
module = cluster_wise_sample_information_server , parent_id = "hm_sample_infor",
cluster_wise_sample_information = reactive(hm_cluster_wise_sample_infor_ll()))
})
####@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Download page server code ----
####@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## download GO data
callModule(module = download_go_data_server , id = "download_go_data" , ah_data = ah_data_summary2)
## download gene expression matrix
callModule(module = download_gene_expression_matrix_server , id = "download_gene_expression_data")
}
cparsania/FungiExpresZ documentation built on March 15, 2024, 5:48 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.
Defines functions app_server
Documented in app_server
#' app server
#'
#' @param input session input
#' @param output session output
#' @param session session
#' @importFrom dplyr %>%
#' @importFrom dplyr add_count
#' @importFrom dplyr add_row
#' @importFrom dplyr add_rownames
#' @importFrom dplyr add_tally
#' @importFrom dplyr all_vars
#' @importFrom dplyr any_vars
#' @importFrom dplyr arrange
#' @importFrom dplyr arrange_all
#' @importFrom dplyr arrange_at
#' @importFrom dplyr arrange_if
#' @importFrom dplyr as_data_frame
#' @importFrom dplyr as_tibble
#' @importFrom dplyr bind_cols
#' @importFrom dplyr bind_rows
#' @importFrom dplyr case_when
#' @importFrom dplyr count
#' @importFrom dplyr count_
#' @importFrom dplyr data_frame
#' @importFrom dplyr distinct
#' @importFrom dplyr distinct_all
#' @importFrom dplyr distinct_at
#' @importFrom dplyr distinct_if
#' @importFrom dplyr distinct_prepare
#' @importFrom dplyr enquo
#' @importFrom dplyr enquos
#' @importFrom dplyr everything
#' @importFrom dplyr expr
#' @importFrom dplyr filter
#' @importFrom dplyr filter_all
#' @importFrom dplyr filter_at
#' @importFrom dplyr filter_if
#' @importFrom dplyr first
#' @importFrom dplyr funs
#' @importFrom dplyr glimpse
#' @importFrom dplyr group_by
#' @importFrom dplyr group_by_
#' @importFrom dplyr group_by_all
#' @importFrom dplyr group_by_at
#' @importFrom dplyr if_else
#' @importFrom dplyr intersect
#' @importFrom dplyr last
#' @importFrom dplyr last_col
#' @importFrom dplyr left_join
#' @importFrom dplyr mutate
#' @importFrom dplyr mutate_
#' @importFrom dplyr mutate_all
#' @importFrom dplyr mutate_at
#' @importFrom dplyr mutate_each
#' @importFrom dplyr mutate_if
#' @importFrom dplyr n
#' @importFrom dplyr n_distinct
#' @importFrom dplyr n_groups
#' @importFrom dplyr na_if
#' @importFrom dplyr order_by
#' @importFrom dplyr pull
#' @importFrom dplyr quo
#' @importFrom dplyr quo_name
#' @importFrom dplyr quos
#' @importFrom dplyr rename
#' @importFrom dplyr rename_all
#' @importFrom dplyr rename_at
#' @importFrom dplyr rename_if
#' @importFrom dplyr rename_vars
#' @importFrom dplyr rename_vars_
#' @importFrom dplyr right_join
#' @importFrom dplyr row_number
#' @importFrom dplyr rowwise
#' @importFrom dplyr same_src
#' @importFrom dplyr sample_frac
#' @importFrom dplyr sample_n
#' @importFrom dplyr select
#' @importFrom dplyr select_
#' @importFrom dplyr select_all
#' @importFrom dplyr select_at
#' @importFrom dplyr select_if
#' @importFrom dplyr select_var
#' @importFrom dplyr select_vars
#' @importFrom dplyr select_vars_
#' @importFrom dplyr slice
#' @importFrom dplyr slice_
#' @importFrom dplyr setdiff
#' @importFrom dplyr starts_with
#' @importFrom dplyr summarise
#' @importFrom dplyr summarise_
#' @importFrom dplyr summarise_all
#' @importFrom dplyr summarise_at
#' @importFrom dplyr summarise_each
#' @importFrom dplyr summarise_each_
#' @importFrom dplyr summarise_if
#' @importFrom dplyr summarize
#' @importFrom dplyr summarize_
#' @importFrom dplyr summarize_all
#' @importFrom dplyr summarize_at
#' @importFrom dplyr summarize_each
#' @importFrom dplyr summarize_each_
#' @importFrom dplyr summarize_if
#' @importFrom dplyr tally
#' @importFrom dplyr tally_
#' @importFrom dplyr tbl
#' @importFrom dplyr tbl_df
#' @importFrom dplyr tibble
#' @importFrom dplyr top_n
#' @importFrom dplyr tribble
#' @importFrom dplyr ungroup
#' @importFrom dplyr union
#' @importFrom dplyr union_all
#' @importFrom dplyr vars
#' @importFrom dplyr contains
#' @importFrom dplyr if_else
#' @importFrom tidyr %>%
#' @importFrom tidyr drop_na
#' @importFrom tidyr gather
#' @importFrom tidyr nest
#' @importFrom tidyr replace_na
#' @importFrom tidyr separate
#' @importFrom tidyr separate_rows
#' @importFrom tidyr spread
#' @importFrom tidyr unite
#' @importFrom tidyr unnest
#' @importFrom magrittr %>%
#' @importFrom readr read_csv
#' @importFrom readr read_delim
#' @importFrom readr read_file
#' @importFrom readr read_lines
#' @importFrom readr read_rds
#' @importFrom readr read_tsv
#' @importFrom readr type_convert
#' @importFrom readr write_csv
#' @importFrom readr write_csv2
#' @importFrom readr write_delim
#' @importFrom readr write_file
#' @importFrom readr write_lines
#' @importFrom readr write_rds
#' @importFrom readr write_tsv
#' @importFrom rlang as_function
#' @importFrom purrr as_mapper
#' @importFrom purrr as_vector
#' @importFrom purrr compact
#' @importFrom purrr compose
#' @importFrom purrr is_list
#' @importFrom purrr keep
#' @importFrom purrr map
#' @importFrom purrr map_at
#' @importFrom purrr map_chr
#' @importFrom purrr map_dbl
#' @importFrom purrr map_depth
#' @importFrom purrr map_df
#' @importFrom purrr map_dfc
#' @importFrom purrr map_dfr
#' @importFrom purrr map_if
#' @importFrom purrr map_int
#' @importFrom purrr map_lgl
#' @importFrom purrr map_raw
#' @importFrom purrr map2
#' @importFrom purrr map2_chr
#' @importFrom purrr map2_dbl
#' @importFrom purrr map2_df
#' @importFrom purrr map2_dfc
#' @importFrom purrr map2_dfr
#' @importFrom purrr map2_int
#' @importFrom purrr map2_lgl
#' @importFrom purrr map2_raw
#' @importFrom purrr negate
#' @importFrom purrr partial
#' @importFrom purrr safely
#' @importFrom purrr set_names
#' @importFrom purrr splice
#' @importFrom tibble add_column
#' @importFrom tibble add_row
#' @importFrom tibble as_data_frame
#' @importFrom tibble as_tibble
#' @importFrom tibble as.tibble
#' @importFrom tibble column_to_rownames
#' @importFrom tibble data_frame
#' @importFrom tibble enframe
#' @importFrom tibble glimpse
#' @importFrom tibble repair_names
#' @importFrom tibble rowid_to_column
#' @importFrom tibble rownames_to_column
#' @importFrom tibble tibble
#' @importFrom glue glue
#' @importFrom stringr str_c
#' @importFrom stringr str_extract
#' @importFrom stringr str_extract_all
#' @importFrom stringr str_glue
#' @importFrom stringr str_length
#' @importFrom stringr str_match
#' @importFrom stringr str_match_all
#' @importFrom stringr str_order
#' @importFrom stringr str_pad
#' @importFrom stringr str_remove
#' @importFrom stringr str_remove_all
#' @importFrom stringr str_replace
#' @importFrom stringr str_replace_all
#' @importFrom stringr str_replace_na
#' @importFrom stringr str_sort
#' @importFrom stringr str_split
#' @importFrom stringr str_wrap
#' @importFrom forcats %>%
#' @importFrom forcats as_factor
#' @importFrom forcats fct_c
#' @importFrom forcats fct_drop
#' @importFrom forcats fct_expand
#' @importFrom forcats fct_inorder
#' @importFrom forcats fct_match
#' @importFrom forcats fct_other
#' @importFrom forcats fct_recode
#' @importFrom forcats fct_relabel
#' @importFrom forcats fct_relevel
#' @importFrom forcats fct_reorder
#' @importFrom forcats fct_reorder2
#' @importFrom clipr clear_clip
#' @importFrom clipr read_clip
#' @importFrom clipr read_clip_tbl
#' @importFrom clipr write_clip
#' @importFrom clipr write_last_clip
#' @importFrom rlang :=
#' @importFrom rlang !!
#' @importFrom rlang !!!
#' @importFrom rlang %@%
#' @importFrom rlang %@%<-
#' @importFrom rlang %|%
#' @importFrom rlang %||%
#' @importFrom rlang enquo
#' @importFrom rlang enquos
#' @importFrom rlang quo
#' @importFrom rlang quos
#' @importFrom rlang set_names
#' @importFrom tm Corpus
#' @importFrom tm Docs
#' @importFrom tm DocumentTermMatrix
#' @importFrom tm removeNumbers
#' @importFrom tm removePunctuation
#' @importFrom tm removeSparseTerms
#' @importFrom tm removeWords
#' @importFrom tm SimpleCorpus
#' @importFrom tm stemDocument
#' @importFrom tm stopwords
#' @importFrom tm TermDocumentMatrix
#' @importFrom tm termFreq
#' @importFrom tm Terms
#' @importFrom tm tm_filter
#' @importFrom tm tm_index
#' @importFrom tm tm_map
#' @importFrom tm tm_parLapply
#' @importFrom tm tm_parLapply_engine
#' @importFrom tm tm_reduce
#' @importFrom tm tm_term_score
#' @importFrom tm VCorpus
#' @importFrom tm VectorSource
#' @importFrom tm content_transformer
#' @importFrom tm stripWhitespace
#' @importFrom MASS kde2d
#' @importFrom janitor clean_names
#' @importFrom broom tidy
#' @importFrom rio convert
#' @importFrom scales squish
#' @import ggupset
#' @keywords internal
app_server <- function(input, output,session) {
# List the first level callModules here
options(shiny.maxRequestSize = 30 * 1024^2)
## prepare user applied filters' (while selecting pre loaded data) expressions .
## NOTE : following filter expressions will be used to filter the sample_info (pre loaded data) table.
## Therefore, column names - `Organism` and `strain` (given as names of vector) must be identical to the column names of the sample_info table.
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Display, filter and select existing data ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
### strains by species
strains_by_species <- reactive({
req(sample_info)
sample_info %>%
dplyr::select(species, strain, genotype) %>%
dplyr::group_by(species) %>%
dplyr::summarise(genotype = list(genotype) , strain = list(strain))
})
## Update species on sra sample info table
observe({
req(strains_by_species())
## all species
available_species <- base::unique(strains_by_species()$species)
shinyWidgets::updatePickerInput(session = session,
inputId = "select_species",
choices = available_species,
selected = "Aspergillus nidulans")
})
## get selected species strain
selected_species_strains <- reactive({
req(input$select_species ,strains_by_species())
## strains for selected species
available_strains <- strains_by_species() %>%
dplyr::filter(species == input$select_species) %>%
dplyr::select(strain) %>%
tidyr::unnest(cols = strain) %>%
tidyr::drop_na() %>%
pull(1) %>%
unique() %>%
sort()
return(available_strains)
})
## update strain info
observe({
req(selected_species_strains())
shinyWidgets::updatePickerInput(session = session,
inputId = "select_strain",
choices = selected_species_strains())
})
## reset strain filter
observeEvent(input$reset_strain_filter , {
shinyWidgets::updatePickerInput(session = session,
inputId = "select_strain",
choices = selected_species_strains())
})
## get genotypes for selected species
selected_species_genotype <- reactive({
req(input$select_species ,strains_by_species())
## genotype for selected species
available_genotype <- strains_by_species() %>%
dplyr::filter(species == input$select_species) %>%
dplyr::select(genotype) %>%
tidyr::unnest(cols = genotype) %>%
tidyr::drop_na() %>%
pull(1) %>%
unique() %>%
sort()
return(available_genotype)
})
## update genotype info
observe({
req(selected_species_genotype())
shinyWidgets::updatePickerInput(session = session,
inputId = "select_genotype",
choices = selected_species_genotype())
})
## reset genotype filter
observeEvent(input$reset_genotype_filter , {
shinyWidgets::updatePickerInput(session = session,
inputId = "select_genotype",
choices = selected_species_genotype())
})
## show number of rows selected
user_selected_rows <- reactive({
if(is.null(input$pre_loaded_data_sra_sample_info_rows_selected)){
return(0)
}else{
return(length(input$pre_loaded_data_sra_sample_info_rows_selected))
}
})
## Render text for number of rows selected
output$sra_info_number_of_rows_selected <- renderText(
paste(user_selected_rows() ,"row(s) selected")
)
## Update strain on sra sample info table
user_filters_expressions <- reactive({
u_filters_vals <- c(species = input$select_species,
strain = input$select_strain ,
genotype = input$select_genotype)
u_filters_expr <- lapply(names(u_filters_vals), function(col) {
my_filter(col, "==", value = u_filters_vals[[col]])
})
return(u_filters_expr)
})
## SRA sample info table user display
sra_sample_info_user_display <- reactive({
## add ncbi urls whereever possible
dd <- sample_info %>%
dplyr::filter(!!!user_filters_expressions())
return(dd)
})
## pre loaded data
output$pre_loaded_data_sra_sample_info <- DT::renderDataTable({
return(sra_sample_info_user_display()) #%>%
# dplyr::mutate(run_accession =
# map_chr(run_accession ,
# ~ tags$a( .x, href = paste("https://www.ncbi.nlm.nih.gov/sra/" ,
# .x ,
# sep = "") , target = "blank") %>%
# as.character()
# ))
},
selection = "multiple",
class = "cell-border stripe",
rownames = FALSE,
extensions = c("Buttons"),
server = F,
options = list(
scrollX = TRUE,
dom = "Blfrtip",
autoWidth = TRUE,
searchHighlight = TRUE,
columnDefs = list(
list(width = '700px', targets = c(5, 6,9)), # Fix width columns
list(targets = c(2,3, 8:18), visible = FALSE)# The column number must be identical to the columns in colvis extension
),
buttons =
list("copy",
list(extend = "collection", buttons = c("csv", "excel", "pdf"), text = "Download"),
list(extend = "colvis", columns = c(2,3,8:18))
), # end of buttons customization
lengthMenu = list(
c(10, 20 ,50, 70, 100,500 ) # declare values
, c(10, 20 ,50, 70, 100,500 ) # declare titles
),
pageLength = 10
), ## end of options
)
## reset rows selection in preloaded data sample information
observeEvent(input$deselect_all_rows, {
proxy <- DT::dataTableProxy("pre_loaded_data_sra_sample_info")
DT::selectRows(proxy = proxy, NULL)
})
## select all rows in preloaded data sample information
observe({
#req(pre_loaded_data_sra_sample_info())
proxy = DT::dataTableProxy("pre_loaded_data_sra_sample_info")
if (is.null(input$sra_sample_info_select_all_rows)) {
DT::selectRows(proxy = proxy, NULL)
} else if(input$sra_sample_info_select_all_rows == "TRUE") {
DT::selectRows(proxy = proxy, input$pre_loaded_data_sra_sample_info_rows_all)
}
})
## user selected SRA id sample info
user_selected_sra_id_sample_info <- eventReactive(input$submit_user_sra_samples, {
req(input$pre_loaded_data_sra_sample_info_rows_selected)
selected_rows <- input$pre_loaded_data_sra_sample_info_rows_selected
n_select <- selected_rows %>% length()
n_max_sra_limit <-1000
if(n_select > n_max_sra_limit){
shinyWidgets::sendSweetAlert(session = session ,
type = "warning",
title = "Warning...!!" ,
text = paste("Due to memory limit, current version allows maximum",
n_max_sra_limit,
"samples. You have selected " ,
n_select, "." ,
"Application will continue with first",
n_max_sra_limit, "samples.",
sep = " "))
selected_rows <- selected_rows[1:n_max_sra_limit]
}
## process user applied filter expressions
user_selected_data_sra_ids <- sra_sample_info_user_display() %>%
dplyr::slice(selected_rows)
})
## prepare tibble having sra_id and bioproject_id columns
user_selected_sra_id_to_bioproject_id <- reactive({
user_selected_sra_id_sample_info() %>% dplyr::select(bio_project , run_accession) %>%
dplyr::mutate_all( ~replace_na(. ,"--NA--"))
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## User selected SRA data ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## user selected data
user_selected_sra_id_data <- eventReactive(input$submit_user_sra_samples,{
req(user_selected_sra_id_sample_info() )
## process user applied filter expressions
user_selected_data_sra_ids <- user_selected_sra_id_sample_info()%>%
dplyr::select(23) %>% ## column 23 is Run/SRA id. IMP: change this, if column order in the sample_info table changed.
dplyr::pull(1)
## Objective : load species specific data.
## Reference annotation name of respective species will be used to load species specific data
## 1st step is to get the user reference annotation name (e.g FungiDB-39_AnidulansFGSCA4 for Aspergillus nidulans and FungiDB-39_CalbicansSC5314 for Candida albicans)
## Once reference annotation name obtained, use it to get the respective species expression .rds file name.
## Reference annotations to .rds file name mapping given in the rds object "reference_annotation_to_expr_map.rds"
## once the name of .rds file obtained, load it and get the user selected data
user_selected_species_ref_annot <- sra_sample_info_user_display()%>%
dplyr::select(2) %>% ## column 2 is get the name of ref annot
dplyr::pull(1) %>%
as.character() %>%
.[1]
#ref_annot_to_expr_rds contains two cols ---> 'reference_annotation' , 'expression_mat_data_file'
## load respective expression mat
expr_data_mat_rds_file <- ref_annot_to_expr_rds %>%
dplyr::filter(.data$reference_annotation == !!user_selected_species_ref_annot) %>%
dplyr::select(2) %>% ## 2nd column is expression_mat_data_file
pull(1) %>%
.[1] ### it make sure that if reference annot match to multiple rows, it only returns .rds data mat file for first match.
## load expr data
withProgress(message = "Loadind data from .rds" , {
incProgress(0.5)
#print("expr_mat_file_path")
#print(paste(get_expression_mats_dir_path() , expr_data_mat_rds_file , sep = "/"))
expr_data_mat <- readr::read_rds(paste(get_expression_mats_dir_path() , expr_data_mat_rds_file , sep = "/"))
incProgress(1)
})
user_selected_sra_id_data <- expr_data_mat %>%
dplyr::select(1, !!user_selected_data_sra_ids)
return(user_selected_sra_id_data)
})
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
### display active group info in the in side panel ----
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#observe(group_info,{
callModule(module = display_active_groups_server ,
id = "display_active_groups",
group_data = reactive(group_info)
)
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
### display sample info for user selected sample info in side panel ----
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
observeEvent(user_selected_sra_id_sample_info(),{
req(user_selected_sra_id_sample_info())
callModule(module = display_sra_sample_info_server ,
id = "user_selected_sra_id_sample_info" ,
user_selected_sra_sample_info_tibble = reactive(user_selected_sra_id_sample_info())
)
})
## set output status for sra sample info display on the side panel.
## UI will displayed only if sra samples selected by users
output$display_sra_sample_info_in_side_panel <- reactive({
req(user_selected_sra_id_sample_info())
return(TRUE)
})
outputOptions(x = output , name = "display_sra_sample_info_in_side_panel" , suspendWhenHidden = FALSE)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Process user uploaded data ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## user upoaded data
user_uploaded_data <- eventReactive(input$submit_user_uploaded_data,{
req(input$upload_data_source)
upload_data_source <- input$upload_data_source
data_from_user = tryCatch({
if(upload_data_source == "upload_from_file"){
req(input$file1)
data_from_user <- readr::read_delim(file = input$file1$datapath, delim = input$sep, col_names = T, trim_ws = T)
}else if(upload_data_source == "upload_from_clipboard") {
data_from_user <- text_to_tibble(text = input$user_pasted_data , sep = input$sep)
}
}, error = function(e) {
print(paste("File uploading error." , e, sep = " "))
return(NULL)
} , warning = function(w){
print(paste("File uploaded with warnings." , w, sep = " "))
return(NULL)
})
## show alert/error if error produced while reading file.
if(is.null(data_from_user)){
shinyWidgets::sendSweetAlert(session = session ,type = "error",title = "Error...!!" ,text = paste("Error while reading the data. Probably unsupported file format (if uploaded from file) or uncorrect pasted data.", sep = " "))
return(NULL)
}
## error if first column is not type char
if(!purrr::map_lgl(data_from_user[1], is.character) ){
shinyWidgets::sendSweetAlert(session = session ,type = "error",title = "Error...!!" ,text = paste("First column must be of type character.", sep = " "))
return(NULL)
}
## other than 1st column, all must be of type nueric
if( ! all(purrr::map_lgl(data_from_user[-1], is.numeric)) ){
shinyWidgets::sendSweetAlert(session = session ,type = "error",title = "Error...!!" ,text = paste("Other than first column, all must be of type numeric.", sep = " "))
return(NULL)
}
## column 1 must not have duplicates.
if(any(base::duplicated(data_from_user[[1]]))){
shinyWidgets::sendSweetAlert(session = session ,type = "error" ,title = "Error...!!" ,text = paste("Column 1 must have unique values.", sep = " "))
return(NULL)
}
## uploded data must have atleast two columns
if(base::ncol(data_from_user) < 2){
shinyWidgets::sendSweetAlert(session = session ,type = "error",title = "Error...!!" ,text = paste("Uploaded data must have atleast 2 columns.\n Make sure that you have selected correct separator.", sep = " "))
return(NULL)
}
## remove genes which are 0 in all samples
processed_data <- data_from_user %>%
tidyr::drop_na() %>% ## genes will be dropped if any column contain NA
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
## log2 trasform user uploaded data
if(input$log_transform_user_upload_data == "log2"){
processed_data <- processed_data %>%
dplyr::filter_if(is.numeric , dplyr::any_vars( . > 0)) %>% ## remove genes having negative values (value < 0) in any sample
dplyr::mutate_if(is.numeric , ~(log2( . + 1)))
}
## log10 trasform user uploaded data
if(input$log_transform_user_upload_data == "log10"){
processed_data <- processed_data %>%
dplyr::filter_if(is.numeric , dplyr::any_vars( . > 0)) %>%## remove genes having negative values (value < 0) in any sample
dplyr::mutate_if(is.numeric , ~(log10( . + 1)))
}
## remove na and round the values.
processed_data <- processed_data %>%
dplyr::mutate_if(is.numeric, round, 4) %>% ## 4 digits after decimal
as_tibble() %>%
tidyr::drop_na() ## rows containing NA (after log transform) will be removed
## check the number of rows in the processed data. if number of row remain zero throw error.
if(base::nrow(processed_data) == 0 ){
warning_text <- paste("All genes have value NA after log transformation (if selected) in one of the sample or value 0 in all the samples. Please upload correct data. If log transformation used, make sure that values are non-negative. ")
shinyWidgets::sendSweetAlert(session = session ,
type = "error",
title = "Error...!!" ,
text = warning_text)
return(NULL)
}
## Update alert type depending on number of genes remained after removing NA.
## if number of rows in the processed data less than user uploaded rows, throw warning.
if(base::nrow(processed_data) < base::nrow(data_from_user)){
genes_removed <- dplyr::setdiff(data_from_user[[1]] , processed_data[[1]])
type = "warning"
title = "Data upload with warning...!!!"
numb_of_genes_removed <- base::nrow(data_from_user) - base::nrow(processed_data)
text <- tags$h5(numb_of_genes_removed,
" genes have been removed due to one of the following reasons...",
tags$br(),tags$br(),
"1). Genes have value NA in one of the sample. NA found either directly from uploaded data or due to log transformation (if selected).",
tags$br(),tags$br(),
"2). Genes have value 0 in all the samples.",
tags$br(),tags$br(),
"Removed genes are ...",
tags$br(),tags$br(),
tags$h5(paste0(genes_removed , collapse = ","),
style = "height: 50px;white-space:nowrap;overflow-x:auto;"), style = "text-align:justify;")
## if number of rows in the processed data equal to the user uploaded rows, show success.
} else if(base::nrow(processed_data) == base::nrow(data_from_user)) {
type = "success"
title = "Success...!!!"
text <- paste("Data uploaded successfully.")
}
shinyWidgets::sendSweetAlert(session = session ,
type = type,
title = title ,
text = text )
## column names replace space to "_", this must be applied to groups also when group info uploaded from file
user_uploaded_processed_data <- processed_data %>%
rename_all(function(.){gsub(pattern = " " , "_" , .)})
return(user_uploaded_processed_data)
})
## disable UI elems if upload example data checked on
observe({
if(input$upload_sample_data){
shinyjs::hide(id ="user_data_upload_section")
shinyWidgets::updateProgressBar(session = session , id = "upload_sample_data_pb" , value = 100)
} else {
shinyjs::show(id ="user_data_upload_section")
shinyWidgets::updateProgressBar(session = session , id = "upload_sample_data_pb" , value = 0)
}
## enable disable data upload. at a time either of the upload from file or upload from clipboard will be enabled
if(input$upload_data_source == "upload_from_file"){
shinyjs::enable(id = "file1")
} else{
shinyjs::disable(id = "file1")
}
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Finalize active plot data ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
plot_data <- reactiveVal(NULL)
## when user hit action button on sra sample info page, update plot data.
observeEvent(input$submit_user_sra_samples ,{
req(user_selected_sra_id_data())
final_data <- user_selected_sra_id_data() %>%
tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
if(nrow(final_data) == 0 ){ ## send error if number of rows remained after removing na is 0.
sendSweetAlert(
session = session,
title = "Error...",
text = "All the rows have atleast one missing or NA value found. Input file needs to be fixed.",
type = "error"
)
plot_data(NULL)
}
## display success alert when data uploaded
sendSweetAlert(
session = session,
title = paste(final_data %>% ncol() - 1 , "data selected"),
text = paste("Selected data now available for analysis.\n\nRun accession will be used as identifier for downstream analysis.\n\nClose selection window to use data further.\n\n"),
type = "success"
)
plot_data(final_data)
})
## if user upload the data , make it plot data
observeEvent(user_uploaded_data(),{
req(user_uploaded_data()) ## to execute this user data must be available
final_data <- user_uploaded_data() %>%
tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(final_data)
})
## make plot data to example data when th eaction button input$upload_sample_data triggered
observeEvent(input$upload_sample_data,{
if(input$upload_sample_data){
example_data_file = system.file("app", "cartoon_data" ,"cartoon_log2fpkm_log2fc.txt" ,package = "FungiExpresZ" )
example_data <- readr::read_delim(file = example_data_file , delim = "\t") %>%
tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(example_data)
}
## if input$upload_sample_data == FALSE set NULL
else {
plot_data(NULL)
}
})
## when submit_user_uploaded_data triggered and join data button is on
observeEvent(input$submit_user_uploaded_data,{
req(input$join_user_data, user_uploaded_data()) ## to execute this user data must be available
user_upload_join_by <- colnames(user_uploaded_data())[1]
merge_data <- user_uploaded_data() %>%
dplyr::left_join(user_selected_sra_id_data() , by = set_names("geneName" , user_upload_join_by))
merge_data <- merge_data %>% tidyr::drop_na() ## rows with NA after merger will be removed.
## send warning if number of rows remained after removing na is < user_uploaded_data()
if(merge_data %>% nrow() < user_uploaded_data() %>% nrow() && merge_data %>% nrow() > 0){
sendSweetAlert(
session = session,
title = "Warning...!",
text = paste0("Only ", merge_data %>% nrow(), " out of " , user_uploaded_data() %>% nrow() , " genes matched to database ID. Application will continue with ", merge_data %>% nrow() , " genes."),
type = "warning"
)
final_data <- merge_data %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(final_data)
}
## send warning if number of rows remained after removing na is 0 return user uploaded data
if(nrow(merge_data) == 0 ){
sendSweetAlert(
session = session,
title = "Warning...",
text = "None of the ID from first column of uploaded data match with database id. Either fix the input id or application continue with uploaded data.",
type = "warning"
)
final_data <- user_uploaded_data() %>%
tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(final_data)
}
## send success message if All the IDs from the first column of uploaded data match with database id
if(merge_data %>% nrow() >= user_uploaded_data() %>% nrow()){
sendSweetAlert(
session = session,
title = "Data joined successfully...",
text = "All the IDs from the first column of uploaded data matched with database id.",
type = "success"
)
final_data <- merge_data %>% tidyr::drop_na() %>%
dplyr::filter_if(is.numeric , .vars_predicate = dplyr::any_vars(. != 0 )) ## select genes which have atleast one non zero value
plot_data(final_data)
}
})
## print final plot data on terminal
observe({
req(plot_data())
# print("plot_data dims")
# print(dim(plot_data()))
# print("plot_data")
# print(plot_data())
})
## preserve plot data original row order
plot_data_original_row_order <- reactive({
req(plot_data())
orig_row_ord <- plot_data() %>%
dplyr::select(1) %>%
dplyr::mutate(!!generate_random_strings(1) := dplyr::row_number())
return(orig_row_ord)
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Define groups ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
##reactive values containing group info
group_info <- reactiveValues()
## User defined column groups
user_defined_column_groups <- callModule(module = add_sample_group , id = "sample_group" ,
sample_names = reactive(base::colnames(plot_data())[-1]) ,
bioproject_groups = reactive(user_selected_sra_id_to_bioproject_id()))
## Assign user groups to reactive values. Below observe will be executed if user_defined_groups changed
observe({
group_info$column_groups <- user_defined_column_groups()
})
## User defined row groups
user_defined_row_groups <- callModule(module = add_gene_groups , session = session,
id = "gene_groups" ,
gene_names = reactive( plot_data() %>% .[[1]] ))
## Assign user defined row groups
observe({
group_info$row_groups <- user_defined_row_groups()
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Reset UI elems of each plot panel based on data being uploaded or selected from pre-loaded ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
### if no rows selected, remove x/y choices
observe({
# if ((input$data_selection == "select_sample" &
# base::is.null(input$pre_loaded_data_sra_sample_info_rows_selected)) |
# (input$data_selection == "upload_user_data" & base::is.null(input$file1))
# ) {
if(is.null(plot_data())){
## update scatter x
updateSelectInput(
session = session,
inputId = "scatter_x",
choices = character(0)
)
## update scatter y
updateSelectInput(
session = session,
inputId = "scatter_y",
choices = character(0)
)
## update multi scatter x
updateSelectInput(
session = session,
inputId = "multi_scatter_vars",
choices = character(0)
)
## update density x
updateSelectInput(
session = session,
inputId = "density_x",
choices = character(0)
)
## update box x
updateSelectInput(
session = session,
inputId = "box_x",
choices = character(0)
)
## update line x
updateSelectInput(
session = session,
inputId = "lineplot_x",
choices = character(0)
)
## joy plot
updateSelectInput(
session = session,
inputId = "joy_plot_x",
choices = character(0)
)
## heatmap vars
updateSelectInput(
session = session,
inputId = "heatmap_vars",
choices = character(0)
)
## pca plot
updateSelectInput(
session = session,
inputId = "pca_plot_vars",
choices = character(0)
)
## corr heat box
updateSelectInput(
session = session,
inputId = "corr_heatbox_vars",
choices = character(0)
)
## violin
updateSelectInput(
session = session,
inputId = "violin_x",
choices = character(0)
)
## histogram
updateSelectInput(
session = session,
inputId = "histogram_x",
choices = character(0)
)
## bar
updateSelectInput(
session = session,
inputId = "barplot_vars",
choices = character(0)
)
}
### if no file uploaded, remove x/y choices
# if (input$data_selection == "upload_user_data" & base::is.null(input$file1)) {
#
# ## update scatter x
# updateSelectInput(
# session = session,
# inputId = "scatter_x",
# choices = character(0)
# )
#
# ## update scatter y
# updateSelectInput(
# session = session,
# inputId = "scatter_y",
# choices = character(0)
# )
#
# ## update multi scatter x
# updateSelectInput(
# session = session,
# inputId = "multi_scatter_vars",
# choices = character(0)
# )
#
#
# ## update density x
# updateSelectInput(
# session = session,
# inputId = "density_x",
# choices = character(0)
# )
#
# ## update box x
# updateSelectInput(
# session = session,
# inputId = "box_x",
# choices = character(0)
# )
#
# ## update line x
# updateSelectInput(
# session = session,
# inputId = "lineplot_x",
# choices = character(0)
# )
#
# ## joy plot
# updateSelectInput(
# session = session,
# inputId = "joy_plot_x",
# choices = character(0)
# )
#
# ## heatmap vars
# updateSelectInput(
# session = session,
# inputId = "heatmap_vars",
# choices = character(0)
# )
#
# ## pca plot
# updateSelectInput(
# session = session,
# inputId = "pca_plot_vars",
# choices = character(0)
# )
#
# ## corr heat box
# updateSelectInput(
# session = session,
# inputId = "corr_heatbox_vars",
# choices = character(0)
# )
#
# ## violin
# updateSelectInput(
# session = session,
# inputId = "violin_x",
# choices = character(0)
# )
# ## histogram
# updateSelectInput(
# session = session,
# inputId = "histogram_x",
# choices = character(0)
# )
#
# ## bar
# updateSelectInput(
# session = session,
# inputId = "barplot_vars",
# choices = character(0)
# )
#
#
# }
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Fix reference annotations ----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
genome_for_annotations <- reactiveVal(NULL)
## reference annot when user choose SRA data
observeEvent(input$submit_user_sra_samples , {
#if(input$data_selection == "select_sample"){ ## when data selected from existing one
req(input$pre_loaded_data_sra_sample_info_rows_selected)
genome_for_annotations <- sample_info %>% ## sample_info is pre loaded data
dplyr::filter(!!!user_filters_expressions()) %>% ## filter by user applied filters
dplyr::select(2) %>% ## column 2 is reference_annotation columns. it contains genome name identical to fungidb annotations. IMP: change this, if column order in the sample_info table changed.
dplyr::slice(input$pre_loaded_data_sra_sample_info_rows_selected)%>% ## user selected rows
dplyr::pull(1)
genome_for_annotations(genome_for_annotations[1])
})
## reference annot when user upload data or select example data
observe({
genome_for_annotations(input$user_selected_species)
if(input$upload_sample_data){
genome_for_annotations("FungiDB-64_CalbicansSC5314")
}
})
## Check current annotations
observe({
req(genome_for_annotations())
#print(paste("User selected geneome", genome_for_annotations() ,sep = " "))
})
## For selected genome sample ids
output$sample_selected_species_gene_id <- renderText({
req(genome_for_annotations())
sample_ids_to_display <- tryCatch({
ah_data_summary2 %>%
dplyr::filter(genome == genome_for_annotations()) %>%
dplyr::select(gr_cols) %>%
tidyr::unnest(cols = gr_cols) %>%
dplyr::pull(ID) %>% sample(20) %>% paste0(collapse = ", ")
}, error = function(x){
return("Trouble to get Ids")
})
return(sample_ids_to_display)
})
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# scatter plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
## Question : Both evenReactive and observeEvent can be invalidated by action button.
## Then, why am I using eventReactive here ? Why not observeEvent ??
## Ans :: eventReactive is there to delay the reactions. Given the reactive value, it triggers the chunk of code and
## return some values, which can be cached and used further in the app. While, observeEvent is also there to trigger the action
## on the basis of given reactive values but it does not return anything. It has side effects. Side effects are the actions due
## to functions but without returning anything.
## check whether x and y are numeric type
scatter_vars_validated <- eventReactive(input$generate_scatter, {
req(input$scatter_x, input$scatter_y, plot_data())
x_vals <- plot_data()[, input$scatter_x][[1]]
y_vals <- plot_data()[, input$scatter_y][[1]]
## validate user selected variables
if (!is.numeric(x_vals)) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = "X must be of type numeric",
type = "error"
)
return(FALSE)
} else if (!is.numeric(y_vals)) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = "Y must be of type numeric",
type = "error"
)
return(FALSE)
}
return(TRUE)
})
## update plot axis limits, reason to use observe event is,
## it won't cache the values in the computer memory. Whenever user clicks on "Generate Plot" (input$plot) invalidated
## the axis limits will be updated.
observeEvent(input$generate_scatter, {
req(scatter_vars_validated())
# selected x y cols
x_vals <- plot_data()[, input$scatter_x][[1]]
y_vals <- plot_data()[, input$scatter_y][[1]]
# calculate axis limits
# xlim
x_range <- round(range(x_vals), 3)
# ylim
y_range <- round(range(y_vals), 3)
# update UI
# X min and max
updateNumericInput(
session = session,
inputId = "plot_xmin",
min = x_range[1],
max = x_range[2],
value = x_range[1]
)
updateNumericInput(
session = session,
inputId = "plot_xmax",
min = x_range[1],
max = x_range[2],
value = x_range[2]
)
# Y min and max
updateNumericInput(
session = session,
inputId = "plot_ymin",
min = y_range[1],
max = y_range[2],
value = y_range[1]
)
updateNumericInput(
session = session,
inputId = "plot_ymax",
min = y_range[1],
max = y_range[2],
value = y_range[2]
)
})
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "scatter_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
## update y
updatePickerInput(
session = session,
inputId = "scatter_y",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## scatter plot user selected gene group data
scatter_plot_data <- callModule(module = gene_group_selection ,
id = "scatter_plot_select_gene_groups" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_scatter),
current_session_data_matrix = plot_data)
### current scatter plot genome, updates only when generate scatter hits.
current_scatter_plot_genome <- eventReactive(input$generate_scatter , {
return(genome_for_annotations())
})
## get scatter plot elements : corr value, density, intercept , slope and base ggplot
scatter_plot_elems <- eventReactive(input$generate_scatter, {
req(scatter_plot_data())
xvar <- scatter_plot_data() %>% dplyr::pull(input$scatter_x)
yvar <- scatter_plot_data() %>% dplyr::pull(input$scatter_y)
# linear model param
mm <- lm(formula = yvar ~ xvar)
linear_model_param <- broom::tidy(mm)
# calculte corr value
xvar <- scatter_plot_data() %>% dplyr::pull(input$scatter_x)
yvar <- scatter_plot_data() %>% dplyr::pull(input$scatter_y)
corr <- cor(xvar, yvar)
scatter_xy_corr <- format(round(corr, 3), nsmall = 2) ## restric digits after decimal
# calculate density
x_y_density <- get_density(scatter_plot_data()[, input$scatter_x][[1]], scatter_plot_data()[, input$scatter_y][[1]])
# xy scatter plot
gp <- ggplot(scatter_plot_data(), aes_string(x = as.symbol(input$scatter_x), y = as.symbol(input$scatter_y)))
gff_feat = ah_data_summary2 %>%
dplyr::filter(genome == current_scatter_plot_genome()) %>%
dplyr::select(gr_cols) %>%
tidyr::unnest(cols = gr_cols)
return(list(linear_model_param = linear_model_param,
scatter_xy_corr = scatter_xy_corr, gp = gp,
x_y_density = x_y_density,
gff_feat = gff_feat))
})
# observe({
# req(scatter_plot_data())
# #print(scatter_plot_data())
# })
## scatterplot condition panel:show only if variable (x, y) validated and displayed on UI
output$scatter_plot_status <- reactive({
req(final_scatter())
return(TRUE)
})
outputOptions(output, "scatter_plot_status", suspendWhenHidden = FALSE)
## final scatter plot
final_scatter <- reactive({
req(scatter_vars_validated() , scatter_plot_elems() ,
input$plot_xmin, input$plot_xmax,input$plot_ymin, input$plot_ymax
)
# req(input$plot_xmax,input$plot_xmin) ## all four xmin, xmax, ymin and ymax must be there to generate the plot
withProgress(message = "Preparing scatter plot", {
incProgress(0.5)
## color by density, default colors
if (input$scatter_color_chooser == "default") {
gp <- scatter_plot_elems()$gp +
geom_point(aes(color = scatter_plot_elems()$x_y_density),
alpha = input$scatter_alpha , size= input$scatter_point_size) +
viridis::scale_color_viridis()
}
## color by density, user defined colors
if (input$scatter_color_chooser == "manual") {
gp <- scatter_plot_elems()$gp +
geom_point(aes(color = scatter_plot_elems()$x_y_density), alpha = input$scatter_alpha , size= input$scatter_point_size) +
scale_color_gradientn(colours = c(input$scatter_col_low, input$scatter_col_medium, input$scatter_col_high))
}
## color by genesets , default colors
if (input$scatter_color_chooser == "by_gene_groups") {
gp <- scatter_plot_elems()$gp +
geom_point(aes(color = gene_groups), alpha = input$scatter_alpha , size= input$scatter_point_size) +
scale_color_discrete()
}
# real time change of axis limits.
gp <- gp +
xlim(input$plot_xmin, input$plot_xmax) +
ylim(input$plot_ymin, input$plot_ymax)
## default plot title
gp <- callModule(module = plot_title_and_axis_label_server ,
id = "scatter_plot_title_and_labels",
my_ggplot = gp ,
plot_title = base::paste("Pearson correlation:",
scatter_plot_elems()$scatter_xy_corr, sep = ""),
axis_x_title = shiny::isolate(input$scatter_x),
axis_y_title = shiny::isolate(input$scatter_y),
x_tick_angle = 0,
color_legend_title = ifelse(input$scatter_color_chooser == "by_gene_groups" , "Groups", "Density")
)
## add / remove regression line
if (input$scatter_diagonal_line == "manual") {
gp <- gp + geom_abline(slope = input$manual_slope, intercept = input$manual_intercept)
}
if (input$scatter_diagonal_line == "from_data") {
i_cept <- scatter_plot_elems()$linear_model_param %>% dplyr::filter(term == "(Intercept)") %>% pull(estimate)
slope <- scatter_plot_elems()$linear_model_param %>% dplyr::filter(term == "xvar") %>% pull(estimate)
gp <- gp + geom_abline(intercept = i_cept, slope = slope )
}
incProgress(1)
})
return(gp)
})
## render scatter plot
output$scatter_plot <- renderPlot({
req(final_scatter())
final_scatter()
},
height = function() {
return(session$clientData$output_scatter_plot_width) ## dynamic height
},
width = function() {
return(session$clientData$output_scatter_plot_width) ## dynamic height
}, res = 96
) ## dynamic resolution
## render corr value
output$scatter_xy_corr <- renderText({
return(scatter_plot_elems()$scatter_xy_corr)
})
## brush table for scatter plot
scatter_plot_brushed_points <- eventReactive(input$plot_brush, {
req(scatter_plot_data())
scatter_plot_brushed_points <- brushedPoints(
df = scatter_plot_data(),
brush = input$plot_brush,
xvar = scatter_plot_elems()$gp$labels$x, #input$scatter_x
yvar = scatter_plot_elems()$gp$labels$y
)
#map metadata info to geneNames
join_col_x <- base::colnames(scatter_plot_brushed_points)[1] ## first column containing geneNames
join_col_y <- base::colnames(scatter_plot_elems()$gff_feat)[7] ## "id" column
display_data <- scatter_plot_brushed_points %>%
left_join(scatter_plot_elems()$gff_feat, by = setNames(join_col_y, join_col_x)) %>%
dplyr::select(1,c("seqnames", "start", "end","width", "strand", "description"), dplyr::everything())
return(display_data)
})
## render brushed data
output$brush_table <- DT::renderDataTable({
req(scatter_plot_brushed_points())
return(scatter_plot_brushed_points() %>%
dplyr::mutate_all(funs(replace_na(as.character(.),"--NA--"))) %>%
dplyr::mutate_if(is.numeric , round , 2))
},selection = "none",
server = F,
extensions = c("Buttons"),
options = list(
deferRender = TRUE,
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy",
list(extend ="collection",
buttons = c("csv", "excel", "pdf"), text = "Download"
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500 ) # declare values
, c(10, 50, 100, 500) # declare titles
),
pageLength = 10
)
)
## call module to download scatter plot
callModule(module = export_plot,
id = "export_scatter",
file_name = "scatter",
plot = final_scatter
)
## call module for scatter plot functional analysis
callModule(module = functional_analysis_server ,
id = "scatterplot_functional_analysis_ui" ,
ui_id = "scatterplot_functional_analysis_ui",
session = session,
gene_set = reactive(split(x = scatter_plot_brushed_points()[[1]], ## genename
f = "1")) ,
genome = reactive(genome_for_annotations()) )
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# multi scatter plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## check whether x and y are numeric type
multi_scatter_vars_validated <- eventReactive(input$generate_multi_scatter, {
req(input$multi_scatter_vars)
selected_vars <- plot_data() %>% dplyr::select(input$multi_scatter_vars)
col_class <- plot_data() %>%
dplyr::select(input$multi_scatter_vars) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather()
if (!all(col_class$value)) {
non_numeric_cols <- col_class %>% dplyr::filter(!value)
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0(paste0(non_numeric_cols$key, collapse = " "), " must be of type numeric", collapse = ""),
type = "error"
)
return(FALSE)
}
if (length(input$multi_scatter_vars) > 5) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Due to memory limit, maximum 5 variables allowed at moment. Try CorrHeatBox for more than 5 variables."),
type = "error"
)
return(FALSE)
}
else {
return(TRUE)
}
})
## multi scatterplot condition panel:show only if variable (x, y) validated and displayed on UI
output$multi_scatter_plot_status <- reactive({
req(final_multi_scatter_plot())
return(TRUE)
})
outputOptions(output, "multi_scatter_plot_status", suspendWhenHidden = FALSE)
## update x variables
observe({
req(plot_data())
## update x
updatePickerInput(
session = session,
inputId = "multi_scatter_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## multi scatter plot user selected gene group data
multi_scatter_plot_data <- callModule(module = gene_group_selection ,
id = "multi_scatter_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_multi_scatter),
current_session_data_matrix = plot_data
)
## prepare multi scatter plot
ggpair_plot <- eventReactive(input$generate_multi_scatter, {
req(multi_scatter_plot_data() , multi_scatter_vars_validated())
gp <- GGally::ggpairs(multi_scatter_plot_data(),
columns = c(input$multi_scatter_vars),
upper = list(continuous = GGally::wrap("cor",
size = input$multi_scatter_corr_text_text_size ,
color = input$multi_scatter_corr_text_col)))
return(gp)
})
## multi scatter final plot
final_multi_scatter_plot <- reactive({
req(ggpair_plot())
multi_scatter_gp <- ggpair_plot()
## decorate multi scatter through module
multi_scatter_gp <- callModule(module = plot_title_and_axis_label_server ,
id = "multi_scatter_plot_title_and_labels" ,
my_ggplot = multi_scatter_gp ,
axis_x_title = "Value" ,
axis_y_title = "Value",
x_tick_angle = 0 ,
aspect_ratio =NULL)
return(multi_scatter_gp)
})
output$multi_scatter_plot <- renderPlot({
req(final_multi_scatter_plot())
return(
withProgress(message = "Display multi-scatter plot in progress",{
incProgress(0.5)
print(final_multi_scatter_plot())
incProgress(1)
})
)
},
height = function() {
return(session$clientData$output_multi_scatter_plot_width)
}, ## dynamic height
width = function() {
return(session$clientData$output_multi_scatter_plot_width)
}
) ## dynamic width
## call module to export multi scatter plot
callModule(module = export_plot,
id = "export_multi_scatter" ,
file_name = "multi_scatter_plot",
plot = final_multi_scatter_plot )
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# CorrHeatBox server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "corr_heatbox_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## check whether selected x var(s) are of numeric type
corr_heatbox_vars_validated <- eventReactive(input$generate_corr_heatbox, {
req(input$corr_heatbox_vars)
## validate selected variables
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$corr_heatbox_vars)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## corr_heatbox status
output$corr_heatbox_status <- reactive({
req(final_corr_heatbox())
return(TRUE)
})
outputOptions(output, "corr_heatbox_status", suspendWhenHidden = FALSE)
## corr heat box user selected gene group data
corr_heatbox_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "corr_heat_box_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_corr_heatbox),
current_session_data_matrix = plot_data
)
## prepare corr_heatbox data
corr_heatbox_data <- eventReactive(input$generate_corr_heatbox, {
req(input$corr_heatbox_vars, corr_heatbox_vars_validated() , corr_heatbox_user_selected_gene_group_data())
withProgress(message = "Preparing CorrHeatBox " , {
incProgress(0.5)
## tibble to data.frame with row names
corr_heatbox_data <- corr_heatbox_user_selected_gene_group_data() %>%
dplyr::select(1,c(input$corr_heatbox_vars)) %>%
as.data.frame() %>%
tibble::column_to_rownames(colnames(corr_heatbox_user_selected_gene_group_data())[1])
## calculate correlation
corr_mat <- tryCatch({
cor_mat <- stats::cor(corr_heatbox_data)
},error = function(e){
return(NULL)
})
incProgress(1)
})
return(corr_mat)
})
## show error if corr data is NULL
observe({
if(is.null(corr_heatbox_data())){
shinyWidgets::sendSweetAlert(session = session,title = "Error..!",
text = "Error while calculating correlation (stats::cor). Please check the data.")
}
})
## final corrHeatBox
final_corr_heatbox <- reactive({
req(corr_heatbox_data())
chb <- tryCatch({
chb <- ggcorrplot::ggcorrplot(corr = corr_heatbox_data() ,
method = input$heatbox_method ,
type = input$heatbox_type,
hc.order = input$cluster_heatbox,
show.diag = as.logical(input$heatbox_show_diag),
lab_col = input$heatbox_corr_text_col ,
lab_size = input$heatbox_corr_text_text_size,
lab = input$heatbox_show_corr_value
)
},error = function(e){
return(NULL)
})
## return NULL (at function) if ggcorrplot::ggcorrplot throws an error
if(is.null(chb)){
return(NULL)
}
## set color scale auto:
if(input$corr_heatbox_scale_manual == "auto"){
chb <- chb +
scale_fill_gradientn(colours = viridis::viridis(n = input$corr_heatbox_colors) %>% rev())
}
## set color scale manual
if(input$corr_heatbox_scale_manual == "manual"){
chb <- chb +
scale_fill_gradientn(colours = viridis::viridis(n = input$corr_heatbox_colors) %>% rev(),
limits = c(input$corr_heatbox_scale_manual_min , input$corr_heatbox_scale_manual_max) , oob=scales::squish)
}
## decorate plot
chb <- callModule(plot_title_and_axis_label_server,
id = "corr_heatbox_title_and_labels" ,
my_ggplot = chb, x_tick_angle = 45 ,
fill_legend_title = "Corr",
apply_theme =FALSE)
return(chb)
})
## show error if corr data is NULL
observe({
if(is.null(final_corr_heatbox())){
shinyWidgets::sendSweetAlert(session = session,title = "Error..!",
type = "error",
text = "Error while generating corr plot (ggcorrplot::ggcorrplot). Make sure that you selected at least two samples or else check input data.")
}
})
## render corr_heatbox
output$corr_heatbox <- renderPlot({
req(final_corr_heatbox())
return(print(final_corr_heatbox()))
}, height = function() {
return(session$clientData$output_corr_heatbox_width)
}, width = function() {
return(session$clientData$output_corr_heatbox_width)
}, res = 90)
## render corr heat box data
output$corr_heatbox_data <- DT::renderDataTable({
req(corr_heatbox_data())
return(corr_heatbox_data() %>%
as.data.frame() %>%
rownames_to_column("RowNames") %>%
as_tibble() %>%
dplyr::mutate_if(is.numeric, function(i){round(i,2)}))
},selection = "none",
server = F,
extensions = "Buttons",
options = list(
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy",
list(extend ="collection",
buttons = c("csv", "excel", "pdf"), text = "Download"
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500, -1) # declare values
, c(10, 50, 100, 500, "All") # declare titles
),
pageLength = 10
)
)
## export corr heat box
callModule(module = export_plot,
id = "export_corr_heatbox" ,
file_name = "corr_heatbox",
plot = final_corr_heatbox )
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# density plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "density_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## check whether selected x var(s) are of numeric type
density_vars_validated <- eventReactive(input$generate_density, {
req(input$density_x)
## validate selected variables
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$density_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## density plot status
output$density_plot_status <- reactive({
req(final_density_plot())
return(TRUE)
})
outputOptions(output, "density_plot_status", suspendWhenHidden = FALSE)
## density plot user selected gene group data
density_plot_data <- callModule(module = gene_group_selection ,
id = "density_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_density),
current_session_data_matrix = plot_data
)
## density plot
dp <- eventReactive(input$generate_density, {
req(density_plot_data() , density_vars_validated())
withProgress(message = "Preparing density plot" , {
incProgress(0.5)
plot_data <- density_plot_data() %>%
dplyr::select(c(input$density_x , !!as.symbol("gene_groups")))
melted <- plot_data %>%
tidyr::gather(samples, value , -gene_groups) %>%
left_join(group_info$column_groups , by = c (samples = "group_members")) %>% ## addd sample groups
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::arrange(groups , samples)%>%
dplyr::mutate(samples = forcats::fct_inorder(samples))
incProgress(1)
})
## base density plot
dp <- ggplot(melted, aes(x = value, fill = samples))
return(dp)
})
## final density plot
final_density_plot <- reactive({
## dynamic alpha
req(dp())
dp <- dp() + geom_density(alpha = input$density_plot_alpha) #+ theme_bw()
## fill and facet density plot
out <- callModule(module = ggplot_fill_and_facet ,
id = "density_plot_fill_and_facet" ,
ggplot = dp , allow_x_var_selection = FALSE)
dp <- out$plot
## decorate plot
dp <- callModule(plot_title_and_axis_label_server ,
id = "decorate_density_plot" ,
my_ggplot = dp ,
axis_x_title = "Value",
x_tick_angle = 0,
axis_y_title = "Density",
fill_legend_title = out$fill_var,
color_legend_title = out$fill_var
)
return(dp)
})
## render density plot
output$density_plot <- renderPlot({
return(print(final_density_plot()))
}, height = function() {
return(session$clientData$output_density_plot_width)
}, width = function() {
return(session$clientData$output_density_plot_width)
}, res = 90)
## prepare density plot data to be shown as table
density_filtered_column <- eventReactive(dp(), {
dd <- plot_data()
return(dd)
})
## render density plot data
output$density_filtered_column_display <- DT::renderDataTable({
return(density_filtered_column())
})
callModule(module = export_plot, id = "export_density" , file_name = "density_plot", plot = final_density_plot )
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# histogram server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "histogram_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## check whether selected x var(s) are of numeric type
histogram_vars_validated <- eventReactive(input$generate_histogram, {
req(input$histogram_x)
## validate selected variables
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$histogram_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## histogram status
output$histogram_status <- reactive({
req(final_histogram())
return(TRUE)
})
outputOptions(output, "histogram_status", suspendWhenHidden = FALSE)
## get histogram gene group specific data
histogram_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "histogram_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_histogram),
current_session_data_matrix = plot_data)
## histogram
hg <- eventReactive(input$generate_histogram, {
req(input$histogram_x, histogram_vars_validated() , histogram_user_selected_gene_group_data())
withProgress(message = "Preparing histogram" , {
incProgress(0.5)
plot_data <- histogram_user_selected_gene_group_data() %>%
dplyr::select(c(input$histogram_x , !!as.symbol("gene_groups")))
melted <- plot_data %>%
tidyr::gather(samples, value , -gene_groups) %>%
left_join(group_info$column_groups , by = c (samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::arrange(groups , samples)%>%
dplyr::mutate(samples = forcats::fct_inorder(samples))
incProgress(1)
})
hg <- ggplot(melted, aes(x = value, fill = samples, col = samples))
return(hg)
})
## final histogram
final_histogram <- reactive({
## dynamic alpha
req(hg())
hg <- hg() + geom_histogram(alpha = input$histogram_alpha ,
position = input$histogram_positions ,
bins = input$histogram_number_of_bins , col ="black")
## fill and facet histogram
out <- callModule(module = ggplot_fill_and_facet ,
id = "histogram_fill_and_facet" ,
ggplot = hg , allow_x_var_selection = FALSE)
hg <- out$plot
## decorate plot
hg <- callModule(plot_title_and_axis_label_server ,
id = "decorate_histogram" ,
my_ggplot = hg ,
axis_x_title = "Value",
x_tick_angle = 0,
axis_y_title = "Count",
fill_legend_title = out$fill_var,
color_legend_title = out$fill_var
)
## remove legend title
return(hg)
})
## render histogram
output$histogram <- renderPlot({
return(print(final_histogram()))
}, height = function() {
return(session$clientData$output_histogram_width)
}, width = function() {
return(session$clientData$output_histogram_width)
}, res = 90)
callModule(module = export_plot, id = "export_histogram" , file_name = "histogram", plot = final_histogram)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Joy plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x, y variables
observe({
## update x
updatePickerInput(
session = session,
inputId = "joy_plot_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## check whether selected x var(s) are of numeric type
joy_plot_vars_validated <- eventReactive(input$generate_joy_plot, {
req(input$joy_plot_x)
## validate selected variables
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$joy_plot_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## multi scatterplot condition panel:show only if variable (x, y) validated and displayed on UI
output$joy_plot_status <- reactive({
req(final_joy_plot())
return(TRUE)
})
outputOptions(output, "joy_plot_status", suspendWhenHidden = FALSE)
## joy plot user selected gene group data
joy_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "joy_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_joy_plot),
current_session_data_matrix = plot_data)
## joy plot
ggjoy_plot <- eventReactive(input$generate_joy_plot, {
req(input$joy_plot_x, joy_plot_vars_validated() , joy_plot_user_selected_gene_group_data())
plot_data <- joy_plot_user_selected_gene_group_data() %>%
dplyr::select(c(input$joy_plot_x) , gene_groups) %>%
tidyr::gather(samples, value , -gene_groups) %>%
left_join(group_info$column_groups , by = c(samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::mutate(samples = forcats::fct_inorder(samples)) %>% ## preserve original order
dplyr::mutate(groups = forcats::fct_inorder(groups))# %>%
ggjoy_plot <- ggplot(plot_data) + aes(x = value)
return(ggjoy_plot)
})
## final joy plot
final_joy_plot <- reactive({
req(ggjoy_plot())
## fill and facet
ggjoy_plot <- ggjoy_plot()
out <- callModule(module = joyplot_fill_and_facet , id = "joy_plot_fill_and_facet" , joyplot = ggjoy_plot)
ggjoy_plot <- out$plot
withProgress(message = "Preparing joy plot",{
incProgress(0.5)
ggjoy_plot <- ggjoy_plot +
scale_x_continuous(expand = c(0.01, 0)) +
scale_y_discrete(expand = c(0.01, 0)) #+
#theme_bw()
## decorate joy plot
ggjoy_plot <- callModule(plot_title_and_axis_label_server ,
id = "decorate_joy_plot" ,
my_ggplot = ggjoy_plot ,
axis_x_title = ggjoy_plot$mapping$x %>% rlang::quo_text(),
axis_y_title = ggjoy_plot$mapping$y %>% rlang::quo_text(),
x_tick_angle = 0,
fill_legend_title = out$fill_var)
incProgress(1)
})
return(ggjoy_plot)
})
## render density plot
output$joy_plot <- renderPlot({
## dynamic alpha
req(final_joy_plot())
return(print(final_joy_plot()))
}, height = function() {
return(session$clientData$output_joy_plot_width)
}, width = function() {
return(session$clientData$output_joy_plot_width)
}, res = 90)
callModule(module = export_plot , id = "export_joy_plot" , file_name = "joy_plot" , plot = final_joy_plot)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# box plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update box plot variables
observeEvent(plot_data(), {
updatePickerInput(
session = session,
inputId = "box_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## validate boxplot selected variables
box_vars_validated <- eventReactive(input$generate_box, {
req(input$box_x)
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$box_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## boxplot condition panel : show only if selected variable(s) validated and displayed on UI
output$box_plot_status <- reactive({
req(final_box_plot())
return(TRUE)
})
outputOptions(output, "box_plot_status", suspendWhenHidden = FALSE)
## box plot user selected gene group data
box_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "box_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_box),
current_session_data_matrix = plot_data)
## box plot
boxplt <- eventReactive(input$generate_box, {
req(input$box_x , box_vars_validated() , box_plot_user_selected_gene_group_data())
box_plot_data <- box_plot_user_selected_gene_group_data() %>%
dplyr::select(c(input$box_x , "gene_groups")) %>%
tidyr::gather(key = samples , value = value , -gene_groups) %>%
dplyr::left_join(group_info$column_groups , by = c(samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::mutate(samples = forcats::fct_inorder(samples)) %>%
dplyr::mutate(groups = forcats::fct_inorder(groups))# %>%
## base plot
bp <- ggplot(box_plot_data)
return(bp)
})
final_box_plot <- reactive({
req(boxplt())
withProgress(message = "Preparing box plot" , {
incProgress(0.5)
boxplt <- boxplt()
## y axis and alpha
boxplt <- boxplt + geom_boxplot(alpha = input$box_plot_alpha) +
aes(y = value)
## fill and facet box plot
out <- callModule(module = ggplot_fill_and_facet ,
id = "box_plot_fill_and_facet" ,
ggplot = boxplt)
boxplt <- out$plot
# dynamic display pvalue
if (input$box_plot_pvalue == "TRUE") {
box_x_var_type <- boxplt$data %>%
dplyr::pull(!!boxplt$mapping$x) %>%
unique() %>% as.character()
if(length(box_x_var_type) >= 2){
all_combin <- combn(box_x_var_type, 2, simplify = F)
boxplt <- boxplt +
ggpubr::stat_compare_means(comparisons = all_combin,
method = input$box_plot_pval_method)
}
}
## box plot dots
if(input$box_plot_show_dots %>% as.logical()){
boxplt <- boxplt + geom_jitter(width = input$boxplot_dots_width , color = input$boxplot_dots_color , alpha = input$boxplot_dots_transprancy)
}
## decorate box plot
boxplt <- callModule(module = plot_title_and_axis_label_server ,
id = "box_plot_label_and_title",
my_ggplot = boxplt,
axis_x_title = boxplt$mapping$x %>% rlang::quo_text(),
axis_y_title = boxplt$mapping$y %>% rlang::quo_text(),
fill_legend_title = boxplt$mapping$fill %>% rlang::quo_text(),
x_tick_angle = 90,
)
incProgress(1)
})
return(boxplt)
})
## render boxplot
output$box_plot <- renderPlot({
req(final_box_plot())
return(print(final_box_plot()))
}, height = function() {
return(session$clientData$output_box_plot_width)
}, width = function() {
return(session$clientData$output_box_plot_width)
}, res = 96)
## export box plot
callModule(module = export_plot , id = "export_box_plot" , file_name = "box_plot" ,plot = final_box_plot)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# violin plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update violin plot variables
observeEvent(plot_data(), {
updatePickerInput(
session = session,
inputId = "violin_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## validate violin plot selected variables
violin_vars_validated <- eventReactive(input$generate_violin, {
req(input$violin_x)
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$violin_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## violin plot condition panel : show only if selected variable(s) validated and displayed on UI
output$violin_plot_status <- reactive({
req(final_violin_plot())
return(TRUE)
})
outputOptions(output, "violin_plot_status", suspendWhenHidden = FALSE)
## violin plot data
violin_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "violin_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_violin),
current_session_data_matrix = plot_data)
## violin plot
violinplt <- eventReactive(input$generate_violin, {
req(input$violin_x , violin_vars_validated() , violin_plot_user_selected_gene_group_data())
violin_plot_data <- violin_plot_user_selected_gene_group_data() %>%
dplyr::select(c(input$violin_x) , gene_groups) %>%
tidyr::gather(key = samples , value = value , -gene_groups) %>%
left_join(group_info$column_groups , by = c(samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::mutate(samples = forcats::fct_inorder(samples)) %>%
dplyr::mutate(groups = forcats::fct_inorder(groups))# %>%
## fill violin plot by variable, default
vp <- ggplot(violin_plot_data)
return(vp)
})
final_violin_plot <- reactive({
req(violinplt())
withProgress(message = "Preparing violin plot" , {
incProgress(0.5)
violin_plot_vars <- isolate(input$violin_x)
violinplt <- violinplt()
#violinplt <- violinplt + aes(x = samples, y = value , fill = samples )
## y axis and alpha
violinplt <- violinplt +
geom_violin(alpha = input$violin_plot_alpha , draw_quantiles = c(input$violin_show_quantile))+
aes(y = value)
# # dynamic fill and alpha
# violinplt <- violinplt +
# geom_violin(alpha = input$violin_plot_alpha , draw_quantiles = c(input$violin_show_quantile))
#
#
## fill and facet violin plot
out <- callModule(module = ggplot_fill_and_facet ,
id = "violin_plot_fill_and_facet" ,
ggplot = violinplt)
violinplt <- out$plot
# dynamic display pvalue
if (input$violin_plot_pvalue == "TRUE") {
violin_x_var_type <- violinplt$data %>%
dplyr::pull(!!violinplt$mapping$x) %>%
unique() %>% as.character()
if(length(violin_x_var_type) >= 2){
all_combin <- combn(violin_x_var_type, 2, simplify = F)
violinplt <- violinplt +
ggpubr::stat_compare_means(comparisons = all_combin, method = input$violin_plot_pval_method)
}
}
# decorate box plot
violinplt <- callModule(module = plot_title_and_axis_label_server ,
id = "violin_plot_label_and_title",
my_ggplot = violinplt,
axis_x_title = violinplt$mapping$x %>% rlang::quo_text(),
axis_y_title = violinplt$mapping$y %>% rlang::quo_text(),
x_tick_angle = 90,
fill_legend_title = violinplt$mapping$fill %>% rlang::quo_text()
)
incProgress(1)
})
return(violinplt)
})
## render violine
output$violin_plot <- renderPlot({
req(final_violin_plot())
return(print(final_violin_plot()))
}, height = function() {
return(session$clientData$output_violin_plot_width)
}, width = function() {
return(session$clientData$output_violin_plot_width)
}, res = 96)
## export box plot
callModule(module = export_plot , id = "export_violin_plot" , file_name = "violin_plot" ,plot = final_violin_plot)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# bar plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update bar plot variables
observeEvent(plot_data(), {
updatePickerInput(
session = session,
inputId = "barplot_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## update bar plot genes
observeEvent(plot_data(), {
updatePickerInput(
session = session,
inputId = "barplot_select_genes",
choices = plot_data() %>% dplyr::pull(1), ## first column is gene name
selected = plot_data() %>% dplyr::pull(1) %>% .[1]
)
})
## validate barplot selected variables
barplot_vars_validated <- eventReactive(input$generate_barplot, {
req(input$barplot_vars)
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$barplot_vars)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
} else {
return(TRUE)
}
})
## barplot condition panel : show only if selected variable(s) validated and displayed on UI
output$barplot_status <- reactive({
req(final_barplot())
return(TRUE)
})
outputOptions(output, "barplot_status", suspendWhenHidden = FALSE)
## barplot
barplot <- eventReactive(input$generate_barplot, {
req(input$barplot_vars , barplot_vars_validated(),input$barplot_select_genes)
barplot_data <- plot_data() %>%
dplyr::rename_at(1 , funs(return("GeneNames"))) %>%## set first column name as geneNames
dplyr::select(1, c(input$barplot_vars)) %>%
dplyr::filter(GeneNames %in% input$barplot_select_genes) %>%
tidyr::gather(key = samples , value = value , -GeneNames) %>%
left_join(group_info$column_groups , by = c(samples = "group_members")) %>%
tidyr::replace_na(list(groups = "No groups assigned")) %>% ## NA will be converted to "No groups assigned"
dplyr::mutate(samples = forcats::fct_inorder(samples)) %>% ## order by first appearance
dplyr::mutate(groups = forcats::fct_inorder(groups))# %>% ## order by first appearance
## if user groups uploaded chunk below make sure that order in each group is as per user uploaded samples
if(TRUE){ ## original (user supplied) sample order
barplot_data <- barplot_data %>%
dplyr::mutate(samples = forcats::fct_relevel(samples ,group_info$column_groups %>% pull(2) %>%
as.character() %>% unique() )) #%>% ## order by group members
}
if(TRUE){ ## original (user supplied) column group order
barplot_data <- barplot_data %>%
dplyr::mutate(groups = forcats::fct_relevel(groups ,group_info$column_groups %>% pull(1) %>%
as.character() %>% unique()))
}
## barplot base ggplot
barplot <- ggplot(barplot_data)
return(barplot)
})
final_barplot <- reactive({
req(barplot())
withProgress(message = "Preparing bar plot" , {
incProgress(0.5)
barplot <- barplot()
## current bar plot data
current_bar_plot_data <- barplot$data
## dynamic color aesthatic (color_by_var) is opposite to x axis aesthatic.
## can be one of the : samples or GeneNames. is the gene column is always named as GeneName ?
color_by_var <- ifelse(input$barplot_xaxis_choices == "samples" , "GeneNames" , "samples")
barplot <- barplot +
geom_col(aes(x = !!as.symbol(input$barplot_xaxis_choices),
y = value , col = !!(as.symbol(color_by_var)) ) , position = "dodge" ,
alpha = input$barplot_alpha) +
scale_color_manual(breaks = current_bar_plot_data[[color_by_var]] %>% unique(),
values = c(rep("black", current_bar_plot_data[[color_by_var]] %>%
unique() %>% length() ))) +
guides(color = FALSE, size = FALSE)
## fill by groups or variable.
if(input$fill_barplot != "identical"){
barplot <- barplot + aes(fill = !!as.name(input$fill_barplot))
}
## fill bar plot identical
if (input$fill_barplot == "identical") {
barplot <- barplot +
aes(fill = input$barplot_color_chooser) + ## fake aesthatic
scale_fill_manual(breaks = current_bar_plot_data[[color_by_var]] %>% unique(),
values = c(rep(input$barplot_color_chooser, current_bar_plot_data[[color_by_var]] %>%
unique() %>% length() )))
}
## facet bar plot
if(input$barplot_facet_value != "none") {
barplot <- barplot +
facet_wrap(~ eval(as.symbol(input$barplot_facet_value)) , scales = c(input$barplot_yscale ))
}
## decorate box plot
barplot <- callModule(module = plot_title_and_axis_label_server ,
id = "barplot_label_and_title",
my_ggplot = barplot,
axis_x_title = input$barplot_xaxis_choices,
axis_y_title = "Value",
x_tick_angle = 90,
fill_legend_title = input$fill_barplot
)
incProgress(1)
})
return(barplot)
})
## render barplot
output$barplot <- renderPlot({
req(final_barplot())
return(print(final_barplot()))
}, height = function() {
return(session$clientData$output_barplot_width)
}, width = function() {
return(session$clientData$output_barplot_width)
}, res = 96)
## export barplot
callModule(module = export_plot , id = "export_barplot" , file_name = "barplot" ,plot = final_barplot)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# line plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## update x variables
observe({
# update x
updatePickerInput(
session = session,
inputId = "lineplot_x",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## validate line plot parameters
line_plot_params_validated <- eventReactive(input$generate_lineplot, {
req(input$lineplot_x)
selected_non_num_vars <- plot_data() %>%
dplyr::select(c(input$lineplot_x)) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather() %>%
dplyr::filter(value == F)
## check if selected variables are of type numeric
if (nrow(selected_non_num_vars) >= 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = ifelse(length(selected_non_num_vars$key) == 1,
base::paste0(selected_non_num_vars$key, " is non numeric varibales"),
base::paste0(base::paste0(selected_non_num_vars$key, collapse = ","), " are non numeric varibales")
),
type = "error"
)
return(FALSE)
}
## atleast 2 variable req to generate line plot
if(length(input$lineplot_x) == 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Select atleast two columns to draw line plot"),
type = "error"
)
return(FALSE)
}
## value given for the `lineplot_top_n_genes` must be of type numeric
if(!is.numeric(input$lineplot_top_n_genes)) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("`# top variable genes to show` value must be of type numeric"),
type = "error"
)
return(FALSE)
}
## value given for the `line_plot_nclust` must be of type numeric
if(!is.numeric(input$line_plot_nclust)) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("`# of clusters (k-means)` value must be of type numeric"),
type = "error"
)
return(FALSE)
}
else {
return(TRUE)
}
})
## line plot condition panel : show only if selected variable(s) validated and displayed on UI
output$line_plot_status <- reactive({
req(line_plt())
return(TRUE)
})
outputOptions(output, "line_plot_status", suspendWhenHidden = FALSE)
## line plot user selected gene group data
line_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "line_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_lineplot),
current_session_data_matrix = plot_data)
## preapre line plot data.
line_plot_data <- eventReactive(eventExpr = input$generate_lineplot, {
req(line_plot_params_validated())
withProgress(message = 'Preparing line plot data', {
# Update progress
incProgress(0.5) ## display 50% task finished when it start
# Long Running Task
set.seed(1234)
## handle error if generated while performing clustering
clustered <- tryCatch({
clustered <- tibble_to_row_clusters(x = line_plot_user_selected_gene_group_data(),
row_ident = 1 ,
cols_to_use = input$lineplot_x,
use_z_score_for_clustering = ifelse(input$lineplot_cluster_value_type == 'zscore' ,
TRUE, FALSE) ,
num_of_top_var_rows = ifelse(input$lineplot_genes_selection == 'top_variable_genes',input$lineplot_top_n_genes , -1),
nclust = ifelse(input$line_plot_cluster_genes_by == "kmeans",
as.numeric(input$line_plot_nclust) , 1 ) ## if user selects cluster by gene groups, value of nclust = 1
)
## add count to cluster name
}, error = function(x){
shinyWidgets::sendSweetAlert(session = session ,
type = "error",
title = "Error" ,
text = tags$h5(tags$code(x)))
return(NULL)
})
# Update progress
incProgress(1)
}) ## with progress ends
## return NULL if oject clustered in NULL
if(is.null(clustered)){
return(NULL)
}
## select which value to display on plot, zscore or raw value.
if(input$lineplot_display_value_type == "zscore"){
forPlot <- clustered$zscore %>% left_join(clustered$clusters)
} else{
forPlot <- clustered$raw_value %>% left_join(clustered$clusters)
}
## if cluster by gene_groups assign user defined groups
if(input$line_plot_cluster_genes_by == "gene_groups"){
## tibble of two cols, where 1st column is gene names and 2nd is user supplied gene_groups
user_gene_groups <- line_plot_user_selected_gene_group_data() %>%
dplyr::select(1, dplyr::last_col())
## get column names to use them inside left_join
left_col <- colnames(forPlot)[1]
right_col <- colnames(user_gene_groups)[1]
## get the name of target column which is going to join as a result of left join.
## the name of resulted joined column will be used later to remove column from the df.
column_to_be_joined <- colnames(user_gene_groups)[2]
forPlot <- forPlot %>%
left_join(user_gene_groups , setNames(right_col, left_col)) %>%
dplyr::mutate(clust = !!as.symbol(column_to_be_joined)) %>%
dplyr::select(-!!as.symbol(column_to_be_joined))
}
## Add gene count in cluster name
forPlot <- forPlot %>%
dplyr::group_by(clust) %>%
dplyr::add_count() %>%
dplyr::ungroup() %>%
dplyr::mutate(clust = paste(clust, ":(N=" ,n , ")" , sep = "")) %>%
dplyr::select(-n)
## plot all lines vs avg line based on tick of activate_avg_line_plot
if (input$activate_avg_line_plot == "average") {
forPlot <- forPlot %>%
dplyr::group_by(clust) %>%
dplyr::summarise_if(is.numeric, input$avg_line_type)
}
forPlot <- forPlot %>%
tidyr::gather(key = "variable", value = "value" , input$lineplot_x) %>%
dplyr::mutate(variable = forcats::fct_inorder(variable)) %>% ## preserve original order of samples
dplyr::group_by(variable)
return(forPlot)
})
## plot
line_plt <- eventReactive(eventExpr = input$generate_lineplot, {
req(line_plot_data())
### plot
gp <- line_plot_data() %>%
dplyr::mutate(clust = forcats::fct_relevel(clust, as.numeric(clust) %>%
unique %>%
sort %>% as.character)) %>% ## numeric cluster to ordered factor
dplyr::mutate(row_num = 1:n()) %>%
ggplot2::ggplot(aes(x = variable,
y = value, group = row_num , alpha = 1))
return(gp)
})
## final line plot
final_line_plot <- reactive({
req(line_plt())
validate(need(is.numeric(input$line_plot_ncols) ,
message = "Number of columns must be numeric"))
## line plot geoms
line_plt <- line_plt() +
geom_point(size = input$lineplot_point_size) +
#geom_line(aes(col = clust) , size = input$lineplot_line_size) +
ggalt::geom_xspline(aes(col = clust),
spline_shape=input$line_plot_splin_shape,
size=input$lineplot_line_size)+
theme(legend.position = "none", axis.text.x = element_text(angle = 90, vjust = 0.4))
## line plot color identical
if(input$line_plot_color_by == 'identical'){
## get number of clusters
n_clust <- line_plt$data %>%
dplyr::pull(clust) %>% ## pull cluster var column
base::unique() %>%
as.character() %>% length()
## generate colors for each cluster
colrs <- c(rep(input$line_plot_color_chooser, n_clust))
## color and fill manual
line_plt <- line_plt +
scale_fill_manual(values = colrs) +
scale_color_manual(values = colrs)
}
## line plot manual alpha
line_plt <- line_plt +
scale_alpha(range = input$line_plot_line_transparancy) + ## override alpha in the plot
guides(alpha = FALSE ,
color = guide_legend(override.aes = list(alpha = input$line_plot_line_transparancy))) ## override alpha in the legend
## lie plot facet
if(input$line_plot_separate_by == 'gene_groups'){
line_plt <- line_plt + facet_wrap(~clust, ncol = input$line_plot_ncols ,
scales = input$line_plot_facet_scale_free)
}
## decorate line plot
line_plot <- callModule(module = plot_title_and_axis_label_server ,
id = "decorate_line_plot" ,
my_ggplot = line_plt ,
axis_x_title = "Samples",
axis_y_title = "Value",
color_legend_title = "Cluster",
x_tick_angle = 90
)
# ## fill color identical
# line_plot <- callModule(module = ggplot_fill_colour , "line_plot_color_identical" ,
# gp = line_plot , times = input$line_plot_nclust)
return(line_plot)
})
## render line plot
output$line_plot <- renderPlot({
req(final_line_plot())
return(print(final_line_plot()))
#return(
# withProgress(message = "Display line plot in progress", {
# incProgress(0.5)
#print(final_line_plot())
#incProgress(1)
#})
#)
}, height = function() {
return(session$clientData$output_line_plot_width)
}, width = function() {
return(session$clientData$output_line_plot_width)
}, res = 96)
## lineplot data to display
line_plot_data_disply <- eventReactive(input$generate_lineplot , {
req(line_plot_data())
display_data <- line_plot_data() %>%
tidyr::spread(key = "variable" , value = "value")%>%
dplyr::select(1,input$lineplot_x,dplyr::everything())
})
## genome annotation for line plot
## global genome annotations object cannot be used in following scenario
## For example : user has generated one lineplot Now accidently or purposely user selected / uploaded data
## for different species than the previous lineplot generated. In this scenario, global reference genome will
## be updated , and therefore, annotations in the existing lineplot will also be affected.
## To prepvent this seprate heatmap ref genome from global annot. lineplot ref annot will be updated only when
## plot lineplot submit button hit
lineplot_reference_annot <- eventReactive(input$generate_lineplot , {
req(genome_for_annotations())
return(genome_for_annotations())
})
## line plot output table
output$line_plot_clustred_data <- DT::renderDataTable({
## map gene features if average line not asked
if(isolate(input$activate_avg_line_plot != "average")){
user_selected_species_annot <- ah_data_summary2 %>%
dplyr::filter(genome == lineplot_reference_annot())%>%
dplyr::select(gr_cols) %>%
tidyr::unnest(cols = gr_cols)
join_col_x <- base::colnames(line_plot_data_disply())[1] ## first column containing geneNames
join_col_y <- base::colnames(user_selected_species_annot)[7] ## "id" column
line_plot_data_to_show <- line_plot_data_disply()%>%
left_join(user_selected_species_annot, by = setNames(join_col_y, join_col_x)) %>%
dplyr::select(1,c("seqnames", "start", "end", "strand", "description"), colnames(line_plot_data_disply())) %>%
dplyr::mutate_if(is.numeric, round, 4)%>%
dplyr::mutate_all(funs(replace_na(as.character(.),"--NA--")))
}else{
line_plot_data_to_show <- line_plot_data_disply()
}
return(line_plot_data_to_show %>% dplyr::arrange(clust) %>%
dplyr::mutate_if(is.numeric , round , 3))
},
selection = "none",
server = F,
extensions = "Buttons",
options = list(
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy", list(
extend =
"collection", buttons =
c("csv", "excel", "pdf"), text = "Download"
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500, -1) # declare values
, c(10, 50, 100, 500, "All") # declare titles
),
pageLength = 10
) ## end of options
)
## export line plot
callModule(module = export_plot ,id = "export_line_plot" ,file_name = "line_plot" , plot = final_line_plot)
## line plot functional analysis
callModule(module = functional_analysis_server , id = "lineplot_functional_analysis_ui" ,
ui_id = "lineplot_functional_analysis_ui",
session = session,
gene_set = reactive(split(x = line_plot_data_disply()[[1]], ## genename
f = line_plot_data_disply()$clust)) ,
genome = reactive({lineplot_reference_annot()}))
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# PCA plot server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## check whether x and y are numeric type
pca_plot_vars_validated <- eventReactive(input$generate_pca_plot, {
req(input$pca_plot_vars)
withProgress(message = "validate data" , {
incProgress(0.3)
selected_vars <- plot_data() %>% dplyr::select(input$pca_plot_vars)
col_class <- plot_data() %>% dplyr::select(input$pca_plot_vars) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather()
incProgress(0.5)
if (!all(col_class$value)) {
non_numeric_cols <- col_class %>% dplyr::filter(!value)
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0(paste0(non_numeric_cols$key, collapse = " "), " must be of type numeric", collapse = ""),
type = "error"
)
return(FALSE)
}
incProgress(0.7)
if(length(input$pca_plot_vars) == 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Select atleast two columns to perfrom PCA."),
type = "error"
)
return(FALSE)
}
else {
return(TRUE)
}
incProgress(1)
})
})
## update x variables
observe({
req(plot_data())
# update x
updatePickerInput(
session = session,
inputId = "pca_plot_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## pca plot user selected gene group data
pca_plot_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "pca_plot_gene_group_selection" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_pca_plot),
current_session_data_matrix = plot_data)
## prepare PCA input matrix , where columns are gene names and rows are sample names
pca_input_matrix <- eventReactive(eventExpr = input$generate_pca_plot,{
req(pca_plot_vars_validated() , pca_plot_user_selected_gene_group_data())
withProgress(message = "Prepare PCA data",{
incProgress(0.3)
plot_data_t <- pca_plot_user_selected_gene_group_data() %>%
dplyr::select(1, input$pca_plot_vars) %>%
dplyr::select_if(function(.) {
!all(. == 0)
}) %>% ## remove if all values are 0 in the sample
tidyr::gather(key = sname, value, -1) %>%
tidyr::spread(1, value) ## transpose data --> genes will be column and samples will be row
## conver dt to matrix for prcomp input
pca_input_data <- plot_data_t %>%
as.data.frame() %>%
column_to_rownames("sname")
})
return(pca_input_data)
})
## prform PCA
pca_plot_pr_comp <- eventReactive(eventExpr = input$generate_pca_plot,{
req(pca_input_matrix())
withProgress(message = "Perform PCA" , {
# perform pca
pr <- tryCatch({
prcomp(pca_input_matrix()) ## remove last column having sample groups
} , error = function(x){
sendSweetAlert(session = session ,title = "Error while performing PCA" ,
text = tags$h4("Error message from function :" ,
tags$code("prcomp()"),br(),br(), tags$code(x)) ,
type = "error")
return(NULL)
})
})
return(pr)
})
### perform pca sample k-means
pca_data_sample_kmeans <- reactive({
req(pca_input_matrix())
validate(
need(is.numeric(input$pca_sample_sample_kmeans_n) &&
(input$pca_sample_sample_kmeans_n > 0 ) , message = "Number of cluster must be numeric")
)
## perform kmenas
km_data <- tryCatch({
set.seed(12345)
km <- kmeans(pca_input_matrix() , centers = input$pca_sample_sample_kmeans_n )
tt <- tibble::tibble(sname = rownames(pca_input_matrix()) , kmeans_clust = km$cluster )
}, error = function(x){
sendSweetAlert(session = session ,title = "PCA sample K-means error!!!" ,
text = tags$h4("Putting all samples in one group.",br(),
"Error message from function :" ,
tags$code("kmeans()"),br(),br(), tags$code(x)) ,
type = "error")
tt <- tibble::tibble(sname = rownames(pca_input_matrix()) , kmeans_clust = "All samples")
return(tt)
})
return(km_data)
})
## Attach % variance with each PC
my_pr_comp_names <- reactive({
req(pca_plot_pr_comp())
## get proportion of variance for each PC
pc_prop_of_var <- summary(pca_plot_pr_comp())$importance %>%
#summary(pr)$importance %>%
as.data.frame() %>%
rownames_to_column(var = "feature_type") %>%
tidyr::gather(pc , value , -feature_type) %>%
dplyr::filter(feature_type == "Proportion of Variance") %>%
dplyr::select(-feature_type) %>%
dplyr::mutate(value = round(value * 100 ,1)) %>% ## convert to percentage
dplyr::mutate(with_var = paste(pc ," (" , value ,"%",")" , sep = "")) %>%
dplyr::select(-value)
## return named vector
pc_prop_of_var %>% dplyr::pull(with_var) %>% rlang::set_names( pc_prop_of_var$pc)
})
## Get PCs from prcomp obtained object. pr_comp_derieved_tibble is a tibble where columns are PCs and rows are samples.
pr_comp_derieved_tibble <- reactive({
req(pca_plot_pr_comp())
## get pr_comp tibble, and map sample and group info
pr_comp_tbl <- pca_plot_pr_comp()$x %>%
as.data.frame() %>%
dplyr::rename_all(~(my_pr_comp_names())) %>%
tibble::rownames_to_column("sname") %>%
as_tibble() ## rename column names. new column names are with 'prop of var' attached.
## create column sname (sample names ) from row names
## prevent rendering from global sample group update
isolate({
pr_comp_tbl_grps <- pr_comp_tbl %>%
left_join(group_info$column_groups , by = c (sname = "group_members")) %>% ## add column groups denoting sample groups
tidyr::replace_na(list(groups = "No groups assigned")) ## in the column groups replace NA to "No groups assigned"
})
## add sample kmeans data
pr_comp_tbl_grps <- pr_comp_tbl_grps %>%
left_join(pca_data_sample_kmeans() , by = "sname") %>%
tidyr::replace_na(list(kmeans_clust = "No groups assigned")) ## in the column groups
return(pr_comp_tbl_grps)
})
## PCA plot update show / hide sample groups. It allows user to exclude sample groups directly from PCA plot
observe({
req(pr_comp_derieved_tibble())
if(input$pca_plot_colour == "groups"){
shinyWidgets::updateMultiInput(inputId = "pca_plot_hide_sample_groups" , session = session,
choices = pr_comp_derieved_tibble() %>% pull("groups") %>% unique()
)
}
if(input$pca_plot_colour == "kmeans"){
shinyWidgets::updateMultiInput(inputId = "pca_plot_hide_sample_groups" , session = session,
choices = pr_comp_derieved_tibble() %>% pull("kmeans_clust") %>% unique()
)
}
})
### Remove user excluded groups before final PCA plot
pca_data_after_groups_excluded_by_user <- reactive({
#req(input$pca_plot_hide_sample_groups)
user_excluded_groups <- input$pca_plot_hide_sample_groups
plot_data <- pr_comp_derieved_tibble() %>%
dplyr::filter(! xor((groups %in% user_excluded_groups),(kmeans_clust %in% user_excluded_groups)))
## make sure pca_data_after_groups_excluded_by_user() > 1 row.
### This is necessary to check when user exclude all the groups
validate(
need(plot_data %>% nrow() > 1 , "Atleast one sample group must be selected" )
)
return(plot_data)
})
## update PC choices
observe({
req(my_pr_comp_names())
available_pc <- my_pr_comp_names()
default_pc <- available_pc[1:2] ## default PCs
updateSelectizeInput(session = session ,
inputId = "select_pcs_to_plot" ,
choices = available_pc %>% unname(),
selected = default_pc ,server = TRUE)
})
## get names of PC columns
pcs_to_plot <- reactive({
validate(
need(input$select_pcs_to_plot %>% length() == 2 , "Select 2 Pcs.")
)
return(input$select_pcs_to_plot)
})
## pca plot
pca_gp <- reactive({
req(all(pcs_to_plot() %in% my_pr_comp_names()))
withProgress(message = "Preparing PCA plot",{
incProgress(0.5)
## add group information
plot_data <- pca_data_after_groups_excluded_by_user()
#print("PCA plot data")
#print(plot_data %>% dplyr::select(sname, groups))
## PCs to plot
pc_x = pcs_to_plot()[1]## PC1
pc_y = pcs_to_plot()[2] ## PC2
## plot , default PC1 and PC2
pca_gp <- ggplot(data = plot_data ,
aes_string(x = as.symbol(pc_x), y = as.symbol(pc_y) )) +
geom_point(size = input$pca_sample_dot_size) #+ theme_bw()
## whether sample names should be shown or not
if(input$pca_display_sample_names) {
pca_gp <- pca_gp +
ggrepel::geom_text_repel(aes(label = sname),
size = input$pca_plot_sample_names_size)
}
### color groups
if(input$pca_plot_colour == "groups") {
pca_gp <- pca_gp + aes(color = groups) +
scale_color_manual(values = get_gg_colors(pr_comp_derieved_tibble() %>%
pull(groups) %>%
as_factor() %>% levels()) )
}
## color by sample kmeans
if(input$pca_plot_colour == "kmeans") {
pca_gp <- pca_gp + aes(color = factor(kmeans_clust)) +
scale_color_manual(values = get_gg_colors(pr_comp_derieved_tibble() %>%
dplyr::pull(kmeans_clust) %>%
forcats::as_factor() %>% levels()))
}
## color identical , NOTE: using breaks = NULL explicitly will be helpful to getrid of legends
if(input$pca_plot_colour == "identical") {
pca_gp <- pca_gp + aes(col = "") +
scale_color_manual( breaks = NULL , values = input$pca_sample_name_color)
}
incProgress(1)
})
return(pca_gp)
})
## final pca plot
final_pca_plot <- reactive({
req(pca_gp())
withProgress(message = "Decorate PCA plot",{
incProgress(0.5)
pca_gp <- callModule(module = plot_title_and_axis_label_server ,
id = "decorate_pca_plot" ,
my_ggplot = pca_gp() ,
axis_x_title = pca_gp()$labels$x,
axis_y_title = pca_gp()$labels$y ,
x_tick_angle = 0,
color_legend_title = input$pca_plot_colour)
pca_gp <- pca_gp +
scale_x_continuous(expand = expand_scale(mult = 0.2)) + # expand x scale
scale_y_continuous(expand = expand_scale(mult = 0.2)) # expand y scale
incProgress(1)
return(pca_gp)
})
})
## render pca
output$pca_plot <- renderPlot({
req(final_pca_plot())
final_pca_plot()
#return(print(final_pca_plot()))
},
height = function() {
req(final_pca_plot())
return(session$clientData$output_pca_plot_width)
}, ## dynamic height
width = function() {
req(final_pca_plot())
return(session$clientData$output_pca_plot_width)
}, res = 96
) ## dynamic width
## export pca plot
callModule(module = export_plot , id = "export_pca_plot" , file_name = "pca_plot" , plot = final_pca_plot)
## current pca plot SRA sample info, update only when generate pca plot submit button hit
current_pca_plot_sra_sample_info <- eventReactive(eventExpr = input$generate_pca_plot,{
return(user_selected_sra_id_sample_info())
})
### pla plot brush data
pca_brushed_data <- eventReactive(input$pca_plot_brush , {
pc_x = pcs_to_plot()[1] ## PC1
pc_y = pcs_to_plot()[2] ## PC2
## subset brushed points data
bp <- brushedPoints(df = pca_data_after_groups_excluded_by_user() ,
brush = input$pca_plot_brush ,
xvar = pc_x,
yvar = pc_y)
## map required sample info
display_pca_data <- current_pca_plot_sra_sample_info() %>%
dplyr::filter(run_accession %in% bp$sname) %>%
dplyr::select(-c("reference_annot" , "taxon_id","scientific_name" , "instrument_model" , "updated_date"))
return(display_pca_data)
})
## render PCA brushed data
output$pca_brushed_datatable <- DT::renderDataTable({
req(pca_brushed_data())
return(pca_brushed_data() %>%
dplyr::mutate_all(funs(replace_na(as.character(.),"--NA--"))) %>%
dplyr::mutate_if(is.numeric , round , 2))
},selection = "none",
server = F,
extensions = c("Buttons"),
options = list(
deferRender = TRUE,
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
columnDefs = list(
list(targets = c(6:15), visible = FALSE) # The column number must be identical to the columns in colvis extension
),
buttons =
list("copy",
list(extend = "collection",
buttons = c("csv", "excel", "pdf"), text = "Download"
),
list(extend = "colvis",
columns = c(6:15)
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500, -1) # declare values
, c(10, 50, 100, 500, "All") # declare titles
),
pageLength = 10
)
)
## pca plot brushed data table status , decide whether should be displayed or not
output$pac_plot_brushed_data_table_status <- reactive({
req(pca_brushed_data())
return(TRUE)
})
outputOptions(output,name = "pac_plot_brushed_data_table_status" , suspendWhenHidden = FALSE)
## pca plot condition panel:show only if variable (x, y) validated and displayed on UI
output$pca_plot_status <- reactive({
req(pca_plot_pr_comp())
return(TRUE)
})
outputOptions(output, "pca_plot_status", suspendWhenHidden = FALSE)
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# heatmap server----
## @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## check whether x and y are numeric type
heatmap_parmas_validated <- eventReactive(input$generate_heatmap, {
req(input$heatmap_vars)
selected_vars <- plot_data() %>% dplyr::select(input$heatmap_vars)
col_class <- plot_data() %>% dplyr::select(input$heatmap_vars) %>%
dplyr::summarise_all(is.numeric) %>%
tidyr::gather()
withProgress(message = "Validating inputs", {
incProgress(1/10)
if (!all(col_class$value)) {
non_numeric_cols <- col_class %>% dplyr::filter(!value)
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0(paste0(non_numeric_cols$key, collapse = " "), " must be of type numeric", collapse = ""),
type = "error"
)
return(FALSE)
}
incProgress(2/10)
## atleast two vars req to generate hm
if(length(input$heatmap_vars) == 1) {
shinyWidgets::sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Select atleast two columns to draw heatmap"),
type = "error"
)
return(FALSE)
}
incProgress(3/10)
# check if number of genes given are of type numeric
if ((!is.numeric(input$heatmap_top_n_genes)) & (input$hm_genes_selection == "top_variable_genes")) {
sendSweetAlert(
session = session,
title = "Error...",
text = "'# top variable genes to show' must be numeric",
type = "error"
)
return(NULL)
}
incProgress(4/10)
## check if user given color scale min is valid
if (!is.numeric(input$heatmap_scale_min)) {
sendSweetAlert(
session = session,
title = "Error...",
text = "Heatmap color scale (minimum) must be numeric value",
type = "error"
)
return(NULL)
}
incProgress(5/10)
## check if user given color scale max valid or not
if (!is.numeric(input$heatmap_scale_max)) {
sendSweetAlert(
session = session,
title = "Error...",
text = "Heatmap color scale (maximum) must be numeric value",
type = "error"
)
return(NULL)
}
incProgress(6/10)
## check if number of cluster given are of type numeric.
if (!is.numeric(input$heatmap_row_nclust) || !is.numeric(input$heatmap_coulm_nclust)) {
sendSweetAlert(
session = session,
title = "Error...",
text = "'# of clusters (column / row k-means)' must be of type numeric",
type = "error"
)
return(NULL)
}
incProgress(7/10)
## check if number of cluster given are > 0 and <= total rows in the data or
if (input$heatmap_row_nclust == 0 ||
input$heatmap_coulm_nclust == 0 ||
input$heatmap_row_nclust >= nrow(plot_data()) ||
input$heatmap_row_nclust >= input$heatmap_top_n_genes ||
input$heatmap_coulm_nclust >= ncol(plot_data()) ||
input$heatmap_coulm_nclust >= length(input$heatmap_vars)
) {
sendSweetAlert(
session = session,
title = "Error...",
text = "'# of clusters (column / row k-means)' must be > 0 and < total rows (row clusters) or total columns (column clusters)",
type = "error"
)
return(NULL)
}
else {
return(TRUE)
}
incProgress(10/10)
})
})
## heatmap conditional panel
output$heatmap_status <- reactive({
req(heatmap_to_display())
return(TRUE)
})
outputOptions(output, "heatmap_status", suspendWhenHidden = FALSE)
## update x variables
observe({
req(plot_data())
## update x
updatePickerInput(
session = session,
inputId = "heatmap_vars",
choices = base::colnames(plot_data())[-1],
selected = base::colnames(plot_data())[2]
)
})
## heatmap user selected gene group data
heatmap_user_selected_gene_group_data <- callModule(module = gene_group_selection ,
id = "heatmap_select_gene_groups" ,
gene_group_info = reactive(group_info$row_groups),
generate_plot_action = reactive(input$generate_heatmap),
current_session_data_matrix = plot_data)
## prepare heatmap data.
heatmap_top_variable_genes_df <- eventReactive(eventExpr = input$generate_heatmap, {
req(heatmap_parmas_validated(), heatmap_user_selected_gene_group_data())
withProgress(message = "Preparing heatmap data " , {
incProgress(0.1)
# fix number of genes to plot, default all genes (if any gene group selected, all the genes from selected gene group will be plotted)
num_of_genes_for_hm <- nrow(heatmap_user_selected_gene_group_data())
if (input$hm_genes_selection == "top_variable_genes") {
## if user given number of genes argument < total genes, all genes will be used in the plot.
if (nrow(heatmap_user_selected_gene_group_data()) < input$heatmap_top_n_genes) {
num_of_genes_for_hm <- nrow(heatmap_user_selected_gene_group_data())
} else {
num_of_genes_for_hm <- input$heatmap_top_n_genes
}
}
# max genes cannot be higher than 20k
max_hm_genes <- 20000
if (num_of_genes_for_hm > max_hm_genes) {
sendSweetAlert(
session = session,
title = "Error...",
text = paste("Number of genes cannot be higher than ", max_hm_genes, ".", sep = ""),
type = "error"
)
return(NULL)
}
incProgress(0.3 , message = "row wise clustering")
## get clusters and zscore data
clustered <- tryCatch({
tibble_to_row_clusters(x = heatmap_user_selected_gene_group_data(),
row_ident = 1 ,
cols_to_use = input$heatmap_vars,
use_z_score_for_clustering = ifelse(input$heatmap_cluster_value_type == 'zscore' , TRUE, FALSE),
#use_z_score_for_clustering = input$hm_use_zscore ,
num_of_top_var_rows = ifelse(input$hm_genes_selection == 'top_variable_genes',
num_of_genes_for_hm , -1),
nclust = as.numeric(input$heatmap_row_nclust)
)
} , error = function(x){
return(x)
})
## if error generated while clustering
if(inherits(clustered , "error")){
sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Row k-means error : ", clustered, collapse = " "),
type = "error"
)
return(NULL)
}
## select which value to display on plot, zscore or raw value.
if(input$heatmap_display_value_type == "zscore"){
heatmap_data <- clustered$zscore
#print(heatmap_data)
} else{
heatmap_data <- clustered$raw_value
#print(heatmap_data)
}
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## arrange heatmap input data in original order is important when user wants to have same order of genes in the heatmap which was uploaded.
## Following things must be kept in mind when arranging heatmap data matrix in the original order
## 1) output of the tibble_to_row_clusters function throws list containing raw_data_matrix, zscore_matrix and row_clusters
## if order of the rows in heatmap data matrix (zscore or raw data) change, order in the row clusters must change.
##@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
gene_name_col_names <- plot_data_original_row_order() %>% colnames() %>% .[1]
row_order_col_name <- plot_data_original_row_order() %>% colnames() %>% .[2]
heatmap_data <- heatmap_data %>%
left_join(plot_data_original_row_order() , by = setNames(gene_name_col_names , colnames(heatmap_data)[1])) %>%
dplyr::arrange(.data[[row_order_col_name]]) %>% ## arrange by original gene order
dplyr::select(-.data[[row_order_col_name]]) ## remove column
## as mentioned above change order in row clusters
row_splt <- clustered$clusters %>%
left_join(plot_data_original_row_order() , by = setNames(gene_name_col_names , colnames(clustered$clusters)[1])) %>%
dplyr::arrange(.data[[row_order_col_name]]) %>%
dplyr::select(-.data[[row_order_col_name]])
### which clusters to use ? kmeans or user defined
if(input$heatmap_row_clusters_choices == "kmeans") {
row_splt <- row_splt%>%
pull(2)
} else if(input$heatmap_row_clusters_choices == "gene_groups"){
## get user given row groups
row_splt = heatmap_data %>%
as_tibble() %>%
dplyr::left_join(group_info$row_groups ,
by = setNames(colnames(group_info$row_groups)[2] ,
colnames(heatmap_data)[1])) %>%
pull(colnames(group_info$row_groups)[1])
## set levels in the orginal order of user supplied groups
row_splt <- row_splt %>%
as.factor() %>%
fct_relevel(., group_info$row_groups %>%
pull(1) %>% unique())
}
## number of genes in each cluster
gene_count <- table(row_splt)
## Fix row cluster names
row_splt <- row_splt %>%
tibble(x = . ) %>%
dplyr::add_count(x) %>%
dplyr::mutate(cluster_name = paste(input$hm_cluster_prefix , x ,":(N=", n,")" , sep = "")) %>%
pull(cluster_name)
## convert tibble to data frame
heatmap_data <- heatmap_data %>%
as.data.frame()
##generate matrix with rownames as gene name
rownames(heatmap_data) <- heatmap_data[[1]]
heatmap_data <- heatmap_data[-1]
incProgress(0.7 , message = "column wise clustering")
## column clusters, which clusters to use ? kmeans or user defined
if(input$heatmap_column_clusters_choices == "kmeans"){ #
column_splt <- tryCatch({
set.seed(1234)
column_km_out <- kmeans(t(heatmap_data) ,centers = input$heatmap_coulm_nclust)
column_km_out$cluster
} , error = function(x){
return(x)
})
} else if(input$heatmap_column_clusters_choices == "sample_groups"){ # use sample groups as column cluster
## heatmap column names to user supplied grp names tibble
column_splt_ss = heatmap_data %>%
colnames() %>%
tibble(sname = .) %>%
left_join(group_info$column_groups , by = c (sname = "group_members")) #%>%
## arrange by user supplied column order
column_splt_ss <- column_splt_ss %>%
dplyr::mutate(sname = forcats::fct_relevel(as.character(sname) , group_info$column_groups %>% pull(2) %>% unique() ))
## get named vector of heatmap column names, where vector elems are group names and names are column names.
column_splt <- column_splt_ss %>%
pull(colnames(group_info$column_groups)[1]) %>% ## pull user supplied group columns
rlang::set_names( . ,column_splt_ss$sname)
## rearrange heatmap data as split order changed
heatmap_data <- heatmap_data %>% dplyr:: select(names(column_splt))
}
## Fix column cluster name
column_splt <- column_splt %>%
tibble(x = .) %>%
dplyr::add_count(x) %>%
dplyr::mutate(cluster_name = paste(input$hm_column_cluster_prefix , x ,"\n(N=", n,")" , sep = "")) %>%
pull(cluster_name) %>%
set_names(names(column_splt)) ## set orig names if it has
## handle column split error
if(inherits(column_splt , "error")){
sendSweetAlert(
session = session,
title = "Error...",
text = paste0("Column k-means error : ", column_splt, collapse = " "),
type = "error"
)
return(NULL)
}
incProgress(0.9 , message = "final data")
## set heatmap data to a list
rr= NULL
rr$mat <- heatmap_data
rr$clust <- row_splt
rr$column_clusters <- column_splt
rr$row_sd <- rr$mat %>%
rownames %>%
tibble(geneName = . ) %>%
left_join(clustered$std_dev , by =c("geneName" = colnames(clustered$std_dev)[1])) %>%
as.data.frame() %>%
column_to_rownames("geneName") %>% as.matrix()
incProgress(0.1)
return(rr)
})
})
## update heatmap legend range
observe({
#req(heatmap_top_variable_genes_df())
if(input$heatmap_display_value_type == "zscore"){
updateNumericInput(session = session ,
inputId = "heatmap_scale_min",
value = -1.5)
updateNumericInput(session = session ,
inputId = "heatmap_scale_max",
value = 1.5)
}
if(input$heatmap_display_value_type != "zscore"){
updateNumericInput(session = session ,
inputId = "heatmap_scale_min",
value = 0)
updateNumericInput(session = session ,
inputId = "heatmap_scale_max",
value = 10)
}
})
## generate heatmap
heatmap <- eventReactive(input$generate_heatmap, {
req(heatmap_top_variable_genes_df())
withProgress(message = "Preparing heatmap",{
incProgress(0.5)
# generate heatmap
hm_row_threshold <- 2000 ##if number of genes higher than this, gene names will be disabled.
# ## hm colors
hm_colors <- tryCatch({
circlize::colorRamp2(
breaks = seq(from = input$heatmap_scale_min,
to = input$heatmap_scale_max , length.out = 3),
colors = c(input$heatmap_col_low, input$heatmap_col_medium, input$heatmap_col_high)
)
}, error = function(e){
## send warning if color function give error
sendSweetAlert(session = session , title = "Warning" ,
type = "warning" ,
text = tags$h4("Error while generating user defined colors",
br(),
"Error from" , tags$code("circlize::colorRamp2()"),
br(),
tags$code(e),br(),
"Default scale (-2 to 2) will be used."
))
## default color : get minimum and maximum from
circlize::colorRamp2(
breaks = seq(from = -2,
to = 2 , length.out = 3),
colors = c(input$heatmap_col_low, input$heatmap_col_medium, input$heatmap_col_high)
)
})
## prepare column annotations
column_ha = NULL ## default column annotations
## boxplot and column name annotations
if(!is.null(input$heatmap_anno_type)){ ## make sure atleast one annot selected
## convert NA to "No groups assigned"
no_grp_label <- "NA"
## get groups for hm cols
hm_selected_column_groups <- heatmap_top_variable_genes_df()$mat %>%
colnames() %>%
tibble(hm_cols = . ) %>%
left_join(group_info$column_groups , by = c(hm_cols = "group_members")) %>%
pull(groups) %>%
replace_na(no_grp_label)
### column grp annot
grp_colors <- get_gg_colors(x = hm_selected_column_groups %>% as_factor() %>% levels())
## column box annot
column_box_anno <- ComplexHeatmap::anno_boxplot(heatmap_top_variable_genes_df()$mat ,
axis = T ,
border = T ,
axis_param = list(gp = grid::gpar(fontsize = 8),
side = "left",
facing = "outside"
),
height = unit(input$heatmap_top_annot_height,"cm")
)
## display both grp and box annot
if(all(c("show_heatmap_column_groups" , "show_heatmap_column_boxplot") %in% input$heatmap_anno_type)){ ## all annotations
column_ha = ComplexHeatmap::HeatmapAnnotation(Groups = hm_selected_column_groups ,
Box = column_box_anno,
col = list(Groups = grp_colors)
)
## only grp annot
}else if(input$heatmap_anno_type == "show_heatmap_column_groups") {## sample group annotations
column_ha = ComplexHeatmap::HeatmapAnnotation(Groups = hm_selected_column_groups , col = list(Groups = grp_colors))
## only box annot
}else if(input$heatmap_anno_type == "show_heatmap_column_boxplot"){ ## box plot annotations
column_ha = ComplexHeatmap::HeatmapAnnotation(box = column_box_anno)
}
}
## final hm
hm <- ComplexHeatmap::Heatmap(heatmap_top_variable_genes_df()$mat,
#row_title = "cluster_%s",
cluster_column_slices = F,#input$hm_cluster_column_slice %>% as.logical() , ## it make sure that column clusters arrange in order
column_split = heatmap_top_variable_genes_df()$column_clusters %>%
factor(., levels = gtools::mixedsort(unique(.))),
show_column_names = input$show_hm_colum_names %>% as.logical(),
show_column_dend = input$show_hm_column_dend %>% as.logical(),
cluster_columns = input$hm_cluster_columns %>% as.logical(),
column_names_gp = grid::gpar(fontsize = input$hm_column_names_font_size),
top_annotation = column_ha,
column_title_rot = 90,
column_title_gp = grid::gpar(fontsize = 10),
# if SD heatmap AND sort by SD both on together, turn off row clustering.
cluster_rows = ifelse(input$sort_hm_by_std_dev %>% as.logical() &&
input$show_std_dev_hm %>% as.logical() , FALSE , as.logical(input$hm_cluster_rows)),
# if number of genes higher than hm_row_threshold disable genenames
show_row_names = ifelse(nrow(heatmap_top_variable_genes_df()$mat) <= hm_row_threshold, as.logical(input$show_hm_row_names), FALSE),
show_row_dend = input$show_hm_row_dend %>% as.logical() ,
#row_split = paste0("Clust_",heatmap_top_variable_genes_df()$clust),
row_split = heatmap_top_variable_genes_df()$clust %>% factor(., levels = gtools::mixedsort(unique(.))) ,
row_names_gp = grid::gpar(fontsize = input$hm_row_names_font_size),
row_order = if(all(input$sort_hm_by_std_dev %>% as.logical() , input$show_std_dev_hm %>% as.logical())) order(heatmap_top_variable_genes_df()$row_sd[,1]) else NULL,
cluster_row_slices = F, #input$hm_cluster_row_slice,
row_title_rot = 0,
row_title_gp = grid::gpar(fontsize = 10),
name = ifelse(input$heatmap_display_value_type == "zscore" , "zscore", input$heatmap_legend_name),
heatmap_legend_param = list(legend_direction = input$heatmap_legened_direction),
col = hm_colors,
border = input$hm_border %>% as.logical()
#width = unit(5 , "in"),
#height = unit(5 , "in")
)
incProgress(1)
})
return(hm)
})
## standard deviation heatmap
sd_heatmap <- eventReactive(input$generate_heatmap, {
req(heatmap_top_variable_genes_df())
hm_row_threshold = 2000
sd_hm <- ComplexHeatmap::Heatmap(heatmap_top_variable_genes_df()$row_sd,
row_split = heatmap_top_variable_genes_df()$clust,
show_row_names = ifelse(nrow(heatmap_top_variable_genes_df()$mat) <= hm_row_threshold, as.logical(input$show_hm_row_names), FALSE),
row_names_gp = grid::gpar(fontsize = input$hm_row_names_font_size),
heatmap_legend_param = list(legend_direction = input$heatmap_legened_direction),
name = "std_dev")
return(sd_hm)
})
## final heatmap : data heatmap or combined with SD heatmap
heatmap_to_display <- eventReactive(input$generate_heatmap , {
req(heatmap())
if(input$show_std_dev_hm %>% as.logical()) {
show_hm <- heatmap() + sd_heatmap() ## temparory SD heatmap de activted
}else{
show_hm <- heatmap()
}
return(show_hm)
})
## render heatmap
output$heatmap <- renderPlot({
#req(heatmap_to_display())
# heatmap display in progress
# withProgress(message = "Display heatmap in progress" , {
# incProgress(0.5)
# set.seed(123)
# #hm <- shiny::isolate(ComplexHeatmap::draw(heatmap_to_display() , heatmap_legend_side = input$heatmap_legend_pos))
# incProgress(1)
# })
return(heatmap_to_display())
},
height = function() {
req(heatmap_top_variable_genes_df())
minimum_height <- 400
ht <- minimum_height + (input$hm_row_height * nrow(heatmap_top_variable_genes_df()$mat))
return(ht)
}, ## dynamic height
width = function() {
req(heatmap_top_variable_genes_df())
minimum_width <- 500
wd <- minimum_width + (input$hm_col_width * ncol(heatmap_top_variable_genes_df()$mat))
return(wd)
}, res = 108
) ## dynamic width
# Export heatmap
callModule(module = export_base_graphics ,
id = "export_heatmap" ,
file_name = "heatmap" ,
plot = as_mapper(~heatmap_to_display()), ## pass as a function does not open device locally
legend_pos = reactive(input$heatmap_legend_pos))
## prepare heatmap data for display
active_heatmap_data <- reactive({
req(heatmap_to_display())
# clusts must be a list. However, if only 1 cluster (rowwise) given , `clusts` becomes vector.
# To overcome this, convert clusts to list explicitly when number of row clusters == 1.
if(heatmap()@matrix_param$row_split %>% pull(row_split) %>% unique() %>% length() == 1) { ## this can be improved
clusts <- list("1" = ComplexHeatmap::row_order(heatmap()))
} else {
## return list where names of each elem indicates the cluster name displyed in heatmap
clusts <- ComplexHeatmap::row_order(heatmap())
}
## prepare the tibble of two column where first column is cluster names and second column is row number of original data matrix given to the ComplexHeatmap::Heatmap function
names(clusts) <- as.character(names(clusts))
hm_clust <- data_frame(clust = names(clusts), row_num = clusts) %>%
tidyr::unnest()
##column order
hm_coloum_ord <- ComplexHeatmap::column_order(heatmap()) %>% unlist(use.names = F)
## final data to be shown below heatmap as heatmap data
hm_data <- heatmap_top_variable_genes_df()$mat %>% ## this is the original data supplied to the heatmap
as.data.frame() %>%
dplyr::select(hm_coloum_ord) %>%
rownames_to_column(var = "gene_name") %>%
as_data_frame() %>%
dplyr::mutate(row_num = dplyr::row_number()) %>%
right_join(hm_clust , by = "row_num") %>% ## two tibble will be join by row_num column
dplyr::select(-row_num) %>%
left_join(heatmap_top_variable_genes_df()$row_sd %>%
as.data.frame() %>%
tibble::rownames_to_column("gene_name") , by = "gene_name")## add std dev
return(hm_data %>%
dplyr::mutate_if(is.numeric, round, 4))
})
## genome annotation for heatmap
## global genome annotations object cannot be used in following scenario
## For example : user has generated one heatmap. Now accidently or purposely user selected / uploaded data
## for different species than the previous heatmap generated. In this scenario, global reference genome will
## be updated , and therefore, annotations in the existing heatmap will also be affected.
## To prepvent this seprate heatmap ref genome from global annot. Heatmap ref annot will be updated only when
## plot heatmap submit button hit
heatmap_reference_annot <- eventReactive(input$generate_heatmap , {
req(genome_for_annotations())
return(genome_for_annotations())
})
## render heatmap data
output$heatmap_data <- DT::renderDataTable({
## map species annotations while displaying heatmap data
user_selected_species_annot <- ah_data_summary2 %>%
dplyr::filter(genome == heatmap_reference_annot()) %>%
dplyr::select(gr_cols) %>%
tidyr::unnest(cols = gr_cols)
join_col_x <- base::colnames(active_heatmap_data())[1] ## first column containing geneNames
join_col_y <- base::colnames(user_selected_species_annot)[7] ## "id" column
heat_map_data_to_show <- active_heatmap_data() %>%
left_join(user_selected_species_annot, by = setNames(join_col_y, join_col_x)) %>%
dplyr::select(1,c("seqnames", "start", "end", "strand", "description"), colnames(active_heatmap_data()))%>%
dplyr::mutate_all(funs(replace_na(as.character(.),"--NA--")))
return(heat_map_data_to_show)
},rownames = T,
selection = "none",
server = T,
extensions = "Buttons",
options = list(
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy", list(
extend =
"collection", buttons =
c("csv", "excel"), text = "Download"
)), # end of buttons customization
# customize the length menu
lengthMenu = list(
c(10, 50, 100, 500, -1) # declare values
, c(10, 50, 100, 500, "All") # declare titles
),
pageLength = 10
)
)
## prepare column cluster data
heatmap_column_cluster <- eventReactive(input$generate_heatmap,{
req(heatmap())
hm_column_labels <- heatmap()@column_names_param$labels
hm_column_ord <- ComplexHeatmap::column_order(heatmap())
named_list_from_vector <- purrr::as_mapper(~
if(!is_list(.x)){
list(`1` = .x)
}else{
.x
} )
## given a list of a char vector it returns a char vector where each elem of list collpase in a single vector elem.
colum_list_to_chr = as_mapper(~map_chr(., paste0 , collapse =","))
hm_column_ord_lst <- named_list_from_vector(hm_column_ord)
## wide format
wide <- tibble(cluster = names(hm_column_ord_lst) , column_order = hm_column_ord_lst) %>%
tidyr::unnest() %>%
dplyr::mutate(column_labels = hm_column_labels[column_order]) %>%
dplyr::select(-column_order) %>%
dplyr::group_by(cluster) %>%
dplyr::summarise(column_labels = list(column_labels)) %>%
dplyr::mutate(count = lengths(column_labels)) %>%
dplyr::mutate(column_labels = colum_list_to_chr(column_labels)) %>%
dplyr::select(cluster, count, column_labels) %>%
dplyr::slice(match(names(hm_column_ord_lst) , .$cluster )) ## arrange clusters in original heatmap order
## given a char vector , reeturns list of vectors. Each elem of char will be splitted by 'split' and all splitted elems will be strored in a vector
colum_chr_to_list = as_mapper(~map(., function(.) {strsplit(. , split = ",") %>% unlist() }))
## Long format
long <- wide %>%
dplyr::mutate(column_labels = colum_chr_to_list(column_labels)) %>%
tidyr::unnest(cols = column_labels)
list(wide = wide, long = long)
})
## prepare row cluster data
heatmap_row_cluster <-eventReactive(input$generate_heatmap,{
req(active_heatmap_data())
## get data from reactive elems
active_hm_data <- active_heatmap_data()
cols_of_interest <- c(colnames(active_hm_data)[1] , "clust")
wide <- active_hm_data %>%
dplyr::select(cols_of_interest) %>% ## select first (gene name) and row cluster column : 'clust'
dplyr::group_by(clust) %>%
dplyr::summarise(row_labels = list(!!as.symbol(cols_of_interest[1] ))) %>%
dplyr::mutate(count = lengths(row_labels)) %>%
dplyr::mutate(row_labels = map_chr(row_labels, ~paste0(.x , collapse = ","))) %>%
dplyr::select( clust, count , row_labels) %>%
dplyr::slice(match( active_heatmap_data()$clust %>% unique(), .$clust )) ## arrange in orginal order
## given a char vector , reeturns list of vectors. Each elem of char will be splitted by 'split' and all splitted elems will be strored in a vector
colum_chr_to_list = as_mapper(~map(., function(.) {strsplit(. , split = ",") %>% unlist() }))
long <- wide %>%
dplyr::mutate(row_labels = colum_chr_to_list(row_labels)) %>%
tidyr::unnest(cols = row_labels)
list(wide = wide, long = long )
})
# render heatmap cluster data
output$heatmap_display_cluster_data <- DT::renderDataTable({
if(input$heatmap_cluster_type == 'show_hm_row_side_clusters'){
return(heatmap_row_cluster()[[input$heatmap_cluster_data_format]])
} else if (input$heatmap_cluster_type == 'show_hm_column_side_clusters'){
return(heatmap_column_cluster()[[input$heatmap_cluster_data_format]] )
}
}, rownames = T,
selection = "none",
server = T,
extensions = "Buttons",
options = list(
scrollX = TRUE,
dom = "Blfrtip",
searchHighlight = TRUE,
buttons =
list("copy",
list(extend = "collection",
buttons =c("csv", "excel"),
text = "Download"
)
), # end of buttons customization
# customize the length menu
pageLength = 10
))
## heatmap functional analysis
callModule(module = functional_analysis_server ,
id = "heatmap_functional_analysis_ui" ,
ui_id = "heatmap_functional_analysis_ui",
session = session,
gene_set = reactive(split(x = active_heatmap_data()$gene_name,
f = factor(active_heatmap_data()$clust , levels = active_heatmap_data()$clust %>% unique()))) ,
genome = reactive({heatmap_reference_annot()}) )
## update heatmap column cluster in the wordcloud
observeEvent(input$generate_heatmap,{
shinyWidgets::updatePickerInput(session = session ,
inputId = "wordcloud_column_cluster",
choices = heatmap_column_cluster()$wide$cluster %>% gtools::mixedsort())
})
## heatmap word cloud
hm_cluster_wise_sample_infor_ll <- eventReactive(input$generate_heatmap, {
## get samples / column labels for user selected cluster
cluster_name_column_lable_tbl <- heatmap_column_cluster()$long %>%
dplyr::select(cluster, column_labels )
## get abstract from selected labels
join_col_x <- cluster_name_column_lable_tbl %>% colnames() %>% .[2] ## column having hm column labels
join_col_y <- user_selected_sra_id_sample_info() %>% colnames()%>% .[23] ## column having SRA id
cluster_wise_sample_infor_tbl <- cluster_name_column_lable_tbl %>%
left_join(user_selected_sra_id_sample_info() ,
by = setNames(join_col_y,join_col_x)) %>%
dplyr::group_by(cluster) %>%
tidyr::nest()
cluster_wise_sample_infor_ll <- cluster_wise_sample_infor_tbl %>%
dplyr::pull(2)
names(cluster_wise_sample_infor_ll) <- cluster_wise_sample_infor_tbl %>%
pull(1)
return(cluster_wise_sample_infor_ll)
})
observe({
callModule(id = "hm_sample_infor" ,
module = cluster_wise_sample_information_server , parent_id = "hm_sample_infor",
cluster_wise_sample_information = reactive(hm_cluster_wise_sample_infor_ll()))
})
####@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## Download page server code ----
####@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
## download GO data
callModule(module = download_go_data_server , id = "download_go_data" , ah_data = ah_data_summary2)
## download gene expression matrix
callModule(module = download_gene_expression_matrix_server , id = "download_gene_expression_data")
}
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.