diff --git a/program/shinyApp/R/enrichment_analysis/ui.R b/program/shinyApp/R/enrichment_analysis/ui.R index 459cdc05..d41a2dd0 100644 --- a/program/shinyApp/R/enrichment_analysis/ui.R +++ b/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")), diff --git a/program/shinyApp/R/heatmap/server.R b/program/shinyApp/R/heatmap/server.R index 8a99c1cc..1175a1a2 100644 --- a/program/shinyApp/R/heatmap/server.R +++ b/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( diff --git a/program/shinyApp/R/heatmap/ui.R b/program/shinyApp/R/heatmap/ui.R index a0e15723..10e9a4a6 100644 --- a/program/shinyApp/R/heatmap/ui.R +++ b/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"), diff --git a/program/shinyApp/R/pca/server.R b/program/shinyApp/R/pca/server.R index 20a2002c..e8669029 100644 --- a/program/shinyApp/R/pca/server.R +++ b/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 diff --git a/program/shinyApp/R/pca/ui.R b/program/shinyApp/R/pca/ui.R index f3702a58..66f43c30 100644 --- a/program/shinyApp/R/pca/ui.R +++ b/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"), diff --git a/program/shinyApp/R/pre_processing/ui.R b/program/shinyApp/R/pre_processing/ui.R index 571ebe23..9c88fa45 100644 --- a/program/shinyApp/R/pre_processing/ui.R +++ b/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", diff --git a/program/shinyApp/R/pre_processing/util.R b/program/shinyApp/R/pre_processing/util.R index 295d8206..7339b737 100644 --- a/program/shinyApp/R/pre_processing/util.R +++ b/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 <- "DESeq makes only sense for transcriptomics data - data treated as if 'filterOnly' was selected!" return(data) } diff --git a/program/shinyApp/R/sample_correlation/server.R b/program/shinyApp/R/sample_correlation/server.R index a3ee8dc5..2187b068 100644 --- a/program/shinyApp/R/sample_correlation/server.R +++ b/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 ) ) diff --git a/program/shinyApp/R/sample_correlation/ui.R b/program/shinyApp/R/sample_correlation/ui.R index f536cc8a..02b57b49 100644 --- a/program/shinyApp/R/sample_correlation/ui.R +++ b/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", diff --git a/program/shinyApp/R/significance_analysis/server.R b/program/shinyApp/R/significance_analysis/server.R index 8b339808..b5718ecc 100644 --- a/program/shinyApp/R/significance_analysis/server.R +++ b/program/shinyApp/R/significance_analysis/server.R @@ -13,7 +13,15 @@ significance_analysis_server <- function(id, data, params){ ) ns <- session$ns ## Sidebar UI section - # UI to choose type of comparison + 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$type_of_comparison_ui <- renderUI({ req(data_input_shiny()) if(is.null(sig_ana_reactive$coldata)){ @@ -192,7 +200,13 @@ significance_analysis_server <- function(id, data, params){ print("Start the Significance Analysis") # update the data if needed data <- update_data(session$token) - sig_ana_reactive$coldata <- colData(data$data) + useBatch <- ifelse(input$UseBatch == "Yes",T,F) + if(useBatch){ + data_calculate <- data$data_batch_corrected + } else { + data_calculate <- data$data + } + sig_ana_reactive$coldata <- colData(data_calculate) # delete old panels if(!is.null(sig_ana_reactive$significance_tabs_to_delete)){ for (i in seq_along(sig_ana_reactive$significance_tabs_to_delete)) { @@ -204,7 +218,11 @@ significance_analysis_server <- function(id, data, params){ } # if preproccesing method was DESeq2, then use DESeq2 for testing if(params$PreProcessing_Procedure == "vst_DESeq"){ - dds <- data$DESeq_obj + if (useBatch){ + dds <- data$DESeq_obj_batch_corrected + } else { + dds <- data$DESeq_obj + } # rewind the comparisons again newList <- input$comparisons contrasts <- vector("list", length(input$comparisons)) @@ -215,7 +233,11 @@ significance_analysis_server <- function(id, data, params){ sig_ana_reactive$sig_results <- list() for (i in seq_along(contrasts)) { if(identical( - list(test_method = "Wald", test_correction = PADJUST_METHOD[[input$test_correction]]), + list( + test_method = "Wald", + test_correction = PADJUST_METHOD[[input$test_correction]], + batch_corrected = useBatch + ), par_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]][[input$comparisons[i]]] )){ print("Results exists, skipping calculations.") @@ -235,7 +257,8 @@ significance_analysis_server <- function(id, data, params){ res_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]][[input$comparisons[i]]] <<- sig_ana_reactive$sig_results[[input$comparisons[i]]] par_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]][[input$comparisons[i]]] <<- list( test_method = "Wald", - test_correction = PADJUST_METHOD[[input$test_correction]] + test_correction = PADJUST_METHOD[[input$test_correction]], + batch_corrected = useBatch ) } } else { # all other methods require manual testing @@ -253,11 +276,11 @@ significance_analysis_server <- function(id, data, params){ names(contrasts) <- input$comparisons # get names of columns we want to choose: index_comparisons <- which( - colData(data$data)[,input$sample_annotation_types_cmp] %in% contrasts_all + colData(data_calculate)[,input$sample_annotation_types_cmp] %in% contrasts_all ) - samples_selected <- colData(data$data)[index_comparisons,] + samples_selected <- colData(data_calculate)[index_comparisons,] # get the data - data_selected <- as.matrix(assay(data$data))[,index_comparisons] + data_selected <- as.matrix(assay(data_calculate))[,index_comparisons] # significance analysis saved the result in res_tmp. # as it is a custom function, wrap in tryCatch tryCatch({ @@ -267,7 +290,8 @@ significance_analysis_server <- function(id, data, params){ contrasts = contrasts, method = input$test_method, correction = PADJUST_METHOD[[input$test_correction]], - contrast_level = input$sample_annotation_types_cmp + contrast_level = input$sample_annotation_types_cmp, + batch_corrected = useBatch ) sig_ana_reactive$sig_results <- res_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]] }, error = function(e){ @@ -336,7 +360,7 @@ significance_analysis_server <- function(id, data, params){ chosenVizSet <- input$comparisons } else { chosenVizSet <- input$comparisons[c(1,2)] - sig_ana_reactive$info_text <- "Note: Although you choose 'all' to visualize only first 2 comparisons are shown to avoid unwanted computational overhead, + sig_ana_reactive$info_text <- "Note: Although you choose 'all' to visualize only first 2 comparisons are shown to avoid unwanted computational overhead, as you got more than 4 comparisons. Please choose precisely the comparisons for visualisation." } }else{ @@ -519,7 +543,7 @@ significance_analysis_server <- function(id, data, params){ fun_LogIt(message = "### SIGNIFICANCE ANALYSIS") fun_LogIt(message = paste( "- Significance Analysis was performed on", - length(data$data), + length(data_calculate), "entities" )) # log which tests were performed diff --git a/program/shinyApp/R/significance_analysis/ui.R b/program/shinyApp/R/significance_analysis/ui.R index 0e4ee264..19502999 100644 --- a/program/shinyApp/R/significance_analysis/ui.R +++ b/program/shinyApp/R/significance_analysis/ui.R @@ -2,6 +2,7 @@ significance_analysis_sidebar_ui<- function(ns){ sidebarPanel( id = "sidebar_significance_analysis", h5(" ") %>% helper(type = "markdown", content = "SigAna_Choices"), + uiOutput(outputId = ns("UseBatch_ui")), uiOutput(outputId = ns("type_of_comparison_ui")), uiOutput(outputId = ns("chooseComparisons_ui")), # UI to choose test method diff --git a/program/shinyApp/R/significance_analysis/util.R b/program/shinyApp/R/significance_analysis/util.R index d515b937..d32b48e9 100644 --- a/program/shinyApp/R/significance_analysis/util.R +++ b/program/shinyApp/R/significance_analysis/util.R @@ -736,7 +736,7 @@ create_new_tab_DESeq <- function(title, targetPanel, result, contrast, alpha, ns significance_analysis <- function( - df, samples, contrasts, method, correction, contrast_level + df, samples, contrasts, method, correction, contrast_level, batch_corrected = FALSE ){ # perform significance analysis # df: dataframe or matrix with the data @@ -795,7 +795,7 @@ significance_analysis <- function( for(contrast in contrasts){ # skip if already there if(identical( - list(test_method = method, test_correction = correction), + list(test_method = method, test_correction = correction, batch_corrected=batch_corrected), par_tmp[[session$token]]$SigAna[[contrast_level]][[names(contrasts)[comp_name]]] )){ print("Results exists, skipping calculations.") @@ -839,7 +839,8 @@ significance_analysis <- function( res_tmp[[session$token]]$SigAna[[contrast_level]][[names(contrasts)[comp_name]]] <<- res par_tmp[[session$token]]$SigAna[[contrast_level]][[names(contrasts)[comp_name]]] <<- list( test_method = method, - test_correction = correction + test_correction = correction, + batch_corrected = batch_corrected ) comp_name <- comp_name + 1 } diff --git a/program/shinyApp/R/single_gene_visualisation/server.R b/program/shinyApp/R/single_gene_visualisation/server.R index 7561316d..14b31e8c 100644 --- a/program/shinyApp/R/single_gene_visualisation/server.R +++ b/program/shinyApp/R/single_gene_visualisation/server.R @@ -14,7 +14,7 @@ single_gene_visualisation_server <- function(id, data){ selectInput( inputId = ns("type_of_data_gene"), label = "Choose Data to use (in case of DESeq- vst normalized counts are used)", - choices = c("raw","preprocessed"), + choices = c("raw","preprocessed", "batch_corrected_preprocessed"), multiple = F , selected = "preprocessed" ) @@ -120,7 +120,6 @@ single_gene_visualisation_server <- function(id, data){ GeneData$anno <- colData(data$data)[,input$accross_condition] GeneDataFlag <- T } else { - print("different Gene") GeneDataFlag <- F } @@ -134,7 +133,16 @@ single_gene_visualisation_server <- function(id, data){ # select to selection of processed data annoToSelect <- unique(c(colData(data$data)[,input$accross_condition])) GeneData <- subset(GeneData, anno %in% annoToSelect) - #print(data$data_original) + GeneDataFlag <- T + } else { + GeneDataFlag <- F + } + } else if(input$type_of_data_gene == "batch_corrected_preprocessed"){ + if(input$Select_Gene %in% rowData(data$data_batch_corrected)[,input$Select_GeneAnno]){ + #get IDX to data + idx_selected <- which(input$Select_Gene == rowData(data$data_batch_corrected)[,input$Select_GeneAnno]) + GeneData <- as.data.frame(t(as.data.frame(assay(data$data_batch_corrected))[idx_selected,,drop=F])) + GeneData$anno <- colData(data$data_batch_corrected)[,input$accross_condition] GeneDataFlag <- T } else { GeneDataFlag <- F diff --git a/program/shinyApp/R/util.R b/program/shinyApp/R/util.R index 64c38bad..29ac58a4 100644 --- a/program/shinyApp/R/util.R +++ b/program/shinyApp/R/util.R @@ -1,15 +1,24 @@ ### general utility functions will be defined here # tryCatch modal dialog -error_modal <- function(e){ +error_modal <- function(e, additional_text = NULL){ + if (is.null(e$message)){ + e$message <- "An unknown error occured" + } + if (is.null(additional_text)){ + additional_text <- "Please check your data set and annotation and try again.

" + } + additional_text <- paste0( + additional_text, + "

Otherwise, please contact the cOmicsArtist Lea and Paul via cOmicsArtist@outlook.de", + "or open an issue on github ", + "describing your problem." + ) showModal(modalDialog( title = HTML("An unknown Error occured"), HTML(paste0( "Error: ",e$message,"

", - "Please check your data set and annotation and try again.

", - "Otherwise, please contact the cOmicsArtist Lea and Paul via cOmicsArtist@outlook.de", - "or open an issue on github", - "describing your problem." + additional_text )), footer = modalButton("Close") )) @@ -24,20 +33,25 @@ update_data <- function(session_id){ } -select_data <- function(data, selected_samples, sample_type){ +select_data <- function(data, selected_samples, sample_type, useBatch = F){ # select data for e.g. pca's or alike + if(useBatch){ + data_entry <- "data_batch_corrected" + } else { + data_entry <- "data" + } samples_selected <- c() if(any(selected_samples == "all")){ - samples_selected <- colnames(assay(data$data)) + samples_selected <- colnames(assay(data[[data_entry]])) }else{ samples_selected <- c( samples_selected, - rownames(colData(data$data))[which( - colData(data$data)[,sample_type] %in% selected_samples + rownames(colData(data[[data_entry]]))[which( + colData(data[[data_entry]])[,sample_type] %in% selected_samples )] ) } - data$data <- data$data[,samples_selected] + data[[data_entry]] <- data[[data_entry]][,samples_selected] return(data) } diff --git a/program/shinyApp/server.R b/program/shinyApp/server.R index efed60b9..da76006d 100644 --- a/program/shinyApp/server.R +++ b/program/shinyApp/server.R @@ -785,6 +785,20 @@ server <- function(input,output,session){ # Set Selected Data as Head to allow reiteration of pre-processing ## UI section ---- + # Update the batch effect UI based on the available columns + output$batch_effect_ui <- renderUI({ + req(data_input_shiny()) + column_names <- colnames(colData(res_tmp[[session$token]]$data_original)) + if (input$PreProcessing_Procedure == "vst_DESeq") { + column_names <- column_names[!column_names %in% c(input$DESeq_formula_main, input$DESeq_formula_sub)] + } + selectInput( + inputId = "BatchEffect_Column", + label = "Select Batch Effect Column", + choices = c("NULL", column_names), + selected = "NULL" + ) + }) output$DESeq_formula_main_ui <- renderUI({ req(data_input_shiny()) req(input$PreProcessing_Procedure == "vst_DESeq") @@ -797,7 +811,7 @@ server <- function(input,output,session){ choices = c(colnames(colData(tmp_data_selected))), multiple = F, selected = "condition" - ) + ) %>% helper(type = "markdown", content = "PreProcessing_DESeqMain") }) output$DESeq_formula_sub_ui <- renderUI({ req(data_input_shiny()) @@ -811,7 +825,7 @@ server <- function(input,output,session){ choices = c(colnames(colData(tmp_data_selected))), multiple = T, selected = "condition" - ) + ) %>% helper(type = "markdown", content = "PreProcessing_DESeqSub") }) ## Do preprocessing ---- @@ -830,6 +844,49 @@ server <- function(input,output,session){ # explicitly set rownames to avoid any errors. # new object Created for res_tmp[[session$token]] res_tmp[[session$token]]$data <<- res_tmp[[session$token]]$data[rownames(res_tmp[[session$token]]$data),] + par_tmp[[session$token]]['BatchColumn'] <<- input$BatchEffect_Column + + # Batch correction before preprocessing + if (input$BatchEffect_Column != "NULL" & input$PreProcessing_Procedure != "vst_DESeq") { + tryCatch({ + res_tmp[[session$token]]$data_batch_corrected <<- prefiltering( + res_tmp[[session$token]]$data, + par_tmp[[session$token]]$omic_type + ) + assay(res_tmp[[session$token]]$data_batch_corrected) <<- sva::ComBat( + dat = assay(res_tmp[[session$token]]$data_batch_corrected), + batch = as.factor(colData(res_tmp[[session$token]]$data_batch_corrected)[,input$BatchEffect_Column]) + ) + }, error = function(e){ + error_modal( + e, additional_text = "Batch correction failed. Make sure the batch effect column is correct!" + ) + req(FALSE) + }) + } else if (input$BatchEffect_Column != "NULL" & input$PreProcessing_Procedure == "vst_DESeq"){ + tryCatch({ + res_tmp[[session$token]]$data_batch_corrected <<- deseq_processing( + data = tmp_data_selected, + omic_type = par_tmp[[session$token]]$omic_type, + formula_main = input$DESeq_formula_main, + formula_sub = c(input$DESeq_formula_sub, input$BatchEffect_Column), + session_token = session$token, + batch_correct = T + ) + }, error = function(e){ + error_modal( + e, additional_text = paste0( + "Batch correction using DESeq failed. Most likely due to linear dependencies ", + "in the design matrix (one or more factors informing about another one).", + "Make sure the batch effect column is correct and ", + "that the design matrix is not singular!" + ) + ) + req(FALSE) + }) + } else { + res_tmp[[session$token]]$data_batch_corrected <<- NULL + } # preprocessing print(paste0("Do chosen Preprocessing:",input$PreProcessing_Procedure)) @@ -841,7 +898,7 @@ server <- function(input,output,session){ formula_main = input$DESeq_formula_main, formula_sub = input$DESeq_formula_sub, session_token = session$token, - advanced_formula = ifelse(input$DESeq_show_advanced, input$DESeq_formula_advanced, "") + batch_correct = F ) } else { res_tmp[[session$token]]$data <<- preprocessing( @@ -849,6 +906,13 @@ server <- function(input,output,session){ omic_type = par_tmp[[session$token]]$omic_type, procedure = input$PreProcessing_Procedure ) + if (!is.null(res_tmp[[session$token]]$data_batch_corrected)) { + res_tmp[[session$token]]$data_batch_corrected <<- preprocessing( + data = res_tmp[[session$token]]$data_batch_corrected, + omic_type = par_tmp[[session$token]]$omic_type, + procedure = input$PreProcessing_Procedure + ) + } } }, error = function(e){ error_modal(e)