Skip to content

Commit

Permalink
Cleanup heatmap (#166)
Browse files Browse the repository at this point in the history
* Removed assignments, as return is questionable.

* Removed comments, removed global variance dependency.

* Mainly spacing and replacing = with =
  • Loading branch information
PaulJonasJost authored Jan 31, 2024
1 parent 1a230c0 commit 50e5bc8
Show file tree
Hide file tree
Showing 4 changed files with 55 additions and 88 deletions.
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 @@ -589,7 +589,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))
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)
)
}

0 comments on commit 50e5bc8

Please sign in to comment.