Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Cleanup heatmap #166

Merged
merged 3 commits into from
Jan 31, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion program/shinyApp/R/enrichment_analysis/server.R
Original file line number Diff line number Diff line change
Expand Up @@ -682,7 +682,7 @@ enrichment_analysis_Server <- function(id, data, params, updates){
}
}
if(input$GeneSet2Enrich == "heatmap_genes"){
geneSetChoice_tmp <- heatmap_genelist
geneSetChoice_tmp <- par_tmp[[session$token]]$Heatmap$gene_list
}
}else{
if(input$ValueToAttach == "LFC" | input$ValueToAttach == "LFC_abs"){
Expand Down
74 changes: 33 additions & 41 deletions program/shinyApp/R/heatmap/fun_entitieSelection.R
Original file line number Diff line number Diff line change
@@ -1,74 +1,66 @@
entitieSelection=function(data,
type,
TopK2Show=NA,
additionalInput_row_anno=NA,
additionalInput_row_anno_factor=NA,
additionalInput_sample_annotation_types=NA,
additionalInput_ctrl_idx=NA,
additionalInput_cmp_idx=NA,
psig_threhsold=NA){
entitieSelection <- function(
data,
type,
TopK2Show=NA,
additionalInput_row_anno=NA,
additionalInput_row_anno_factor=NA,
additionalInput_sample_annotation_types=NA,
additionalInput_ctrl_idx=NA,
additionalInput_cmp_idx=NA,
psig_threhsold=NA
){
# to cover: c("TopK","significant_LFC","LFC_onlySig","rowAnno_based")
filtered_data=assay(data)
orderMakesSense_flag=FALSE
filtered_data <- assay(data)
orderMakesSense_flag <- FALSE
print("Entitie Selection")
#print(additionalInput_row_anno)
if(any(type=="rowAnno_based") & !(any(is.na(additionalInput_row_anno) &is.na(additionalInput_row_anno_factor))) & !any(additionalInput_row_anno_factor=="all")){
# Note here this only what to show, LFCs and more importantly multiple test correction will be done on the entire set (without the row anno based selection!!)
if(any(additionalInput_row_anno_factor=="all")){
filtered_data = filtered_data
}else{
filtered_data = filtered_data[which(data$annotation_rows[,additionalInput_row_anno] %in% additionalInput_row_anno_factor),]
filtered_data <- filtered_data
} else{
filtered_data <- filtered_data[which(data$annotation_rows[, additionalInput_row_anno] %in% additionalInput_row_anno_factor),]
}
}
if(!(is.na(additionalInput_sample_annotation_types)) & !(is.na(additionalInput_ctrl_idx)) & !(is.na(additionalInput_cmp_idx))){
if(any(type=="significant_LFC")){
# sort based on significance
# need LFCs
# is reachable from here? selectedData_processed()[[input$omicType]]$sample_table
# sort based on significance need LFCs
ctrl_samples_idx <- which(colData(data)[,additionalInput_sample_annotation_types]%in%additionalInput_ctrl_idx)
comparison_samples_idx <- which(colData(data)[,additionalInput_sample_annotation_types]%in%additionalInput_cmp_idx)
if((length(ctrl_samples_idx) <= 1) | (length(comparison_samples_idx) <= 1)){
warning("LFC makes no sense just having a single sample per conidition, which is here the case!")
filtered_data=NULL
}else{
LFC_output=getLFC(filtered_data,ctrl_samples_idx,comparison_samples_idx)
filtered_data=filtered_data[rownames(LFC_output)[order(LFC_output$p_adj,decreasing = F)],,drop=F]
orderMakesSense_flag=T
filtered_data <- NULL
} else{
LFC_output <- getLFC(filtered_data, ctrl_samples_idx, comparison_samples_idx)
filtered_data <- filtered_data[rownames(LFC_output)[order(LFC_output$p_adj, decreasing = F)],, drop=F]
orderMakesSense_flag <- T
}

}
if(any(type=="LFC_onlySig")){
ctrl_samples_idx<-which(colData(data)[,additionalInput_sample_annotation_types]%in%additionalInput_ctrl_idx)
comparison_samples_idx<-which(colData(data)[,additionalInput_sample_annotation_types]%in%additionalInput_cmp_idx)
LFC_output=getLFC(filtered_data,ctrl_samples_idx,comparison_samples_idx)
LFC_output <- getLFC(filtered_data, ctrl_samples_idx, comparison_samples_idx)
if(!(any(LFC_output$p_adj<psig_threhsold))){
warning("No single entry left! Maybe adjust psig_threhsold_heatmap (but do not put it arbitraly high!)")
#req(FALSE) -> can we speak from here to output$debug?
filtered_data=NULL
}else{
filtered_data=filtered_data[rownames(LFC_output)[which(LFC_output$p_adj<psig_threhsold)],,drop=F]
filtered_data=filtered_data[rownames(LFC_output)[order(LFC_output$LFC,decreasing = F)],,drop=F]
orderMakesSense_flag=T
filtered_data <- NULL
} else{
filtered_data <- filtered_data[rownames(LFC_output)[which(LFC_output$p_adj<psig_threhsold)],, drop=F]
filtered_data <- filtered_data[rownames(LFC_output)[order(LFC_output$LFC, decreasing = F)],, drop=F]
orderMakesSense_flag <- T
}

}
}

if(any(type=="TopK")){
if(orderMakesSense_flag){
#assumes the data to be sorted somehow
if(nrow(filtered_data)>TopK2Show){
filtered_data=filtered_data[c(1:TopK2Show),,drop=F]
}else{
filtered_data=filtered_data
filtered_data <- filtered_data[c(1:TopK2Show),, drop=F]
} else{
filtered_data <- filtered_data
}
}else{
filtered_data=NULL
} else{
filtered_data <- NULL
}

}



return(filtered_data)
}
63 changes: 19 additions & 44 deletions program/shinyApp/R/heatmap/server.R
Original file line number Diff line number Diff line change
Expand Up @@ -106,7 +106,6 @@ heatmap_server <- function(id, data, params, updates){
label = "Choose type for LFC-based ordering",
choices = c(colnames(colData(data$data))),
multiple = F
# selected = c(colnames(colData(data$data)))[1]
)
})
output$Groups2Compare_ref_heatmap_ui <- renderUI({
Expand Down Expand Up @@ -152,13 +151,13 @@ heatmap_server <- function(id, data, params, updates){

observe({
if(any(input$row_selection_options == "TopK")){
output$TopK_ui <- renderUI({
numericInput(inputId = ns("TopK"),
label = "Choose number of top entities to show (order based on p-val (LFC) or rowCount)",
min = 1,
step = 1,
value = 20)
})
output$TopK_ui <- renderUI({numericInput(
inputId = ns("TopK"),
label = "Choose number of top entities to show (order based on p-val (LFC) or rowCount)",
min = 1,
step = 1,
value = 20
)})
}else{
hide(id = "TopK", anim = T)
}
Expand All @@ -175,7 +174,7 @@ heatmap_server <- function(id, data, params, updates){
label = "Choose the variable to select the rows after (Multiples are not possible)",
choices = c(colnames(rowData(data$data))),
selected = colnames(rowData(data$data))[1],
multiple = F # would be cool if true, to be able to merge vars ?!,
multiple = F
)
})
output$row_anno_options_heatmap_ui <- renderUI({
Expand Down Expand Up @@ -236,7 +235,7 @@ heatmap_server <- function(id, data, params, updates){
ifelse(any(input$sample_selection!="all"),paste0(" (with: ",paste0(input$sample_selection,collapse = ", "),")"),""),
"-preprocessing: ",
input$PreProcessing_Procedure
)
)

### atm raw data plotted
data2Plot <- data$data
Expand All @@ -259,11 +258,6 @@ heatmap_server <- function(id, data, params, updates){
# selection based on row Annotation:
if(!(any(input$row_selection_options == "all"))){
if(any(input$row_selection_options == "rowAnno_based")){
# if(any(input$row_anno_options_heatmap=="SELECT_AN_OPTION")){ #old
# output$Options_selected_out_3=renderText({"If you go with rowAnno_based you must select a varaible to select the rows after! (See Section Further row selection). Now it is defaulting to show all to omit an error"})
# additionalInput_row_anno="all"
# additionalInput_row_anno_factor=NA
# }else{
print(input$row_anno_options_heatmap)
additionalInput_row_anno <- ifelse(any(input$row_selection_options == "rowAnno_based"),"yip",NA)
if(!is.na(additionalInput_row_anno)){
Expand All @@ -288,9 +282,7 @@ heatmap_server <- function(id, data, params, updates){
additionalInput_ctrl_idx <- ifelse(isTruthy(input$Groups2Compare_ref_heatmap),input$Groups2Compare_ref_heatmap,NA)
additionalInput_cmp_idx <- ifelse(isTruthy(input$Groups2Compare_treat_heatmap),input$Groups2Compare_treat_heatmap,NA)
psig_threhsold <- ifelse(isTruthy(input$psig_threhsold_heatmap),input$psig_threhsold_heatmap,NA)
print(paste0("This should not be NA if LFC Settings: ",
additionalInput_sample_annotation_types)
)
print(paste0("This should not be NA if LFC Settings: ", additionalInput_sample_annotation_types))
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Also testing statements - can be removed

print(paste0("This should not be NA if LFC Settings: ",
input$Groups2Compare_ref_heatmap,
input$Groups2Compare_treat_heatmap)
Expand Down Expand Up @@ -384,7 +376,7 @@ heatmap_server <- function(id, data, params, updates){
data = as.data.frame(data2HandOver),
ctrl_samples_idx = ctrl_samples_idx,
comparison_samples_idx = comparison_samples_idx
)
)

## do pheatmap

Expand Down Expand Up @@ -516,18 +508,6 @@ heatmap_server <- function(id, data, params, updates){
if(nchar(Heatmap_customTitleHeatmap) >= 250){
Heatmap_customTitleHeatmap <- "Heatmap"
}

# Heatmap_heatmap_plot <- heatmap_plot
# Heatmap_row_anno_options_heatmap <- input$row_anno_options_heatmap
# Heatmap_TopK <- input$TopK
# Heatmap_row_selection_options <- input$row_selection_options
# Heatmap_anno_options <- input$anno_options
# Heatmap_row_anno_options <- input$row_anno_options
# Heatmap_cluster_rows <- input$cluster_rows
# Heatmap_LFC_toHeatmap <- input$LFC_toHeatmap
# Heatmap_sample_annotation_types_cmp_heatmap <- input$sample_annotation_types_cmp_heatmap
# Heatmap_Groups2Compare_ref_heatmap <- input$Groups2Compare_ref_heatmap
# Heatmap_Groups2Compare_ctrl_heatmap <- input$Groups2Compare_ctrl_heatmap


# res_tmp[[session$token]] gets data2HandOver or Data2Plot depending on scenario
Expand Down Expand Up @@ -624,24 +604,24 @@ heatmap_server <- function(id, data, params, updates){
},

content = function(file){
write.csv(heatmap_genelist, file)
write.csv(par_tmp[[session$token]]$Heatmap$gene_list, file)
on.exit({
if(FLAG_nonUnique_Heatmap){
if(heatmap_reactives$FLAG_nonUnique_Heatmap){
showModal(modalDialog(
title = "Warning!",
"The download includes non-unique entries, hence you will not be able to distinguish the entities uniquely. You might want to change the entry in 'choose the label of rows' for the next download",
easyClose = TRUE
))
}
fun_LogIt(message = paste0("**HEATMAP** - The corresponding entitie list was saved by the user"))
fun_LogIt(message = paste0("**HEATMAP** - Number of entities: ",length(heatmap_genelist)))
fun_LogIt(message = paste0("**HEATMAP** - Number of entities: ",length(par_tmp[[session$token]]$Heatmap$gene_list)))
})
}
)

## adjust the returned names depending on chosen label of rows
if(is.null(data2HandOver)){
FLAG_nonUnique_Heatmap <<- F
heatmap_reactives$FLAG_nonUnique_Heatmap <<- F
NA
}else{
mergedData <- merge(
Expand All @@ -657,19 +637,14 @@ heatmap_server <- function(id, data, params, updates){
# heatmap_genelist now consists of the rownames, enabling a
# smooth translation in the enrichment case
if(length(unique(mergedData[,input$row_label_options]))<nrow(mergedData) ){
FLAG_nonUnique_Heatmap <<- T
heatmap_genelist <<- mergedData[,"Row.names"]
heatmap_reactives$FLAG_nonUnique_Heatmap <<- T
par_tmp[[session$token]]$Heatmap$gene_list <<- mergedData[,"Row.names"]
}else{
FLAG_nonUnique_Heatmap <<- F
heatmap_genelist <<- mergedData[,"Row.names"]
heatmap_reactives$FLAG_nonUnique_Heatmap <<- F
par_tmp[[session$token]]$Heatmap$gene_list <<- mergedData[,"Row.names"]
}
}
})
# observeEvent(input$Do_Heatmap,{
# output$Options_selected_out_3 <- renderText({
# paste0("The number of selected entities: ",length((heatmap_genelist)))
# })
# })
# send only to report
observeEvent(input$only2Report_Heatmap,{
notificationID <- showNotification("Saving...",duration = 0)
Expand Down
4 changes: 2 additions & 2 deletions program/shinyApp/R/heatmap/ui.R
Original file line number Diff line number Diff line change
Expand Up @@ -132,8 +132,8 @@ heatmap_UI <- function(id){
id = "heatmap",
fluid = T,
h4("Heatmap"),
heatmap_sidebar <- heatmap_sidebar(ns),
heatmap_main <- heatmap_main(ns)
heatmap_sidebar(ns),
heatmap_main(ns)
)
}

Loading