Cleanup heatmap (#166)

* Removed assignments, as return is questionable. * Removed comments, removed global variance dependency. * Mainly spacing and replacing = with =
ICB-DCM · Jan 31, 2024 · 50e5bc8 · 50e5bc8
1 parent 1a230c0
commit 50e5bc8
Show file tree

Hide file tree

Showing 4 changed files with 55 additions and 88 deletions.
diff --git a/program/shinyApp/R/enrichment_analysis/server.R b/program/shinyApp/R/enrichment_analysis/server.R
@@ -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"){

diff --git a/program/shinyApp/R/heatmap/fun_entitieSelection.R b/program/shinyApp/R/heatmap/fun_entitieSelection.R
@@ -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)
 }
diff --git a/program/shinyApp/R/heatmap/server.R b/program/shinyApp/R/heatmap/server.R
@@ -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({
@@ -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)
         }
@@ -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({
@@ -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
@@ -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)){
@@ -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)
@@ -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
 
@@ -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
@@ -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(
@@ -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)

diff --git a/program/shinyApp/R/heatmap/ui.R b/program/shinyApp/R/heatmap/ui.R
@@ -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)
   )
 }