Added batch Correction as an option to processing the data

program/shinyApp/R/enrichment_analysis/ui.R

@@ -77,6 +77,7 @@ ea_sidebar <- function(ns){
     id = "sidebar_enrichment_analysis",
     uiOutput(outputId = ns("OrganismChoice_ui")) %>% helper(type = "markdown", content = "EA_Options"),
     uiOutput(outputId = ns("ORA_or_GSE_ui")),
+    uiOutput(outputId = ns("UseBatch_ui")),
     uiOutput(outputId = ns("ValueToAttach_ui")),
     uiOutput(outputId = ns("sample_annotation_types_cmp_GSEA_ui")),
     uiOutput(outputId = ns("Groups2Compare_ref_GSEA_ui")),

program/shinyApp/R/heatmap/server.R

@@ -64,7 +64,16 @@ heatmap_server <- function(id, data, params, updates){
           hide(id = "cluster_rows", anim = T )
         }
       })
-
+
+      output$UseBatch_ui <- renderUI({
+        req(par_tmp[[session$token]]$BatchColumn != "NULL")
+        selectInput(
+          inputId = ns("UseBatch"),
+          label = "Use batch corrected data?",
+          choices = c("No","Yes"),
+          selected = "No"
+        )
+      })
 
       output$LFC_toHeatmap_ui <-renderUI({
         req(data_input_shiny())
@@ -217,6 +226,7 @@ heatmap_server <- function(id, data, params, updates){
         )
         req(selectedData_processed())
         # update the data
+        useBatch <- ifelse(input$UseBatch == "Yes",T,F)
         data <- update_data(session$token)
         print("Heatmap on selected Data")
         # Value need to be setted in case there is nothing to plot to avoid crash
@@ -234,8 +244,11 @@ heatmap_server <- function(id, data, params, updates){
           input$PreProcessing_Procedure
         )
 
-        ### atm raw data plotted
-        data2Plot <- data$data
+        if(useBatch){
+            data2Plot <- data$data_batch_corrected
+        } else {
+            data2Plot <- data$data
+        }
 
         print(customTitleHeatmap)
         mycolors <- list()
@@ -324,6 +337,7 @@ heatmap_server <- function(id, data, params, updates){
         print(paste0("plot LFC's?",input$LFC_toHeatmap))
         # Dependent to plot raw data or LFC if calculation is needed
         calculate <- 1
+        # TODO: Lea for code snippet?
         # check whether we have to calculate
         # Does not find funtion
         # check <- check_calculations(list(

program/shinyApp/R/heatmap/ui.R

@@ -4,6 +4,7 @@ heatmap_sidebar<- function(ns){
     #########################################
     # Heatmap
     #########################################
+    uiOutput(outputId = ns("UseBatch_ui")),
     uiOutput(outputId = ns("row_selection_options_ui")) %>% helper(type = "markdown", content = "Heatmap_Options"),
     uiOutput(outputId = ns("LFC_toHeatmap_ui")),
     h5("Further row selection (LFC based)") %>% helper(type = "markdown", content = "Heatmap_FurtherOptions"),

program/shinyApp/R/pca/server.R

@@ -21,6 +21,15 @@ pca_Server <- function(id, data, params, row_select){
       ns <- session$ns
 
       ## UI Section ----
+      output$UseBatch_ui <- renderUI({
+        req(par_tmp[[session$token]]$BatchColumn != "NULL")
+        selectInput(
+          inputId = ns("UseBatch"),
+          label = "Use batch corrected data?",
+          choices = c("No","Yes"),
+          selected = "No"
+        )
+      })
       output$x_axis_selection_ui <- renderUI({radioGroupButtons(
         inputId = ns("x_axis_selection"),
         label = "PC for x-Axis",
@@ -136,9 +145,9 @@ pca_Server <- function(id, data, params, row_select){
         req(input$Do_PCA > pca_reactives$counter)
         pca_reactives$counter <- input$Do_PCA
         check <- check_calculations(list(
-          dummy = "dummy",
           sample_selection_pca = input$sample_selection_pca,
-          SampleAnnotationTypes_pca = input$SampleAnnotationTypes_pca
+          SampleAnnotationTypes_pca = input$SampleAnnotationTypes_pca,
+          batch = ifelse(input$UseBatch == "Yes",T,F)
         ), "PCA")
         if (check == "No Result yet"){
           output$PCA_Info <- renderText("PCA computed.")
@@ -176,22 +185,29 @@ pca_Server <- function(id, data, params, row_select){
         # only calculate PCA, Score and Loadings if the counter is >= 0
         if(pca_reactives$calculate >= 0){
           # update the data
+          useBatch <- ifelse(input$UseBatch == "Yes",T,F)
           data2plot <- update_data(session$token)
           # select the neccesary data
           if(input$data_selection_pca){
             data2plot <- select_data(
               data2plot,
               input$sample_selection_pca,
-              input$SampleAnnotationTypes_pca
+              input$SampleAnnotationTypes_pca,
+              useBatch
             )
           }
+          if(useBatch){
+              data2plot <- data2plot$data_batch_corrected
+          } else {
+              data2plot <- data2plot$data
+          }
           # set the counter to -1 to prevent any further plotting
           pca_reactives$calculate <- -1
           print("Calculate PCA")
           # PCA, for safety measures, wrap in tryCatch
           tryCatch({
             pca <- prcomp(
-              x = as.data.frame(t(as.data.frame(assay(data2plot$data)))),
+              x = as.data.frame(t(as.data.frame(assay(data2plot)))),
               center = T,
               scale. = FALSE
             )
@@ -206,7 +222,7 @@ pca_Server <- function(id, data, params, row_select){
           percentVar <- round(100 * explVar, digits = 1)
 
           # Define data for plotting
-          pcaData <- data.frame(pca$x,colData(data2plot$data))
+          pcaData <- data.frame(pca$x,colData(data2plot))
 
           df_out_r <- NULL
           if(input$Show_loadings == "Yes"){
@@ -238,8 +254,8 @@ pca_Server <- function(id, data, params, row_select){
             if(!is.null(input$EntitieAnno_Loadings)){
               req(data_input_shiny())
               df_out_r$chosenAnno <- factor(
-                make.unique(as.character(rowData(data2plot$data)[rownames(df_out_r),input$EntitieAnno_Loadings])),
-                levels = make.unique(as.character(rowData(data2plot$data)[rownames(df_out_r),input$EntitieAnno_Loadings]))
+                make.unique(as.character(rowData(data2plot)[rownames(df_out_r),input$EntitieAnno_Loadings])),
+                levels = make.unique(as.character(rowData(data2plot)[rownames(df_out_r),input$EntitieAnno_Loadings]))
               )
             }
           }
@@ -265,8 +281,8 @@ pca_Server <- function(id, data, params, row_select){
           if(!is.null(input$EntitieAnno_Loadings)){
             req(data_input_shiny())
             LoadingsDF$entitie <- factor(
-              make.unique(as.character(rowData(data2plot$data)[rownames(LoadingsDF),input$EntitieAnno_Loadings])),
-              levels = make.unique(as.character(rowData(data2plot$data)[rownames(LoadingsDF),input$EntitieAnno_Loadings]))
+              make.unique(as.character(rowData(data2plot)[rownames(LoadingsDF),input$EntitieAnno_Loadings])),
+              levels = make.unique(as.character(rowData(data2plot)[rownames(LoadingsDF),input$EntitieAnno_Loadings]))
             )
           }
           # Loadings Matrix plot
@@ -292,8 +308,8 @@ pca_Server <- function(id, data, params, row_select){
           if(!is.null(input$EntitieAnno_Loadings_matrix)){
             req(data_input_shiny())
             df_loadings$chosenAnno <- factor(
-              make.unique(as.character(rowData(data2plot$data)[unique(df_loadings$entity),input$EntitieAnno_Loadings_matrix])),
-              levels = make.unique(as.character(rowData(data2plot$data)[unique(df_loadings$entity),input$EntitieAnno_Loadings_matrix]))
+              make.unique(as.character(rowData(data2plot)[unique(df_loadings$entity),input$EntitieAnno_Loadings_matrix])),
+              levels = make.unique(as.character(rowData(data2plot)[unique(df_loadings$entity),input$EntitieAnno_Loadings_matrix]))
             )
           } else{
             df_loadings$chosenAnno <- df_loadings$entity
@@ -311,8 +327,8 @@ pca_Server <- function(id, data, params, row_select){
           # assign par_temp as empty list
           par_tmp[[session$token]][["PCA"]] <<- list(
             sample_selection_pca = input$sample_selection_pca,
-            SampleAnnotationTypes_pca = input$SampleAnnotationTypes_pca
-
+            SampleAnnotationTypes_pca = input$SampleAnnotationTypes_pca,
+            UseBatch = useBatch
           )
         } else {
           # otherwise read the reactive values

program/shinyApp/R/pca/ui.R

@@ -6,6 +6,7 @@ pca_sidebar_panel <- function(ns){
     # PCA
     #########################################
     h4("Explorative Analysis") %>% helper(type = "markdown", content = "PCA_Choices"),
+    uiOutput(outputId = ns("UseBatch_ui")),
     ### data selection
     switchInput(
       inputId = ns("data_selection_pca"),

program/shinyApp/R/pre_processing/ui.R

@@ -13,8 +13,12 @@ pre_processing_sidebar_panel <- sidebarPanel(
     ),
     selected = "none"
   ) %>% helper(type = "markdown", content = "PreProcessing_Procedures"),
-  uiOutput(outputId = "DESeq_formula_main_ui") %>% helper(type = "markdown", content = "PreProcessing_DESeqMain"),
-  uiOutput(outputId = "DESeq_formula_sub_ui") %>% helper(type = "markdown", content = "PreProcessing_DESeqSub"),
+
+  uiOutput(outputId = "DESeq_formula_main_ui"),
+  uiOutput(outputId = "DESeq_formula_sub_ui"),
+
+  uiOutput(outputId = "batch_effect_ui"),
+
   actionButton(
     inputId = "Do_preprocessing",
     label = "Get Pre-Processing",

program/shinyApp/R/pre_processing/util.R

@@ -83,7 +83,7 @@ ln_normalisation <- function(data, omic_type, logarithm_procedure){
 
 
 deseq_processing <- function(
-  data, omic_type, formula_main, formula_sub, session_token, advanced_formula = NULL
+  data, omic_type, formula_main, formula_sub, session_token, batch_correct
 ){
   # Center and scale the data
   # prefilter the data
@@ -125,14 +125,17 @@ deseq_processing <- function(
       )
 
     de_seq_result <- DESeq2::DESeq(dds)
-    res_tmp[[session_token]]$DESeq_obj <<- de_seq_result
+    if (batch_correct){
+      res_tmp[[session_token]]$DESeq_obj_batch_corrected <<- de_seq_result
+    } else {
+      res_tmp[[session_token]]$DESeq_obj <<- de_seq_result
+    }
     dds_vst <- vst(
       object = de_seq_result,
       blind = TRUE
-      )
+    )
     assay(data) <- as.data.frame(assay(dds_vst))
     return(data)
   }
-  addWarning <- "<font color=\"#FF0000\"><b>DESeq makes only sense for transcriptomics data - data treated as if 'filterOnly' was selected!</b></font>"
   return(data)
 }

program/shinyApp/R/sample_correlation/server.R

@@ -14,6 +14,15 @@ sample_correlation_server <- function(id, data, params){
 
       ns <- session$ns
       # UI Section ----
+      output$UseBatch_ui <- renderUI({
+        req(par_tmp[[session$token]]$BatchColumn != "NULL")
+        selectInput(
+          inputId = ns("UseBatch"),
+          label = "Use batch corrected data?",
+          choices = c("No","Yes"),
+          selected = "No"
+        )
+      })
       output$SampleAnnotationChoice_ui <- renderUI({
         req(selectedData_processed())
         selectInput(
@@ -37,19 +46,26 @@ sample_correlation_server <- function(id, data, params){
 
         if(sample_corr_reactive$calculate == 1){
           # update the data if needed
+          useBatch <- ifelse(input$UseBatch == "Yes",T,F)
           data <- update_data(session$token)
+          if(useBatch){
+              data <- data$data_batch_corrected
+          } else {
+              data <- data$data
+          }
           # set the counter to 0 to prevent any further plotting
           sample_corr_reactive$calculate <- 0
 
           # check value of input$Do_SampleCorrelation
-          annotationDF <- colData(data$data)[,input$SampleAnnotationChoice,drop = F]
+          annotationDF <- colData(data)[,input$SampleAnnotationChoice,drop = F]
           check <- check_calculations(
             list(
               corrMethod = input$corrMethod,
               data_info = list(
-                rows = length(rownames(data$data)),
-                cols = length(colnames(data$data)),
-                preprocessing = par_tmp[[session$token]]$PreProcessing_Procedure
+                rows = length(rownames(data)),
+                cols = length(colnames(data)),
+                preprocessing = par_tmp[[session$token]]$PreProcessing_Procedure,
+                batch = useBatch
               )
             ),
             "SampleCorrelation"
@@ -61,7 +77,7 @@ sample_correlation_server <- function(id, data, params){
                 "Correlation Matrix successfully computed."
               )
               cormat <- cor(
-                x = as.matrix(assay(data$data)),
+                x = as.matrix(assay(data)),
                 method = input$corrMethod
               )
             } else if (check == "Result exists"){
@@ -74,7 +90,7 @@ sample_correlation_server <- function(id, data, params){
                 "Correlation Matrix result overwritten with different parameters."
               )
               cormat <- cor(
-                x = as.matrix(assay(data$data)),
+                x = as.matrix(assay(data)),
                 method = input$corrMethod
               )
             }
@@ -106,9 +122,10 @@ sample_correlation_server <- function(id, data, params){
           par_tmp[[session$token]][["SampleCorrelation"]] <<- list(
             corrMethod = input$corrMethod,
             data_info = list(
-              rows = length(rownames(data$data)),
-              cols = length(colnames(data$data)),
-              preprocessing = par_tmp[[session$token]]$PreProcessing_Procedure
+              rows = length(rownames(data)),
+              cols = length(colnames(data)),
+              preprocessing = par_tmp[[session$token]]$PreProcessing_Procedure,
+              batch = useBatch
             )
           )
 

program/shinyApp/R/sample_correlation/ui.R

@@ -2,6 +2,7 @@ sampleCorrelation_sidebar_panel <- function(ns){
   sidebarPanel(
     id = "sidebar_sampleCorrelation",
     h4("Sample Correlation") %>% helper(type = "markdown", content = "SampleCorr_Choices"),
+    uiOutput(outputId = ns("UseBatch_ui")),
     selectInput(
       inputId = ns("corrMethod"),
       label = "Choose the correlation method",