diff --git a/program/shinyApp/R/enrichment_analysis/ui.R b/program/shinyApp/R/enrichment_analysis/ui.R
index 01a47510..fb0e3095 100644
--- a/program/shinyApp/R/enrichment_analysis/ui.R
+++ b/program/shinyApp/R/enrichment_analysis/ui.R
@@ -79,6 +79,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/fun_getCodeSnippets.R b/program/shinyApp/R/fun_getCodeSnippets.R
index b6ebe759..aef4d9a7 100644
--- a/program/shinyApp/R/fun_getCodeSnippets.R
+++ b/program/shinyApp/R/fun_getCodeSnippets.R
@@ -62,10 +62,10 @@ selected <- unique(
if(PreProcessing_Procedure != "none"){
if(PreProcessing_Procedure == "filterOnly"){
if(omic_type == "Transcriptomics"){
- stringPreProcessing <- 'processedData <- tmp_data_selected[which(rowSums(assay(tmp_data_selected)) > 10),]'
+ stringPreProcessing <- 'res_tmp$data <- tmp_data_selected[which(rowSums(assay(tmp_data_selected)) > 10),]'
}
if(omic_type == "Metabolomics"){
- stringPreProcessing <- 'processedData <- tmp_data_selected[which(apply(assay(tmp_data_selected),1,median)!=0),]'
+ stringPreProcessing <- 'res_tmp$data <- tmp_data_selected[which(apply(assay(tmp_data_selected),1,median)!=0),]'
}
prequel_stringPreProcessing <- c("")
}else{
@@ -76,7 +76,6 @@ selected <- unique(
prequel_stringPreProcessing <- 'res_tmp$data <- tmp_data_selected[which(apply(assay(tmp_data_selected),1,median)!=0),]'
}
}
-
if(PreProcessing_Procedure == "simpleCenterScaling"){
stringPreProcessing <- 'processedData <- as.data.frame(t(
scale(
@@ -142,7 +141,32 @@ selected <- unique(
assay(res_tmp$data) <- as.data.frame(pareto.matrix)
'
}
- stringPreProcessing <- paste0(prequel_stringPreProcessing,"\n",stringPreProcessing)
+ if(par_tmp[[session$token]]['BatchColumn'] != "NULL" & PreProcessing_Procedure != "vst_DESeq"){
+ string_batchCorrection <- 'res_tmp$data_batch_corrected <- res_tmp$data
+ assay(res_tmp$data_batch_corrected) <- sva::ComBat(
+ dat = assay(res_tmp$data_batch_corrected),
+ batch = as.factor(colData(res_tmp$data_batch_corrected)[,par_tmp["BatchColumn"]])
+ )
+ '
+ # copy string to a new one and replace all orccurences of res_tmp$data with res_tmp$data_batch_corrected
+ stringPreProcessing_batch <- stringPreProcessing
+ stringPreProcessing_batch <- gsub("res_tmp$data","res_tmp$data_batch_corrected",stringPreProcessing_batch)
+ string_batchCorrection <- paste0(prequel_stringPreProcessing,"\n", string_batchCorrection)
+ } else if (par_tmp[[session$token]]['BatchColumn'] != "NULL" & PreProcessing_Procedure == "vst_DESeq") {
+ stringPreProcessing_batch <- stringPreProcessing
+ stringPreProcessing_batch <- gsub("res_tmp$data","res_tmp$data_batch_corrected",stringPreProcessing_batch)
+ stringPreProcessing_batch <- gsub("par_tmp$DESeq_formula","par_tmp$DESeq_formula_batch",stringPreProcessing_batch)
+ string_batchCorrection <- paste0(prequel_stringPreProcessing,"\n", string_batchCorrection)
+ } else {
+ string_batchCorrection <- ''
+ }
+ stringPreProcessing <- paste0(prequel_stringPreProcessing,"\n", string_batchCorrection, "\n", stringPreProcessing)
+ if (par_tmp[[session$token]]['BatchColumn'] != "NULL") {
+ stringPreProcessing <- paste0(
+ stringPreProcessing, "\n",
+ "# uncomment this line to use batch corrected data\n# res_tmp$data <- res_tmp$data_batch_corrected\n"
+ )
+ }
}else{
stringPreProcessing <- ''
}
diff --git a/program/shinyApp/R/heatmap/server.R b/program/shinyApp/R/heatmap/server.R
index 5139443c..7b39a489 100644
--- a/program/shinyApp/R/heatmap/server.R
+++ b/program/shinyApp/R/heatmap/server.R
@@ -65,7 +65,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())
@@ -218,6 +227,7 @@ heatmap_server <- function(id, data, params, updates){
)
req(selectedData_processed())
# update the data
+ useBatch <- ifelse(par_tmp[[session$token]]$BatchColumn != "NULL" && 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
@@ -235,8 +245,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()
@@ -325,6 +338,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 1695cc14..1c78409a 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 6555f3bc..6bead523 100644
--- a/program/shinyApp/R/pca/server.R
+++ b/program/shinyApp/R/pca/server.R
@@ -22,6 +22,15 @@ pca_Server <- function(id, data, params, row_select){
ns <- session$ns
file_path <- paste0("/www/",session$token,"/")
## 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",
@@ -137,9 +146,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(par_tmp[[session$token]]$BatchColumn != "NULL" && input$UseBatch == "Yes",T,F)
), "PCA")
if (check == "No Result yet"){
output$PCA_Info <- renderText("PCA computed.")
@@ -177,22 +186,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(par_tmp[[session$token]]$BatchColumn != "NULL" && 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
)
@@ -207,7 +223,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"){
@@ -239,8 +255,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]))
)
}
}
@@ -266,8 +282,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
@@ -293,8 +309,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
@@ -313,8 +329,8 @@ pca_Server <- function(id, data, params, row_select){
## TODO I think this can be removed
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 932b36fc..a3b9aed0 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 b5e27653..b49498be 100644
--- a/program/shinyApp/R/pre_processing/ui.R
+++ b/program/shinyApp/R/pre_processing/ui.R
@@ -15,6 +15,7 @@ pre_processing_sidebar_panel <- sidebarPanel(
) %>% helper(type = "markdown", content = "PreProcessing_Procedures"),
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..09814f42 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
@@ -114,7 +114,6 @@ deseq_processing <- function(
par_tmp[[session_token]][["DESeq_factors"]] <<- c(formula_main)
}
print(design_formula)
- par_tmp[[session_token]]["DESeq_formula"] <<- design_formula
# on purpose local
print(colData(data)[,formula_main])
@@ -125,14 +124,19 @@ 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
+ par_tmp[[session_token]]["DESeq_formula"] <<- design_formula
+ } else {
+ res_tmp[[session_token]]$DESeq_obj <<- de_seq_result
+ par_tmp[[session_token]]["DESeq_formula_batch"] <<- design_formula
+ }
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 5f868e1b..ac169ed0 100644
--- a/program/shinyApp/R/sample_correlation/server.R
+++ b/program/shinyApp/R/sample_correlation/server.R
@@ -4,8 +4,7 @@ sample_correlation_server <- function(id, data, params){
function(input,output,session){
sample_corr_reactive <- reactiveValues(
calculate = 0,
- counter = 0,
- SampleCorrelationPlot_final = NULL
+ counter = 0
)
session$userData$clicks_observer <- observeEvent(input$Do_SampleCorrelation,{
req(input$Do_SampleCorrelation > sample_corr_reactive$counter)
@@ -14,8 +13,16 @@ sample_correlation_server <- function(id, data, params){
})
ns <- session$ns
- file_path <- paste0("/www/",session$token,"/")
# 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(
@@ -39,18 +46,24 @@ sample_correlation_server <- function(id, data, params){
req(input$Do_SampleCorrelation > 0)
# update the data if needed
data <- update_data(session$token)
+ useBatch <- ifelse(par_tmp[[session$token]]$BatchColumn != "NULL" && input$UseBatch == "Yes",T,F)
+ 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)),
+ rows = length(rownames(data)),
+ cols = length(colnames(data)),
preprocessing = par_tmp[[session$token]]$PreProcessing_Procedure
)
),
@@ -63,30 +76,26 @@ sample_correlation_server <- function(id, data, params){
"Correlation Matrix successfully computed."
)
if(input$corrMethod == "kendall"){
- cormat <- pcaPP::cor.fk(x = as.matrix(assay(data$data)))
+ cormat <- pcaPP::cor.fk(x = as.matrix(assay(data)))
} else {
cormat <- cor(
- x = as.matrix(assay(data$data)),
+ x = as.matrix(assay(data)),
method = input$corrMethod
)
}
} else if (check == "Result exists"){
output$SampleCorr_Info <- renderText(
- "Correlation Matrix was already computed, reusing."
+ "Correlation Matrix was already computed, no need to click the Button again."
)
cormat <- res_tmp[[session$token]]$SampleCorrelation
} else if (check == "Overwrite"){
output$SampleCorr_Info <- renderText(
"Correlation Matrix result overwritten with different parameters."
)
- if(input$corrMethod == "kendall"){
- cormat <- pcaPP::cor.fk(x = as.matrix(assay(data$data)))
- } else {
- cormat <- cor(
- x = as.matrix(assay(data$data)),
- method = input$corrMethod
- )
- }
+ cormat <- cor(
+ x = as.matrix(assay(data)),
+ method = input$corrMethod
+ )
}
}, error = function(e){
error_modal(e)
@@ -104,7 +113,7 @@ sample_correlation_server <- function(id, data, params){
)
anno_colors <- assign_colors_SampleCorr(annotationDF)
- sample_corr_reactive$SampleCorrelationPlot_final <- pheatmap(
+ SampleCorrelationPlot_final <- pheatmap(
mat = cormat,
annotation_row = as.data.frame(annotationDF),
main = customTitleSampleCorrelation,
@@ -116,15 +125,14 @@ 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)),
+ rows = length(rownames(data)),
+ cols = length(colnames(data)),
preprocessing = par_tmp[[session$token]]$PreProcessing_Procedure
)
)
sampleCorrelation_scenario <- 18
- output$SampleCorrelationPlot <- renderPlot({sample_corr_reactive$SampleCorrelationPlot_final})
-
+ output$SampleCorrelationPlot <- renderPlot({SampleCorrelationPlot_final})
# Longer names causes issues for saving
if(nchar(customTitleSampleCorrelation) >= 250){
@@ -170,15 +178,15 @@ sample_correlation_server <- function(id, data, params){
paste0(par_tmp[[session$token]][["SampleCorr"]]$customTitleSampleCorrelation, Sys.time(), input$file_ext_Heatmap)
},
content = function(file){
- save_pheatmap(sample_corr_reactive$SampleCorrelationPlot_final,filename = file,type=gsub("\\.","",input$file_ext_SampleCorrelation))
+ save_pheatmap(par_tmp[[session$token]][["SampleCorr"]]$SampleCorrelationPlot_final,filename = file,type=gsub("\\.","",input$file_ext_SampleCorrelation))
on.exit({
tmp_filename <- paste0(
getwd(),
- file_path,
+ "/www/",
paste0(par_tmp[[session$token]][["SampleCorr"]]$customTitleSampleCorrelation, Sys.time(), input$file_ext_SampleCorrelation)
)
save_pheatmap(
- sample_corr_reactive$SampleCorrelationPlot_final,
+ par_tmp[[session$token]][["SampleCorr"]]$SampleCorrelationPlot_final,
filename = tmp_filename,
type = gsub("\\.","",input$file_ext_SampleCorrelation)
)
@@ -197,11 +205,12 @@ sample_correlation_server <- function(id, data, params){
notificationID <- showNotification("Saving...",duration = 0)
tmp_filename <- paste0(
getwd(),
- file_path,
+ "/www/",
paste0(par_tmp[[session$token]][["SampleCorr"]]$customTitleSampleCorrelation, Sys.time(), ".png")
)
+
save_pheatmap(
- sample_corr_reactive$SampleCorrelationPlot_final,
+ par_tmp[[session$token]][["SampleCorr"]]$SampleCorrelationPlot_final,
filename = tmp_filename,
type = "png"
)
diff --git a/program/shinyApp/R/sample_correlation/ui.R b/program/shinyApp/R/sample_correlation/ui.R
index df75737f..508253f9 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 3a17a9d7..2c9e3230 100644
--- a/program/shinyApp/R/significance_analysis/server.R
+++ b/program/shinyApp/R/significance_analysis/server.R
@@ -14,7 +14,15 @@ significance_analysis_server <- function(id, data, params){
ns <- session$ns
file_path <- paste0("/www/",session$token,"/")
## 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)){
@@ -207,7 +215,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(par_tmp[[session$token]]$BatchColumn != "NULL" && 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)) {
@@ -219,7 +233,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))
@@ -230,7 +248,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.")
@@ -250,7 +272,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
@@ -268,11 +291,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({
@@ -282,7 +305,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){
@@ -353,7 +377,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{
@@ -679,7 +703,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 e2376bea..b1c15b70 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 4a527569..1a9eb3e8 100644
--- a/program/shinyApp/R/significance_analysis/util.R
+++ b/program/shinyApp/R/significance_analysis/util.R
@@ -732,7 +732,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
@@ -791,7 +791,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.")
@@ -835,7 +835,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 f4a35406..5010fa49 100644
--- a/program/shinyApp/R/single_gene_visualisation/server.R
+++ b/program/shinyApp/R/single_gene_visualisation/server.R
@@ -13,10 +13,14 @@ single_gene_visualisation_server <- function(id, data){
## Ui section ----
output$type_of_data_gene_ui <- renderUI({
req(data_input_shiny())
+ options <- c("raw","preprocessed")
+ if(par_tmp[[session$token]]$BatchColumn != "NULL"){
+ options <- c("raw","preprocessed","batch_corrected_preprocessed")
+ }
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 = options,
multiple = F ,
selected = "preprocessed"
)
@@ -122,7 +126,6 @@ single_gene_visualisation_server <- function(id, data){
GeneData$anno <- colData(data$data)[,input$accross_condition]
GeneDataFlag <- T
} else {
- print("different Gene")
GeneDataFlag <- F
}
@@ -136,7 +139,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 1ef24e42..a2eed020 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 d5dabb54..0cc9adc8 100644
--- a/program/shinyApp/server.R
+++ b/program/shinyApp/server.R
@@ -806,6 +806,23 @@ 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))
+ filtered_column_names <- column_names[sapply(column_names, function(col) {
+ length(unique(colData(res_tmp[[session$token]]$data_original)[[col]])) < nrow(colData(res_tmp[[session$token]]$data_original))
+ })]
+ if (input$PreProcessing_Procedure == "vst_DESeq") {
+ filtered_column_names <- filtered_column_names[!filtered_column_names %in% c(input$DESeq_formula_main, input$DESeq_formula_sub)]
+ }
+ selectInput(
+ inputId = "BatchEffect_Column",
+ label = "Select Batch Effect Column",
+ choices = c("NULL", filtered_column_names),
+ selected = "NULL"
+ )
+ })
output$DESeq_formula_main_ui <- renderUI({
req(data_input_shiny())
req(input$PreProcessing_Procedure == "vst_DESeq")
@@ -832,7 +849,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 ----
@@ -851,6 +868,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))
@@ -862,7 +922,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(
@@ -870,6 +930,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)
@@ -950,6 +1017,14 @@ server <- function(input,output,session){
ifelse(input$PreProcessing_Procedure=="vst_DESeq",paste0(input$PreProcessing_Procedure, "~",input$DESeq_formula_main),input$PreProcessing_Procedure)
)
)
+ if(input$BatchEffect_Column != "NULL"){
+ fun_LogIt(
+ message = paste0(
+ "**PreProcessing** - Batch Effect Correction: ",
+ input$BatchEffect_Column
+ )
+ )
+ }
fun_LogIt(
message = paste0(
"**PreProcessing** - The resulting dimensions are: ",
diff --git a/program/shinyApp/ui.R b/program/shinyApp/ui.R
index e37ea8fa..625a5e59 100644
--- a/program/shinyApp/ui.R
+++ b/program/shinyApp/ui.R
@@ -40,6 +40,7 @@ library(readxl)
library(ggvenn)
library(ComplexUpset)
library(gridExtra)
+library(sva)
library(pcaPP) # requires gfortran. Not sure how to install on server
library(reshape2)
# library(svglite)