From c9e90d15dd9457bfec7e6dad3b49eb24e150cd85 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Sun, 28 Jan 2024 18:50:16 +0100 Subject: [PATCH 01/13] tryCatch for Heatmaps --- program/shinyApp/R/heatmap/server.R | 113 +++++++++++++++------------- program/shinyApp/R/util.R | 13 ++++ 2 files changed, 75 insertions(+), 51 deletions(-) diff --git a/program/shinyApp/R/heatmap/server.R b/program/shinyApp/R/heatmap/server.R index 9582a897..7b2fbc77 100644 --- a/program/shinyApp/R/heatmap/server.R +++ b/program/shinyApp/R/heatmap/server.R @@ -3,9 +3,7 @@ heatmap_server <- function(id, data, params, updates){ id, function(input,output,session){ # Heatmap ---- - heatmap_reactives <- reactiveValues( - current_updates = 0, - ) + ## UI Section ---- ns <- session$ns observe({ @@ -219,9 +217,8 @@ heatmap_server <- function(id, data, params, updates){ input$row_label_options ) req(selectedData_processed()) - # update the data if needed + # update the data data <- update_data(session$token) - heatmap_reactives$current_updates <- updates() print("Heatmap on selected Data") # Value need to be setted in case there is nothing to plot to avoid crash scenario <- 0 @@ -303,18 +300,22 @@ heatmap_server <- function(id, data, params, updates){ print("No entitie selection") data2HandOver <- as.data.frame(assay(data$data)) }else{ - data2HandOver <- entitieSelection( - data$data, - type = input$row_selection_options, - additionalInput_row_anno = additionalInput_row_anno, - additionalInput_row_anno_factor = additionalInput_row_anno_factor, - additionalInput_sample_annotation_types = additionalInput_sample_annotation_types, - additionalInput_ctrl_idx = additionalInput_ctrl_idx, - additionalInput_cmp_idx = additionalInput_cmp_idx, - psig_threhsold = psig_threhsold, - TopK2Show = TopK2Show + # entitie selection is a custom function -> wrap it in a tryCatch + tryCatch({ + data2HandOver <- entitieSelection( + data$data, + type = input$row_selection_options, + additionalInput_row_anno = additionalInput_row_anno, + additionalInput_row_anno_factor = additionalInput_row_anno_factor, + additionalInput_sample_annotation_types = additionalInput_sample_annotation_types, + additionalInput_ctrl_idx = additionalInput_ctrl_idx, + additionalInput_cmp_idx = additionalInput_cmp_idx, + psig_threhsold = psig_threhsold, + TopK2Show = TopK2Show + ) + print(dim(data2HandOver)) + }, error = function(e){error_modal(e)} ) - print(dim(data2HandOver)) } doThis_flag <- T @@ -378,13 +379,15 @@ heatmap_server <- function(id, data, params, updates){ output$Options_selected_out_3 <- renderText("Choose another preprocessing, as there are negative values!") }else if(doThis_flag){ - #Takes user-specified choices from additional LFC Inputs - # put does not plot values but the LFC itself - Data2Plot <- getLFC( - data = as.data.frame(data2HandOver), - ctrl_samples_idx = ctrl_samples_idx, - comparison_samples_idx = comparison_samples_idx - ) + # getLFC is a custom function -> wrap it in a tryCatch + tryCatch({ + Data2Plot <- getLFC( + data = as.data.frame(data2HandOver), + ctrl_samples_idx = ctrl_samples_idx, + comparison_samples_idx = comparison_samples_idx + ) + }, error = function(e){error_modal(e)} + ) ## do pheatmap @@ -394,20 +397,22 @@ heatmap_server <- function(id, data, params, updates){ scenario <- 10 annotation_col <- as.data.frame(rowData(data2Plot)[rownames(Data2Plot),input$row_anno_options,drop=F]) - heatmap_plot <- pheatmap( - t(Data2Plot[,"LFC",drop=F]), - main = gsub("^Heatmap","Heatmap_LFC",customTitleHeatmap), - show_rownames = ifelse(nrow(Data2Plot)<=25,TRUE,FALSE), - show_colnames = TRUE, - cluster_cols = input$cluster_cols, - cluster_rows = FALSE, - scale=ifelse(input$rowWiseScaled,"row","none"), - annotation_col = annotation_col, - # annotation_colors = mycolors, - silent = F, - # breaks = myBreaks, - color = myColor_fill - ) + + # for safety measures wrap in tryCatch + tryCatch({ + heatmap_plot <- pheatmap( + t(Data2Plot[,"LFC",drop=F]), + main = gsub("^Heatmap","Heatmap_LFC",customTitleHeatmap), + show_rownames = ifelse(nrow(Data2Plot)<=25,TRUE,FALSE), + show_colnames = TRUE, + cluster_cols = input$cluster_cols, + cluster_rows = FALSE, + scale=ifelse(input$rowWiseScaled,"row","none"), + annotation_col = annotation_col, + silent = F, + color = myColor_fill + ) + }, error = function(e){error_modal(e)}) } }else if(doThis_flag){ if(any(is.na(data2HandOver))){ @@ -434,20 +439,24 @@ heatmap_server <- function(id, data, params, updates){ print(input$row_label_options) #row_label_options scenario <- 11 - heatmap_plot <- pheatmap( - as.matrix(data2HandOver), - main = customTitleHeatmap, - show_rownames = ifelse(nrow(data2HandOver)<=input$row_label_no,TRUE,FALSE), - labels_row = rowData(data$data)[rownames(data2HandOver),input$row_label_options], - show_colnames = TRUE, - cluster_cols = input$cluster_cols, - cluster_rows = clusterRowspossible, - scale=ifelse(input$rowWiseScaled,"row","none"), - annotation_col = annotation_col, - annotation_row = annotation_row, - annotation_colors = mycolors, - silent = F - ) + + # for safety measures wrap in tryCatch + tryCatch({ + heatmap_plot <- pheatmap( + as.matrix(data2HandOver), + main = customTitleHeatmap, + show_rownames = ifelse(nrow(data2HandOver)<=input$row_label_no,TRUE,FALSE), + labels_row = rowData(data$data)[rownames(data2HandOver),input$row_label_options], + show_colnames = TRUE, + cluster_cols = input$cluster_cols, + cluster_rows = clusterRowspossible, + scale=ifelse(input$rowWiseScaled,"row","none"), + annotation_col = annotation_col, + annotation_row = annotation_row, + annotation_colors = mycolors, + silent = F + ) + }, error = function(e){error_modal(e)}) } } else { print("Plotting saved result") @@ -457,6 +466,7 @@ heatmap_server <- function(id, data, params, updates){ annotation_col <- rowData(data2Plot)[,input$row_anno_options,drop=F] scenario <- 10 + # Plotting saved result -> no need to wrap in tryCatch heatmap_plot <- pheatmap( t(res_tmp[[session$token]]$Heatmap[,"LFC",drop=F]), main = gsub("^Heatmap","Heatmap_LFC",customTitleHeatmap), @@ -492,6 +502,7 @@ heatmap_server <- function(id, data, params, updates){ annotation_row <- as.data.frame(annotation_row) } scenario <- 11 + # Plotting saved result -> no need to wrap in tryCatch heatmap_plot <- pheatmap( as.matrix(res_tmp[[session$token]]$Heatmap), main = customTitleHeatmap, diff --git a/program/shinyApp/R/util.R b/program/shinyApp/R/util.R index e07705f5..00bbad6c 100644 --- a/program/shinyApp/R/util.R +++ b/program/shinyApp/R/util.R @@ -1,5 +1,18 @@ ### general utility functions will be defined here +# tryCatch modal dialog +error_modal <- function(e){ + 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." + )), + footer = modalButton("Close") + )) +} + update_data <- function(session_id){ # for stability reasons, data is ALWAYS pulled here From 3ef5a97e91ea3a4d788492431b1bd6aa283c8b35 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Sun, 28 Jan 2024 18:56:06 +0100 Subject: [PATCH 02/13] tryCatch for PCA --- program/shinyApp/R/pca/server.R | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/program/shinyApp/R/pca/server.R b/program/shinyApp/R/pca/server.R index 8ec16db9..12bda229 100644 --- a/program/shinyApp/R/pca/server.R +++ b/program/shinyApp/R/pca/server.R @@ -6,8 +6,6 @@ pca_Server <- function(id, data, params, row_select, updates){ pca_reactives <- reactiveValues( calculate = 0, counter = 0, - # ensures Do_PCA is clicked at least once after refresh - current_updates = 0, percentVar = NULL, pcaData = NULL, df_out_r = NULL, @@ -191,8 +189,7 @@ pca_Server <- function(id, data, params, row_select, updates){ print(customTitle) # only calculate PCA, Score and Loadings if the counter is >= 0 if(pca_reactives$calculate >= 0){ - # update the data if needed - # TODO check if the follwoing still needed as update is now done on 1st server level + # update the data data2plot <- update_data(session$token) # select the neccesary data if(input$data_selection_pca){ @@ -202,16 +199,17 @@ pca_Server <- function(id, data, params, row_select, updates){ input$SampleAnnotationTypes_pca ) } - pca_reactives$current_updates <- updates() # set the counter to -1 to prevent any further plotting pca_reactives$calculate <- -1 print("Calculate PCA") - # PCA - pca <- prcomp( - x = as.data.frame(t(as.data.frame(assay(data2plot$data)))), - center = T, - scale. = FALSE - ) + # PCA, for safety measures, wrap in tryCatch + tryCatch({ + pca <- prcomp( + x = as.data.frame(t(as.data.frame(assay(data2plot$data)))), + center = T, + scale. = FALSE + ) + }, error = function(e){error_modal(e)}) # how much variance is explained by each PC explVar <- pca$sdev^2/sum(pca$sdev^2) names(explVar) <- colnames(pca$x) @@ -281,7 +279,7 @@ pca_Server <- function(id, data, params, row_select, updates){ LoadingsDF$entitie <- factor(LoadingsDF$entitie,levels = rownames(LoadingsDF)) if(!is.null(input$EntitieAnno_Loadings)){ req(data_input_shiny()) - LoadingsDF$entitie=factor( + 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])) ) From f8bc5467b90ae5192c55e338e228fd4ae49cf411 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Sun, 28 Jan 2024 19:10:17 +0100 Subject: [PATCH 03/13] Added stop() function --- program/shinyApp/R/heatmap/server.R | 22 +++++--- program/shinyApp/R/pca/server.R | 5 +- .../shinyApp/R/sample_correlation/server.R | 50 +++++++++++-------- 3 files changed, 48 insertions(+), 29 deletions(-) diff --git a/program/shinyApp/R/heatmap/server.R b/program/shinyApp/R/heatmap/server.R index 7b2fbc77..ad41a491 100644 --- a/program/shinyApp/R/heatmap/server.R +++ b/program/shinyApp/R/heatmap/server.R @@ -314,8 +314,10 @@ heatmap_server <- function(id, data, params, updates){ TopK2Show = TopK2Show ) print(dim(data2HandOver)) - }, error = function(e){error_modal(e)} - ) + }, error = function(e){ + error_modal(e) + stop() + }) } doThis_flag <- T @@ -386,8 +388,10 @@ heatmap_server <- function(id, data, params, updates){ ctrl_samples_idx = ctrl_samples_idx, comparison_samples_idx = comparison_samples_idx ) - }, error = function(e){error_modal(e)} - ) + }, error = function(e){ + error_modal(e) + stop() + }) ## do pheatmap @@ -412,7 +416,10 @@ heatmap_server <- function(id, data, params, updates){ silent = F, color = myColor_fill ) - }, error = function(e){error_modal(e)}) + }, error = function(e){ + error_modal(e) + stop() + }) } }else if(doThis_flag){ if(any(is.na(data2HandOver))){ @@ -456,7 +463,10 @@ heatmap_server <- function(id, data, params, updates){ annotation_colors = mycolors, silent = F ) - }, error = function(e){error_modal(e)}) + }, error = function(e){ + error_modal(e) + stop() + }) } } else { print("Plotting saved result") diff --git a/program/shinyApp/R/pca/server.R b/program/shinyApp/R/pca/server.R index 12bda229..57714f80 100644 --- a/program/shinyApp/R/pca/server.R +++ b/program/shinyApp/R/pca/server.R @@ -209,7 +209,10 @@ pca_Server <- function(id, data, params, row_select, updates){ center = T, scale. = FALSE ) - }, error = function(e){error_modal(e)}) + }, error = function(e){ + error_modal(e) + stop() + }) # how much variance is explained by each PC explVar <- pca$sdev^2/sum(pca$sdev^2) names(explVar) <- colnames(pca$x) diff --git a/program/shinyApp/R/sample_correlation/server.R b/program/shinyApp/R/sample_correlation/server.R index b0d7e616..393dfc04 100644 --- a/program/shinyApp/R/sample_correlation/server.R +++ b/program/shinyApp/R/sample_correlation/server.R @@ -58,28 +58,34 @@ sample_correlation_server <- function(id, data, params, updates){ ), "SampleCorrelation" ) - if (check == "No Result yet"){ - output$SampleCorr_Info <- renderText( - "Correlation Matrix successfully computed." - ) - cormat <- cor( - x = as.matrix(assay(data$data)), - method = input$corrMethod - ) - } else if (check == "Result exists"){ - output$SampleCorr_Info <- renderText( - "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." - ) - cormat <- cor( - x = as.matrix(assay(data$data)), - method = input$corrMethod - ) - } + # for safety measures, wrap in tryCatch + tryCatch({ + if (check == "No Result yet"){ + output$SampleCorr_Info <- renderText( + "Correlation Matrix successfully computed." + ) + cormat <- cor( + x = as.matrix(assay(data$data)), + method = input$corrMethod + ) + } else if (check == "Result exists"){ + output$SampleCorr_Info <- renderText( + "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." + ) + cormat <- cor( + x = as.matrix(assay(data$data)), + method = input$corrMethod + ) + } + }, error = function(e){ + error_modal(e) + stop() + }) customTitleSampleCorrelation <- paste0( "Sample Correlation - ", From 50cf4c61f5413a67f5d9efc4043c42d8e01d70af Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Sun, 28 Jan 2024 19:23:37 +0100 Subject: [PATCH 04/13] Replaced stop() with return(NULL) --- program/shinyApp/R/heatmap/server.R | 8 ++++---- program/shinyApp/R/pca/server.R | 2 +- program/shinyApp/R/sample_correlation/server.R | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/program/shinyApp/R/heatmap/server.R b/program/shinyApp/R/heatmap/server.R index ad41a491..d88ee073 100644 --- a/program/shinyApp/R/heatmap/server.R +++ b/program/shinyApp/R/heatmap/server.R @@ -316,7 +316,7 @@ heatmap_server <- function(id, data, params, updates){ print(dim(data2HandOver)) }, error = function(e){ error_modal(e) - stop() + return(NULL) }) } @@ -390,7 +390,7 @@ heatmap_server <- function(id, data, params, updates){ ) }, error = function(e){ error_modal(e) - stop() + return(NULL) }) ## do pheatmap @@ -418,7 +418,7 @@ heatmap_server <- function(id, data, params, updates){ ) }, error = function(e){ error_modal(e) - stop() + return(NULL) }) } }else if(doThis_flag){ @@ -465,7 +465,7 @@ heatmap_server <- function(id, data, params, updates){ ) }, error = function(e){ error_modal(e) - stop() + return(NULL) }) } } else { diff --git a/program/shinyApp/R/pca/server.R b/program/shinyApp/R/pca/server.R index 57714f80..032532cf 100644 --- a/program/shinyApp/R/pca/server.R +++ b/program/shinyApp/R/pca/server.R @@ -211,7 +211,7 @@ pca_Server <- function(id, data, params, row_select, updates){ ) }, error = function(e){ error_modal(e) - stop() + return(NULL) }) # how much variance is explained by each PC explVar <- pca$sdev^2/sum(pca$sdev^2) diff --git a/program/shinyApp/R/sample_correlation/server.R b/program/shinyApp/R/sample_correlation/server.R index 393dfc04..7af8d4de 100644 --- a/program/shinyApp/R/sample_correlation/server.R +++ b/program/shinyApp/R/sample_correlation/server.R @@ -84,7 +84,7 @@ sample_correlation_server <- function(id, data, params, updates){ } }, error = function(e){ error_modal(e) - stop() + return(NULL) }) customTitleSampleCorrelation <- paste0( From b99662e6e64b6b63115f3ee9da0b202023a56957 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Sun, 28 Jan 2024 20:34:39 +0100 Subject: [PATCH 05/13] No additional tryCatch neccessary. Some cleanup, as updating did not work --- .../R/single_gene_visualisation/server.R | 24 ++----------------- 1 file changed, 2 insertions(+), 22 deletions(-) diff --git a/program/shinyApp/R/single_gene_visualisation/server.R b/program/shinyApp/R/single_gene_visualisation/server.R index 7a08f6f8..8efa35f0 100644 --- a/program/shinyApp/R/single_gene_visualisation/server.R +++ b/program/shinyApp/R/single_gene_visualisation/server.R @@ -2,13 +2,6 @@ single_gene_visualisation_server <- function(id, data, params, updates){ moduleServer( id, function(input,output,session){ - - single_Gene_vis <- reactiveValues( - calculate = 0, - counter = 0, - current_updates = 0 - ) - ns <- session$ns @@ -18,7 +11,6 @@ single_gene_visualisation_server <- function(id, data, params, updates){ print("Refresh UI Single Gene") data <- update_data(session$token) params <- update_params(session$token) - single_Gene_vis$current_updates <- updates() ## Ui section ---- output$type_of_data_gene_ui <- renderUI({ @@ -114,26 +106,14 @@ single_gene_visualisation_server <- function(id, data, params, updates){ input$chooseComparisons ) }) - - # - # session$userData$clicks_observer <- observeEvent(input$singleGeneGo,{ - # req(input$singleGeneGo > single_Gene_vis$counter) - # single_Gene_vis$counter <- input$singleGeneGo - # single_Gene_vis$calculate <- 1 - # }) # Visualize single Gene ---- observeEvent(toListen(),{ req(input$singleGeneGo>0) print(input$Select_Gene) - if(single_Gene_vis$calculate == 1){ - # update the data if needed - data <- update_data(session$token) - single_Gene_vis$current_updates <- updates() - # set the counter to 0 to prevent any further plotting - single_Gene_vis$calculate <- 0 - } + # update the data + data <- update_data(session$token) GeneDataFlag = F From 0612948cbe5817fc7be4c83eeaadff2b5c218ed2 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Sun, 28 Jan 2024 20:44:49 +0100 Subject: [PATCH 06/13] tryCatch around sig ana. --- .../shinyApp/R/significance_analysis/server.R | 33 ++++++++++++------- 1 file changed, 21 insertions(+), 12 deletions(-) diff --git a/program/shinyApp/R/significance_analysis/server.R b/program/shinyApp/R/significance_analysis/server.R index d88beafc..cc539e10 100644 --- a/program/shinyApp/R/significance_analysis/server.R +++ b/program/shinyApp/R/significance_analysis/server.R @@ -9,7 +9,6 @@ significance_analysis_server <- function(id, data, params, updates){ dds = NULL, scenario = 0, comparisons_for_plot = "all", - current_updates = 0, coldata = NULL ) ns <- session$ns @@ -182,7 +181,6 @@ significance_analysis_server <- function(id, data, params, updates){ observeEvent(input$refreshUI, { data <- update_data(session$token) params <- update_params(session$token) - sig_ana_reactive$current_updates <- updates() sig_ana_reactive$coldata <- colData(data$data) }) # Analysis initial info @@ -201,7 +199,6 @@ significance_analysis_server <- function(id, data, params, updates){ print("Start the Significance Analysis") # update the data if needed data <- update_data(session$token) - sig_ana_reactive$current_updates <- updates() sig_ana_reactive$coldata <- colData(data$data) # delete old panels if(!is.null(significance_tabs_to_delete)){ @@ -272,14 +269,22 @@ significance_analysis_server <- function(id, data, params, updates){ samples_selected <- colData(data$data)[index_comparisons,] # get the data data_selected <- as.matrix(assay(data$data))[,index_comparisons] - sig_results <<- significance_analysis( - df = as.data.frame(data_selected), - samples = as.data.frame(samples_selected), - contrasts = contrasts, - method = input$test_method, - correction = PADJUST_METHOD[[input$test_correction]], - contrast_level = input$sample_annotation_types_cmp - ) + # significance analysis saved the result in res_tmp. + # as it is a custom function, wrap in tryCatch + tryCatch({ + significance_analysis( + df = as.data.frame(data_selected), + samples = as.data.frame(samples_selected), + contrasts = contrasts, + method = input$test_method, + correction = PADJUST_METHOD[[input$test_correction]], + contrast_level = input$sample_annotation_types_cmp + ) + sig_results <- res_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]] + }, error = function(e){ + error_modal(e) + return(NULL) + }) } # for each result create a tabPanel for (i in 1:length(sig_results)) { @@ -317,6 +322,8 @@ significance_analysis_server <- function(id, data, params, updates){ input$sig_to_look_at, sig_ana_reactive$update_plot_post_ana > 0 ) + # assign significance_results again, for safety measures + sig_results <- res_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]] # assign scenario=20 for Venn Diagram and scenario=21 for UpSetR if(input$visualization_method == "Venn Diagram"){ sig_ana_reactive$scenario <- 20 @@ -483,7 +490,7 @@ significance_analysis_server <- function(id, data, params, updates){ }, content = function(file){ envList <- list( - sig_results = sig_results, + sig_results = res_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]], input = reactiveValuesToList(input), res2plot = sig_ana_reactive$results_for_plot ) @@ -525,6 +532,8 @@ significance_analysis_server <- function(id, data, params, updates){ observeEvent(input$only2Report_Sig,{ notificationID <- showNotification(ui = "Saving...",duration = 0) tmp_filename <- paste0(getwd(),"/www/", paste(id,Sys.time(),".png",sep="_")) + # assign sig_results again for safety + sig_results <- res_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]] png(tmp_filename) print(sig_ana_reactive$plot_last) dev.off() From 6d95c0b8297d35ec05d6e79167f18d98c8d05b7e Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Thu, 1 Feb 2024 14:59:04 +0100 Subject: [PATCH 07/13] UI cleanup. --- program/shinyApp/R/data_selection/ui.R | 17 +++++++---------- program/shinyApp/R/pre_processing/ui.R | 11 ++--------- 2 files changed, 9 insertions(+), 19 deletions(-) diff --git a/program/shinyApp/R/data_selection/ui.R b/program/shinyApp/R/data_selection/ui.R index 6e3e1439..f48a9182 100644 --- a/program/shinyApp/R/data_selection/ui.R +++ b/program/shinyApp/R/data_selection/ui.R @@ -13,7 +13,6 @@ data_selection_sidebar_panel <- sidebarPanel( uiOutput(outputId = "AddGeneSymbols_ui"), uiOutput(outputId = "AddGeneSymbols_organism_ui") ), - #uiOutput("AddGeneSymbols_organism_ui"), actionButton( inputId = "refresh1", label = "Do" @@ -29,7 +28,6 @@ data_selection_sidebar_panel <- sidebarPanel( uiOutput(outputId = "row_selection_ui"), uiOutput(outputId = "propensityChoiceUser_ui") ), - # Outlier Selection -> for fixed removal pre-processing needs to be redone! div( class = "SampleSelection", h4("Sample selection"), @@ -62,17 +60,17 @@ data_selection_main_panel <- mainPanel( NULL ), hr(style = "border-top: 2px solid #90DBF4;"), - a(id = "toggleAdvanced", + a( + id = "toggleAdvanced", "Data Upload via file input", style = "background-color: #90DBF4; color: black; padding: 7px 10px; " - ) %>% helper(type = "markdown", content = "DataSelection_DataUploadFileInput"), - shinyjs::hidden( - div( + ) %>% helper(type = "markdown", content = "DataSelection_DataUploadFileInput"), + shinyjs::hidden(div( id = "advanced", splitLayout( style = "border: 1px solid silver:", cellWidths = c("50%", "50%"), - uiOutput(outputId = "data_matrix1_ui"), # %>% helper(type = "markdown", content = "DataSelection_Matrix"), - uiOutput(outputId = "data_sample_anno1_ui"), # %>% helper(type = "markdown", content = "DataSelection_SampleAnno") + uiOutput(outputId = "data_matrix1_ui"), + uiOutput(outputId = "data_sample_anno1_ui"), ), splitLayout( style = "border: 1px solid silver:", cellWidths = c("50%", "50%"), @@ -81,8 +79,7 @@ data_selection_main_panel <- mainPanel( outputId = "data_preDone_ui" ) %>% helper(type = "markdown", content = "DataSelection_SummarizedExp") ) - ) - ), + )), hr(style = "border-top: 2px solid #90DBF4;"), uiOutput(outputId = "metadataInput_ui") %>% helper(type = "markdown", content = "DataSelection_MetaData"), hr(style = "border-top: 2px solid #90DBF4;"), diff --git a/program/shinyApp/R/pre_processing/ui.R b/program/shinyApp/R/pre_processing/ui.R index b86808c7..ce8a1df1 100644 --- a/program/shinyApp/R/pre_processing/ui.R +++ b/program/shinyApp/R/pre_processing/ui.R @@ -36,16 +36,9 @@ pre_processing_main_panel <- mainPanel( id = "mainpanel_pre_processing", # Statistics to the data helpText("general statistics to the input data, stuff like dimensions"), - # hidden(div(id = 'Spinner_Statisitcs_Data', plotOutput("Statisitcs_Data")%>% withSpinner(type=8))), htmlOutput(outputId = "Statisitcs_Data") %>% withSpinner(type = 8), HTML(text = "
"), - HTML(text = "
"), - splitLayout( - cellWidths = c("25%", "25%", "25%"), - # uiOutput(outputId = "NextPanel2_ui"), - # uiOutput(outputId = "NextPanel3_ui"), - # uiOutput(outputId = "NextPanel4_ui") - ) + HTML(text = "
") ) @@ -53,7 +46,7 @@ pre_processing_panel <- tabPanel( title = "Pre-processing", id = "pre_processing_panel", fluid = T, - h4("Data Pre-processing"), # %>% helper(type = "markdown", content = "PreProcessing_help"), + h4("Data Pre-processing"), pre_processing_sidebar_panel, pre_processing_main_panel ) \ No newline at end of file From 7dfec168433fc252301e597a3fe280a6256d27d1 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Thu, 1 Feb 2024 14:59:44 +0100 Subject: [PATCH 08/13] Removed unused security --- program/shinyApp/ui.R | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/program/shinyApp/ui.R b/program/shinyApp/ui.R index 40dc68d6..967a5fae 100644 --- a/program/shinyApp/ui.R +++ b/program/shinyApp/ui.R @@ -59,19 +59,6 @@ source("R/significance_analysis/ui.R",local=T) options(repos = BiocManager::repositories()) options(spinner.color = "#1c8a3b", spinner.color.background = "#ffffff", spinner.size = 2) -######## -# Set Up security -######## -credentials <- data.frame( - user = c("Clivia", "Lea"), # mandatory - password = c("Cii@31", "Lea"), # mandatory - # start = c("2019-04-15"), # optinal (all others) - # expire = c(NA, "2019-12-31"), - admin = c(FALSE, TRUE), - comment = "Log In to Run secret Shiny", - stringsAsFactors = FALSE -) - ui <- shiny::fluidPage( # JS to reset input values From f993d84a7a6ba54fee4a7a52ac435d3437745bd3 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Thu, 1 Feb 2024 15:03:25 +0100 Subject: [PATCH 09/13] removed assignment --- program/shinyApp/ui.R | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/program/shinyApp/ui.R b/program/shinyApp/ui.R index 967a5fae..617937d2 100644 --- a/program/shinyApp/ui.R +++ b/program/shinyApp/ui.R @@ -43,9 +43,7 @@ library(gridExtra) # library(svglite) source("R/C.R") - source("R/module_DownloadReport.R",local=T) - # source the uis for each panel here source("R/data_selection/ui.R",local=T) source("R/pre_processing/ui.R",local=T) @@ -56,7 +54,6 @@ source("R/enrichment_analysis/ui.R",local=T) source("R/sample_correlation/ui.R",local = T) source("R/significance_analysis/ui.R",local=T) - options(repos = BiocManager::repositories()) options(spinner.color = "#1c8a3b", spinner.color.background = "#ffffff", spinner.size = 2) @@ -71,7 +68,6 @@ ui <- shiny::fluidPage( ########## # Styling Setting ########## - # Note the wrapping of the string in HTML() tags$style(HTML(" body { background-color: #f8f7fa; @@ -180,24 +176,25 @@ ui <- shiny::fluidPage( ################################################################################ data_selection_panel, pre_processing_panel, - sample_correlation_panel <- sampleCorrelation_UI("sample_correlation"), - significance_analysis_panel <- significance_analysis_UI("SignificanceAnalysis"), - pca_panel <- pca_UI("PCA"), - heatmap_panel <- heatmap_UI("Heatmap"), - single_gene_visualisation_panel <- single_gene_visualisation_UI("single_gene_visualisation"), - enrichment_analysis_tab_panel <- enrichment_analysis_UI("EnrichmentAnalysis") + sampleCorrelation_UI("sample_correlation"), + significance_analysis_UI("SignificanceAnalysis"), + pca_UI("PCA"), + heatmap_UI("Heatmap"), + single_gene_visualisation_UI("single_gene_visualisation"), + enrichment_analysis_UI("EnrichmentAnalysis") ), hidden(selectInput( "element_02", - label = "LeasBirthday", - choices = c(0, 1,2), + label = "AuthorBirthdays", + choices = c(0, 1, 2), selected = if(format(as.POSIXct(Sys.time()), "%d-%m") == "22-11"){ - 1 - }else if(format(as.POSIXct(Sys.time()), "%d-%m") == "19-12"){ - 2 - }else{ - 0 - })), + 1 # Lea's Birthday + } else if (format(as.POSIXct(Sys.time()), "%d-%m") == "19-12"){ + 2 # Paul's Birthday + } else { + 0 # No Birthday + } + )), conditionalPanel( condition = "input.element_02 == 0", absolutePanel("Brought to you by Lea Seep & Paul Jonas Jost", @@ -229,8 +226,4 @@ ui <- shiny::fluidPage( textOutput("session_id"), bottom = 0, right = 10, fixed = TRUE ) - ) - -# Wrap your UI with secure_app -# ui <- secure_app(ui) From afdf3dc827d649ba1c0b12840f3a21a93cc0144c Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Thu, 1 Feb 2024 15:56:36 +0100 Subject: [PATCH 10/13] Made Jokes a global variable. Tidied up data inspection --- program/shinyApp/R/C.R | 4 + program/shinyApp/R/fun_LogIt.R | 2 +- program/shinyApp/server.R | 316 +++++++++++++++------------------ 3 files changed, 144 insertions(+), 178 deletions(-) diff --git a/program/shinyApp/R/C.R b/program/shinyApp/R/C.R index 60d72e4f..fe659fc3 100644 --- a/program/shinyApp/R/C.R +++ b/program/shinyApp/R/C.R @@ -3,6 +3,10 @@ FLAG_TEST_DATA_SELECTED <<- FALSE NOTES_PlACEHOLDER <<- "Notes you want to take alongside the Plot (will be saved in the report) \nYou may want to use markdown syntay for structering the notes " NOTES_HELP <<- "Notes: For structure reasons you should start with Heading Level 4 (hence #### My personal Title)" +# Jokes +JOKES <<- read.csv("joke-db.csv") +JOKES <<- JOKES[nchar(JOKES$Joke)>0 & nchar(JOKES$Joke)<180,] + # Test correction list PADJUST_METHOD <<- list( "None" = "none", diff --git a/program/shinyApp/R/fun_LogIt.R b/program/shinyApp/R/fun_LogIt.R index d6263f0c..ac0a63fc 100644 --- a/program/shinyApp/R/fun_LogIt.R +++ b/program/shinyApp/R/fun_LogIt.R @@ -5,7 +5,7 @@ fun_LogIt <- function( addPlot = F, tableSaved = F, Filename = NULL, - jokes = jokesDF + jokes = JOKES ){ # sophisticated "Where to place log file" # how to name it ? diff --git a/program/shinyApp/server.R b/program/shinyApp/server.R index 19b90836..6f337f50 100644 --- a/program/shinyApp/server.R +++ b/program/shinyApp/server.R @@ -14,21 +14,15 @@ server <- function(input,output,session){ options(shiny.maxRequestSize=20*(1024^2)) # request 20MB observeEvent(input$guide_cicerone_next,{ - # triggers but guide is deteached + # triggers but guide is detached if(input$guide_cicerone_next$highlighted == "mainPanel_DataSelection"){ print("Here will be now automatically data uploaded ") }else{ print("Mööp") } }) - -# Load external Data ---- - jokesDF <- read.csv("joke-db.csv") - jokesDF <- jokesDF[nchar(jokesDF$Joke)>0 & nchar(jokesDF$Joke)<180,] - print("Hello Shiny") - - #### Clean Up + #### Clean Up # create www folder if not present if(dir.exists("www")){ setwd("www") @@ -42,10 +36,9 @@ server <- function(input,output,session){ print("Removed old Report files for fresh start") setwd("..") } - observe_helpers() + # Guide ---- - observeEvent(input$guide, { print("Jip") guide$init()$start() @@ -54,12 +47,6 @@ server <- function(input,output,session){ # Download Report pdf ---- DownloadReport_server("DownloadTestModule") - # To allow Reconnection wiht lost Session, potential - # security issue + more than one user issues potentially ?! - # Thats why further security - # session$allowReconnect(TRUE) - # what if complete new start (should have button for this ?!) - # session$allowReconnect("force") # To test locally # Layout upon Start ---- hideTab(inputId = "tabsetPanel1", target = "Pre-processing") @@ -98,15 +85,15 @@ server <- function(input,output,session){ "Download report", download=NA, target="_blank" - ), + ), actionButton( inputId = "Done", label = "Done" - ), + ), modalButton('Cancel') ) - ) ) + ) }) observeEvent(input$Done,{ @@ -123,10 +110,11 @@ server <- function(input,output,session){ # Data Upload + checks ---- print("Data Upload") + ## Set reactiveVals ---- FLAG_TEST_DATA_SELECTED <- reactiveVal(FALSE) -## Ui Section ---- +## Ui Section ---- observeEvent(input$Reset,{ FLAG_TEST_DATA_SELECTED(FALSE) output$debug <- renderText("Reset successful") @@ -160,81 +148,67 @@ server <- function(input,output,session){ FLAG_TEST_DATA_SELECTED(TRUE) shinyjs::click("refresh1") }) + + shinyjs::onclick("toggleAdvanced", shinyjs::toggle(id = "advanced", anim = TRUE)) - shinyjs::onclick("toggleAdvanced", - shinyjs::toggle(id = "advanced", anim = TRUE)) - - output$data_matrix1_ui <- renderUI({ - shiny::fileInput( - inputId = "data_matrix1", - label = HTML('Upload data matrix
(rows entities, cols samples)
Download example data (Transcriptomics, human)'), - accept = c(".csv", ".xlsx"), - width = "80%") - }) - output$data_sample_anno1_ui <- renderUI({ - shiny::fileInput( - inputId = "data_sample_anno1", - label = HTML('Upload sample annotation
(rows must be samples)
Download example data'), - accept = c(".csv", ".xlsx"), - width = "80%") - }) - output$data_row_anno1_ui <- renderUI({ - shiny::fileInput( - inputId = "data_row_anno1", - label = HTML('Upload entities annotation matrix
(rows must be entities)
Download example data'), - accept = c(".csv", ".xlsx"), - width = "80%") - }) - output$data_preDone_ui <- renderUI({ - shiny::fileInput( - inputId = "data_preDone", - label = HTML('Load precompiled data
(saved in this procedure or type SummarizedExperiment)
Download example data'), - accept = ".RDS", - width = "80%" - ) - }) + output$data_matrix1_ui <- renderUI({shiny::fileInput( + inputId = "data_matrix1", + label = HTML('Upload data matrix
(rows entities, cols samples)
Download example data (Transcriptomics, human)'), + accept = c(".csv", ".xlsx"), + width = "80%" + ) }) + output$data_sample_anno1_ui <- renderUI({shiny::fileInput( + inputId = "data_sample_anno1", + label = HTML('Upload sample annotation
(rows must be samples)
Download example data'), + accept = c(".csv", ".xlsx"), + width = "80%" + )}) + output$data_row_anno1_ui <- renderUI({shiny::fileInput( + inputId = "data_row_anno1", + label = HTML('Upload entities annotation matrix
(rows must be entities)
Download example data'), + accept = c(".csv", ".xlsx"), + width = "80%" + )}) + output$data_preDone_ui <- renderUI({shiny::fileInput( + inputId = "data_preDone", + label = HTML('Load precompiled data
(saved in this procedure or type SummarizedExperiment)
Download example data'), + accept = ".RDS", + width = "80%" + )}) output$SaveInputAsList <- downloadHandler( filename = function() { - paste(input$omicType,"_only_precompiled", " ",Sys.time(),".RDS",sep = "")}, + paste0(input$omicType, "_only_precompiled", " ", Sys.time(), ".RDS") }, content = function(file){ # TODO Q: What to save here? only original enough? saveRDS( object = res_tmp[[session$token]]$data_original, file = file - ) + ) } ) - output$metadataInput_ui <- renderUI({ - shiny::fileInput( - inputId = "metadataInput", - label = HTML("Upload your Meta Data Sheet (currently replaces sample annotation)"), - accept = c(".xlsx"), - buttonLabel = list(icon("folder"),"Simply upload your Metadata Sheet!"), - width = "100%" - ) - }) + output$metadataInput_ui <- renderUI({shiny::fileInput( + inputId = "metadataInput", + label = HTML("Upload your Meta Data Sheet (currently replaces sample annotation)"), + accept = c(".xlsx"), + buttonLabel = list(icon("folder"),"Simply upload your Metadata Sheet!"), + width = "100%" + )}) observeEvent(input$omicType,{ + output$AddGeneSymbols_ui <- NULL + output$AddGeneSymbols_organism_ui <- NULL if(input$omicType == "Transcriptomics"){ - output$AddGeneSymbols_ui=renderUI({ - checkboxInput( - inputId = "AddGeneSymbols", - label = "Adding gene Annotation?", - value = F - ) - - }) - output$AddGeneSymbols_organism_ui <- renderUI({ - selectInput( - inputId = "AddGeneSymbols_organism", - label = "Which Organisms?", - choices = listDatasets(useEnsembl(biomart = "genes"))[,"description"], - selected = "Mouse genes (GRCm39)" - ) - }) - }else{ - output$AddGeneSymbols_ui = NULL - output$AddGeneSymbols_organism_ui = NULL + output$AddGeneSymbols_ui <- renderUI({checkboxInput( + inputId = "AddGeneSymbols", + label = "Adding gene Annotation?", + value = F + )}) + output$AddGeneSymbols_organism_ui <- renderUI({selectInput( + inputId = "AddGeneSymbols_organism", + label = "Which Organisms?", + choices = listDatasets(useEnsembl(biomart = "genes"))[,"description"], + selected = "Mouse genes (GRCm39)" + )}) } }) @@ -242,116 +216,104 @@ server <- function(input,output,session){ observeEvent(input$DoVisualDataInspection,{ if(isTruthy(input$data_preDone)){ - output$DataMatrix_VI_Info=renderText({ + output$DataMatrix_VI_Info <- renderText({ "Visual Inspection only for primary data, not for precompiled set possible!" - }) + }) req(F) } if(!(isTruthy(input$data_matrix1) & (isTruthy(input$data_sample_anno1)|isTruthy(input$metadataInput)) & isTruthy(input$data_row_anno1))){ - output$DataMatrix_VI_Info=renderText( + output$DataMatrix_VI_Info <- renderText( "The Upload has failed completely, or you haven't uploaded anything yet. Need to uploade all three matrices!" ) - }else{ + } else { flag_csv <- F tryCatch( expr = { - Matrix <- read_file(input$data_matrix1$datapath, check.names=T) - Matrix2 <- read_file(input$data_matrix1$datapath, check.names=F) - flag_csv <- T - }, - error = function(cond){ - print("Not a real csv file!") - } + Matrix <- read_file(input$data_matrix1$datapath, check.names=T) + Matrix2 <- read_file(input$data_matrix1$datapath, check.names=F) + flag_csv <- T + }, + error = function(){ + print("Not a real csv file!") + Matrix <- read.table(input$data_matrix1$datapath,check.names = T) + Matrix2 <- read.table(input$data_matrix1$datapath, check.names = F) + } ) - if(!flag_csv){ - Matrix <- read.table(input$data_matrix1$datapath,check.names = T) - Matrix2 <- read.table(input$data_matrix1$datapath, check.names = F) - }else{ - Matrix <- read_file(input$data_matrix1$datapath, check.names=T) - Matrix2 <- read_file(input$data_matrix1$datapath, check.names=F) + + output$DataMatrix_VI <- DT::renderDataTable({DT::datatable(data = Matrix)}) + output$DataMatrix_VI_INFO <- renderText({"Matrix:"}) + if(isTruthy(input$data_sample_anno1)){ + sample_table <- read_file(input$data_sample_anno1$datapath, check.names=T) + } else if(isTruthy(input$metadataInput)){ + sample_table <- fun_readInSampleTable(input$metadataInput$datapath) + } else { + sample_table <- data.frame() } - - output$DataMatrix_VI <- DT::renderDataTable({ - DT::datatable(data = Matrix) - }) - output$DataMatrix_VI_INFO <- renderText({"Matrix:"}) - if(isTruthy(input$data_sample_anno1)){ - sample_table <- read_file(input$data_sample_anno1$datapath, check.names=T) - }else if(isTruthy(input$metadataInput)){ - sample_table <- fun_readInSampleTable(input$metadataInput$datapath) - }else{ - sample_table <- data.frame() - } - - output$SampleMatrix_VI <- DT::renderDataTable({ - DT::datatable(data = sample_table) - }) - output$SampleMatrix_VI_INFO <- renderText({"Sample table:"}) - - annotation_rows <- read_file(input$data_row_anno1$datapath, check.names=T) - output$EntitieMatrix_VI <- DT::renderDataTable({ - DT::datatable(data = annotation_rows) - }) - output$EntitieMatrix_VI_INFO <- renderText({"Entitie table:"}) - - ## Do some checking - snippetYes <- "Yes" - snippetNo <- "No" - output$OverallChecks <- renderText({ - "Some overall Checks are running run...\n - Rownames of Matrix are the same as rownames of entitie table ...\n - Colnames of Matrix are same as rownames of sample table ... \n - Matrix has no na ...\n - Sample table no na ...\n - Entitie table no na ...\n - " - }) + output$SampleMatrix_VI <- DT::renderDataTable({DT::datatable(data = sample_table)}) + output$SampleMatrix_VI_INFO <- renderText({"Sample table:"}) + + annotation_rows <- read_file(input$data_row_anno1$datapath, check.names=T) + output$EntitieMatrix_VI <- DT::renderDataTable({ + DT::datatable(data = annotation_rows) + }) + output$EntitieMatrix_VI_INFO <- renderText({"Entitie table:"}) - check0 <- ifelse(flag_csv,snippetYes,snippetNo) - check1 <- ifelse(all(rownames(Matrix) == rownames(annotation_rows)),snippetYes,snippetNo) - check2 <- ifelse(all(colnames(Matrix) == rownames(sample_table)),snippetYes,snippetNo) - check3 <- ifelse(any(is.na(Matrix) == T),snippetNo,snippetYes) - check4 <- ifelse(any(is.na(sample_table) == T),snippetNo,snippetYes) - check5 <- ifelse(any(is.na(annotation_rows) == T),snippetNo,snippetYes) - check6 <- ifelse(all(colnames(Matrix2) == colnames(Matrix)),snippetYes,snippetNo) - - if(check5 == snippetNo){ - # Indicate columns with NA - colsWithNa <- numeric() - for(i in 1:ncol(annotation_rows)){ - if(any(is.na(annotation_rows[,i]) == T)){ - colsWithNa <- c(colsWithNa,i) - } - } - check5 <- paste0(snippetNo," Following columns are potentially problematic: ",paste0(colsWithNa, collapse = ", ")) - } - - if(check6 == snippetNo){ - # add help text - check6 <- paste0( - snippetNo, - "\n\t A syntactically valid name consists of letters, numbers and the dot or underline characters \n - and starts with a letter or the dot not followed by a number.\n - Therefore '12345' is invalid, 'ID_12345' is valid \n - Remember to change the Sample ID everywhere (Matrix & Sample Table") - } - output$OverallChecks <- renderText({ - paste0("Some overall Checks are running run ...\n - Data Matrix is a real csv (has ',' as separators:): ",check0,"\n - Most likely: You had a xlsx and exported to csv but your excel is in german - and / or you use ',' as separators for decimal positions. - Fix: change your decimal separator in Excel and re-export! - Rownames of Matrix are the same as rownames of entitie table ",check1,"\n - Colnames of Matrix are same as rownames of sample table ",check2," \n - Matrix has no na ",check3,"\n - Sample table no na ",check4,"\n - Entitie table no na ",check5,"\n - Sample IDs have valid names ", check6, "\n - ") - }) + ## Do some checking + snippetYes <- "Yes" + snippetNo <- "No" + + check0 <- ifelse(flag_csv,snippetYes,snippetNo) + check1 <- ifelse(all(rownames(Matrix) == rownames(annotation_rows)),snippetYes,snippetNo) + check2 <- ifelse(all(colnames(Matrix) == rownames(sample_table)),snippetYes,snippetNo) + check3 <- ifelse(any(is.na(Matrix) == T),snippetNo,snippetYes) + check4 <- ifelse(any(is.na(sample_table) == T),snippetNo,snippetYes) + check5 <- ifelse(any(is.na(annotation_rows) == T),snippetNo,snippetYes) + check6 <- ifelse(all(colnames(Matrix2) == colnames(Matrix)),snippetYes,snippetNo) + + if(check0 == snippetNo){ + # add help text + check0 <- paste0( + snippetNo, + "\n\tMost likely: You had a xlsx and exported to csv but your excel is in ", + "german\n\tand/or you use ',' as separators for decimal positions.\n\t", + "Fix: change your decimal separator in Excel and re-export!" + ) + } + if(check5 == snippetNo){ + # Indicate columns with NA + colsWithNa <- numeric() + for(i in 1:ncol(annotation_rows)){ + if(any(is.na(annotation_rows[,i]) == T)){ + colsWithNa <- c(colsWithNa,i) + } + } + check5 <- paste0(snippetNo,"\n\tFollowing columns are potentially problematic: ",paste0(colsWithNa, collapse = ", ")) + } + if(check6 == snippetNo){ + # add help text + check6 <- paste0( + snippetNo, + "\n\tA syntactically valid name consists of letters, numbers,\n\t", + "the dot or underline characters and starts with a letter.\n\t", + "Therefore '12345' is invalid, 'ID_12345' is valid.\n\t", + "Remember to change the Sample ID everywhere (Matrix & Sample Table" + ) + } + output$OverallChecks <- renderText({ + paste0( + "Some overall Checks have been run:\n", + "Data Matrix is a real csv (has ',' as separators:): ",check0,"\n", + "Rownames of Matrix are the same as rownames of entitie table ",check1,"\n", + "Colnames of Matrix are same as rownames of sample table ",check2," \n", + "Matrix has no na ",check3,"\n", + "Sample table no na ",check4,"\n", + "Entitie table no na ",check5,"\n", + "Sample IDs have valid names ", check6, "\n" + ) + }) } }) From 12075fd63aff4adcec9dd8fac47410a03056c648 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Thu, 1 Feb 2024 23:08:47 +0100 Subject: [PATCH 11/13] Moved preprocessing away. Made some if/else statments clearer. TODO: "addWarning" seems quite unintuitive right now --- program/shinyApp/R/SourceAll.R | 1 + program/shinyApp/R/data_selection/ui.R | 4 +- program/shinyApp/R/pre_processing/ui.R | 8 +- program/shinyApp/R/pre_processing/util.R | 129 +++++++++++++++++++++++ program/shinyApp/server.R | 4 +- 5 files changed, 135 insertions(+), 11 deletions(-) create mode 100644 program/shinyApp/R/pre_processing/util.R diff --git a/program/shinyApp/R/SourceAll.R b/program/shinyApp/R/SourceAll.R index b20c39b9..006aa4c7 100644 --- a/program/shinyApp/R/SourceAll.R +++ b/program/shinyApp/R/SourceAll.R @@ -21,3 +21,4 @@ source("R/sample_correlation/server.R", local = T) source("R/significance_analysis/server.R", local = T) source("R/significance_analysis/util.R", local = T) source("R/fun_getCurrentVersionFromChangeLog.R",local = T) +source("R/pre_processing/util.R",local = T) diff --git a/program/shinyApp/R/data_selection/ui.R b/program/shinyApp/R/data_selection/ui.R index f48a9182..4f90a7a2 100644 --- a/program/shinyApp/R/data_selection/ui.R +++ b/program/shinyApp/R/data_selection/ui.R @@ -1,8 +1,8 @@ data_selection_sidebar_panel <- sidebarPanel( id = "sidebar_data_selection", - div(class = "omicType", + div(class = "omic_type", selectInput( - inputId = "omicType", # RNAorLIPID + inputId = "omic_type", # RNAorLIPID label = "Omic Type that is uploaded", choices = c("Transcriptomics", "Lipidomics", "Metabolomics"), selected = "" diff --git a/program/shinyApp/R/pre_processing/ui.R b/program/shinyApp/R/pre_processing/ui.R index ce8a1df1..e87c3f24 100644 --- a/program/shinyApp/R/pre_processing/ui.R +++ b/program/shinyApp/R/pre_processing/ui.R @@ -15,13 +15,7 @@ pre_processing_sidebar_panel <- sidebarPanel( ) %>% 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"), - switchInput( - inputId = "DESeq_show_advanced", - label = "Advanced formula options for DESeq2", - inline = T, - size = "mini", - value = F - ), + uiOutput(outputId = "DESeq_show_advanced_ui"), uiOutput(outputId = "DESeq_formula_advanced_ui"), actionButton( inputId = "Do_preprocessing", diff --git a/program/shinyApp/R/pre_processing/util.R b/program/shinyApp/R/pre_processing/util.R new file mode 100644 index 00000000..785e444d --- /dev/null +++ b/program/shinyApp/R/pre_processing/util.R @@ -0,0 +1,129 @@ +# preprocessing procedures + +prefiltering <- function(data, omic_type){ + # Filter out low abundant genes for Metabol- and Transcriptmics. + if(omic_type == "Transcriptomics"){ + print("Remove anything of rowCount <=10") + return(data[which(rowSums(assay(data)) > 10),]) + } + if(omic_type == "Metabolomics"){ + print("Remove anything which has a row median of 0") + return(data[which(apply(assay(data),1,median)!=0),]) + } +} + + +simple_center_scaling <- function(data, omic_type){ + # Center and scale the data + print("Do chosen Preprocessing: simpleCenterScaling") + # prefilter the data + data <- prefiltering(data, omic_type) + # center and scale the data + processedData <- as.data.frame(t(scale( + x = as.data.frame(t(as.data.frame(assay(data)))), + scale = T, + center = T + ))) + assay(data) <- processedData + return(data) +} + + +scaling_normalisation <- function(data, omic_type, scaling_procedure){ + # Center and scale the data + print(paste0("Do chosen Preprocessing: ", scaling_procedure)) + # prefilter the data + data <- prefiltering(data, omic_type) + # scaling functions + fun_scale <- function(x){ + return((x-min(x))/(max(x)-min(x))) + } + fun_pareto <- function(x){ + return((x-mean(x))/sqrt(var(x))) + } + scaling_function <- ifelse(scaling_procedure == "Scaling_0_1", fun_scale, fun_pareto) + processedData <- as.data.frame(t(apply( + X = assay(data), + MARGIN = 1, + FUN = scaling_function + ))) + assay(data) <- processedData + return(data) +} + + +ln_normalisation <- function(data, omic_type, logarithm_procedure){ + # Center and scale the data + print(paste0("Do chosen Preprocessing: ", logarithm_procedure)) + logarithm <- ifelse(logarithm_procedure == "log10", log10, log) + # prefilter the data + data <- prefiltering(data, omic_type) + # log the data and always add 1 to avoid -Inf + processedData <- as.data.frame(logarithm(as.data.frame(assay(data)) + 1)) + assay(data) <- processedData + return(data) +} + + +deseq_processing <- function( + data, omic_type, formula_main, formula_sub, session_token, advanced_formula = NULL +){ + # Center and scale the data + print("Do chosen Preprocessing: vst_DESeq") + # prefilter the data + data <- prefiltering(data, omic_type) + # DESeq2 + par_tmp[[session_token]]["DESeq_advanced"] <<- FALSE + if(omic_type == "Transcriptomics"){ + design_formula <- paste("~", formula_main) + # only do this locally + colData(data)[,formula_main] <- as.factor( + colData(data)[,formula_main] + ) + if(length(formula_sub) > 0){ + design_formula <- paste( + design_formula, " + ", + paste(formula_sub, collapse = " + ") + ) + # turn each factor into a factor + for(i in formula_sub){ + colData(data)[,i] <- as.factor( + colData(data)[,i] + ) + } + par_tmp[[session_token]][["DESeq_factors"]] <<- c( + formula_main,formula_sub + ) + } + else{ + par_tmp[[session_token]][["DESeq_factors"]] <<- c(formula_main) + } + # if advanced formula is used, overwrite the other formula + if(!(advanced_formula == "") & startsWith(advanced_formula, "~")){ + print("Advanced formula used") + design_formula <- advanced_formula + par_tmp[[session_token]]["DESeq_advanced"] <<- TRUE + } + print(design_formula) + par_tmp[[session_token]]["DESeq_formula"] <<- design_formula + # on purpose local + print(colData(data)[,formula_main]) + + dds <- DESeq2::DESeqDataSetFromMatrix( + countData = assay(data), + colData = colData(data), + design = as.formula(design_formula) + ) + + de_seq_result <- DESeq2::DESeq(dds) + 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/server.R b/program/shinyApp/server.R index 6f337f50..427351c0 100644 --- a/program/shinyApp/server.R +++ b/program/shinyApp/server.R @@ -177,7 +177,7 @@ server <- function(input,output,session){ )}) output$SaveInputAsList <- downloadHandler( filename = function() { - paste0(input$omicType, "_only_precompiled", " ", Sys.time(), ".RDS") }, + paste0(input$omic_type, "_only_precompiled", " ", Sys.time(), ".RDS") }, content = function(file){ # TODO Q: What to save here? only original enough? saveRDS( @@ -194,7 +194,7 @@ server <- function(input,output,session){ width = "100%" )}) - observeEvent(input$omicType,{ + observeEvent(input$omic_type,{ output$AddGeneSymbols_ui <- NULL output$AddGeneSymbols_organism_ui <- NULL if(input$omicType == "Transcriptomics"){ From 13f481dc1fbc77a4e63e35c81a3a7e6e5ae23b39 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Wed, 14 Feb 2024 16:54:15 +0100 Subject: [PATCH 12/13] Added tryExcept for preprocessing. --- program/shinyApp/R/pre_processing/util.R | 24 +- program/shinyApp/server.R | 612 ++++++++--------------- 2 files changed, 231 insertions(+), 405 deletions(-) diff --git a/program/shinyApp/R/pre_processing/util.R b/program/shinyApp/R/pre_processing/util.R index 785e444d..d47eebd5 100644 --- a/program/shinyApp/R/pre_processing/util.R +++ b/program/shinyApp/R/pre_processing/util.R @@ -1,5 +1,25 @@ # preprocessing procedures +preprocessing <- function(data, omic_type, procedure){ + if(procedure == "filterOnly"){ + return(prefiltering(data, omic_type)) + } + if(procedure == "simpleCenterScaling"){ + return(simple_center_scaling(data, omic_type)) + } + if(procedure %in% c("Scaling_0_1", "pareto_scaling")){ + return(scaling_normalisation(data, omic_type, procedure)) + } + if(procedure %in% c("log10", "ln")){ + return(ln_normalisation(data, omic_type, procedure)) + } + if(procedure == "none"){ + return(data) + } + # if nothing is chosen, raise an error + stop("No valid Preprocessing procedure chosen") +} + prefiltering <- function(data, omic_type){ # Filter out low abundant genes for Metabol- and Transcriptmics. if(omic_type == "Transcriptomics"){ @@ -15,7 +35,6 @@ prefiltering <- function(data, omic_type){ simple_center_scaling <- function(data, omic_type){ # Center and scale the data - print("Do chosen Preprocessing: simpleCenterScaling") # prefilter the data data <- prefiltering(data, omic_type) # center and scale the data @@ -31,7 +50,6 @@ simple_center_scaling <- function(data, omic_type){ scaling_normalisation <- function(data, omic_type, scaling_procedure){ # Center and scale the data - print(paste0("Do chosen Preprocessing: ", scaling_procedure)) # prefilter the data data <- prefiltering(data, omic_type) # scaling functions @@ -54,7 +72,6 @@ scaling_normalisation <- function(data, omic_type, scaling_procedure){ ln_normalisation <- function(data, omic_type, logarithm_procedure){ # Center and scale the data - print(paste0("Do chosen Preprocessing: ", logarithm_procedure)) logarithm <- ifelse(logarithm_procedure == "log10", log10, log) # prefilter the data data <- prefiltering(data, omic_type) @@ -69,7 +86,6 @@ deseq_processing <- function( data, omic_type, formula_main, formula_sub, session_token, advanced_formula = NULL ){ # Center and scale the data - print("Do chosen Preprocessing: vst_DESeq") # prefilter the data data <- prefiltering(data, omic_type) # DESeq2 diff --git a/program/shinyApp/server.R b/program/shinyApp/server.R index 427351c0..6360b7cc 100644 --- a/program/shinyApp/server.R +++ b/program/shinyApp/server.R @@ -197,7 +197,7 @@ server <- function(input,output,session){ observeEvent(input$omic_type,{ output$AddGeneSymbols_ui <- NULL output$AddGeneSymbols_organism_ui <- NULL - if(input$omicType == "Transcriptomics"){ + if(input$omic_type == "Transcriptomics"){ output$AddGeneSymbols_ui <- renderUI({checkboxInput( inputId = "AddGeneSymbols", label = "Adding gene Annotation?", @@ -319,43 +319,47 @@ server <- function(input,output,session){ ## Do Upload ---- observeEvent(input$refresh1,{ - par_tmp[[session$token]]['omic_type'] <<- input$omicType + par_tmp[[session$token]]['omic_type'] <<- input$omic_type par_tmp[[session$token]]['organism'] <<- input$AddGeneSymbols_organism fun_LogIt(message = "## DataInput {.tabset .tabset-fade}") fun_LogIt(message = "### Info") fun_LogIt( message = paste0("**DataInput** - Uploaded Omic Type: ", par_tmp[[session$token]]['omic_type']) - ) + ) if(!(isTruthy(input$data_preDone) | FLAG_TEST_DATA_SELECTED() | (isTruthy(input$data_matrix1) & isTruthy(input$data_sample_anno1) & - isTruthy(input$data_row_anno1)))){ + isTruthy(input$data_row_anno1)) + )){ output$debug <- renderText("The Upload has failed, or you haven't uploaded anything yet") - }else if(FLAG_TEST_DATA_SELECTED() & !(isTruthy(input$data_preDone))){ + } else if (FLAG_TEST_DATA_SELECTED() & !(isTruthy(input$data_preDone))){ output$debug <- renderText({"The Test Data Set was used"}) - }else{ + } else { show_toast( title = paste0(par_tmp[[session$token]]['omic_type'],"Data Upload"), text = paste0(par_tmp[[session$token]]['omic_type'],"-data upload was successful"), position = "top", timer = 1500, timerProgressBar = T - ) + ) output$debug <- renderText({ "Upload successful" - }) + }) if(isTruthy(input$data_preDone)){ # precomplied set used - fun_LogIt( - message = paste0("**DataInput** - The used data was precompiled. Filename: \n\t",input$data_preDone$name) - ) - }else{ - fun_LogIt( - message = paste0("The following data was used: \n\t",input$data_matrix1$name,"\n\t",input$data_sample_anno1$name,"\n\t",input$data_row_anno1$name) - ) + fun_LogIt(message = paste0( + "**DataInput** - The used data was precompiled. Filename: \n\t", + input$data_preDone$name + )) + } else { + fun_LogIt(message = paste0( + "The following data was used: \n\t", + input$data_matrix1$name,"\n\t", + input$data_sample_anno1$name,"\n\t", + input$data_row_anno1$name + )) } - showTab(inputId = "tabsetPanel1", target = "Pre-processing") } }) @@ -364,23 +368,20 @@ server <- function(input,output,session){ data_input_shiny <- eventReactive(input$refresh1,{ # initialize empty data_input object data_input <- list() - if(isTruthy(input$data_preDone)){ # precompiled data upload - uploadedFile <- readRDS( - file = input$data_preDone$datapath - ) - if(any(names(uploadedFile)%in% input$omicType)){ + if(isTruthy(input$data_preDone)){ # precompiled data upload + uploadedFile <- readRDS(file = input$data_preDone$datapath) + if(any(names(uploadedFile) %in% input$omic_type)){ # This is a file precompiled before 14.March.2023 - data_input <- uploadedFile[[input$omicType]] - }else{ - data_input[[paste0(input$omicType,"_SumExp")]] <- uploadedFile + data_input <- uploadedFile[[input$omic_type]] + } else { + data_input[[paste0(input$omic_type,"_SumExp")]] <- uploadedFile } } else if(isTruthy(input$metadataInput)){ # Metadata upload tmp_sampleTable <- fun_readInSampleTable(input$metadataInput$datapath) test_data_upload <- function(){ - tryCatch( - { + tryCatch({ data_input <- list( - type = as.character(input$omicType), + type = as.character(input$omic_type), Matrix = read_file( input$data_matrix1$datapath, check.names=T )[,rownames(tmp_sampleTable)], @@ -389,20 +390,19 @@ server <- function(input,output,session){ ) return(data_input) }, - error=function(cond){ + error = function(){ print("Error! Names From SampleTable and Matrix do not fit") output$debug <- renderText({ "Your Sample Names from the Metadata Sheet and from your Matrix do not match!! Data cannot be loaded" - }) + }) reset('metadataInput') return(NULL) - } - ) + }) } data_input <- test_data_upload() - }else if(isTruthy(input$data_sample_anno1)){ # Try upload via file input + } else if(isTruthy(input$data_sample_anno1)){ # Try upload via file input data_input <- list( - type = as.character(input$omicType), + type = as.character(input$omic_type), Matrix = read_file(input$data_matrix1$datapath, check.names=T), sample_table = read_file(input$data_sample_anno1$datapath, check.names=T), annotation_rows = read_file(input$data_row_anno1$datapath, check.names=T) @@ -410,113 +410,94 @@ server <- function(input,output,session){ # check if only 1 col in anno row, # add dummy col to ensure R does not turn it into a vector if(ncol(data_input$annotation_rows) < 2){ - print("Added dummy column to annotation row") data_input$annotation_rows$origRownames <- rownames(data_input$annotation_rows) } } else if(FLAG_TEST_DATA_SELECTED()){ # Upload test data #TODO change test data to also not rely on 'Transcriptomics' data_input <- readRDS( file = "www/Transcriptomics_only_precompiled-LS.RDS" - )[[input$omicType]] - + )[[input$omic_type]] fun_LogIt( message = paste0("**DataInput** - Test Data set used") ) - } else { # Meaningfull error message as info + } else { # TODO: Meaningfull error message as info output$debug <- renderText({ - "Upload failed, please check your input." - }) + "Upload failed, please check your input." + }) return(NULL) } ### Added here gene annotation if asked for - if(input$AddGeneSymbols & - input$omicType == "Transcriptomics"){ + if(input$AddGeneSymbols & input$omic_type == "Transcriptomics"){ fun_LogIt( message = "**DataInput** - Gene Annotation (SYMBOL and gene type) was added" - ) + ) fun_LogIt( message = paste0("**DataInput** - chosen Organism: ",input$AddGeneSymbols_organism) - ) - print("Add gene annotation") - # - # if(input$AddGeneSymbols_organism == "hsapiens"){ - # ensembl <- readRDS("data/ENSEMBL_Human_05_07_22") - # }else{ - # ensembl <- readRDS("data/ENSEMBL_Mouse_05_07_22") - # } + ) + output$debug <- renderText({"Added gene annotation"}) datasets_avail <- listDatasets(useEnsembl(biomart = "genes")) - ensembl <- - useEnsembl(biomart ="ensembl", - dataset = datasets_avail[datasets_avail$description==input$AddGeneSymbols_organism,"dataset"] - ) - + ensembl <- useEnsembl( + biomart ="ensembl", + dataset = datasets_avail[datasets_avail$description==input$AddGeneSymbols_organism,"dataset"] + ) out <- getBM( attributes = c("ensembl_gene_id", "gene_biotype","external_gene_name"), values = rownames(data_input$annotation_rows), mart = ensembl - ) - + ) # Make user aware if potentially wrong organism used - out <- out[base::match(rownames(data_input$annotation_rows), out$ensembl_gene_id),] - if(all(is.na(out$ensembl_gene_id))){ # Most likely wrong organism used output$debug <- renderText({"You have most likely chosen the wrong organism! No annotation was added"}) - }else{ + } else { data_input$annotation_rows$gene_type <- out$gene_biotype data_input$annotation_rows$GeneName <- out$external_gene_name } - } if(!any(class(data_input) == "SummarizedExperiment") & !any(grepl('SumExp',names(data_input))) ){ ## Lets Make a SummarizedExperiment Object for reproducibility and further usage - data_input[[paste0(input$omicType,"_SumExp")]]= - SummarizedExperiment(assays = list(raw = data_input$Matrix), - rowData = data_input$annotation_rows[rownames(data_input$Matrix),,drop=F], - colData = data_input$sample_table - ) + data_input[[paste0(input$omic_type,"_SumExp")]] <- SummarizedExperiment( + assays = list(raw = data_input$Matrix), + rowData = data_input$annotation_rows[rownames(data_input$Matrix),,drop=F], + colData = data_input$sample_table + ) #TODO make the copy and tab show process dependent if we get here a results object or 'simple' rds } # TODO SumExp only needed hence more restructuring needed - res_tmp[[session$token]][['data_original']] <<- data_input[[paste0(input$omicType,"_SumExp")]] + res_tmp[[session$token]][['data_original']] <<- data_input[[paste0(input$omic_type,"_SumExp")]] # Make a copy, to leave original data untouched res_tmp[[session$token]][['data']] <<- res_tmp[[session$token]]$data_original # Count up updating updating$count <- updating$count + 1 - - print(paste0( - "(before) No. anno options sample_table: ",ncol(res_tmp[[session$token]]$data_original) - )) - colData(res_tmp[[session$token]]$data) <- - DataFrame(as.data.frame(colData(res_tmp[[session$token]]$data)) %>% - purrr::keep(~length(unique(.x)) != 1)) - print(paste0( - "(after) No. anno options sample_table: ",ncol(res_tmp[[session$token]]$data) - )) - + colData(res_tmp[[session$token]]$data) <- DataFrame( + as.data.frame(colData(res_tmp[[session$token]]$data)) %>% + purrr::keep(~length(unique(.x)) != 1) + ) print(paste0( - "(before) No. anno options annotation_rows: ",ncol(res_tmp[[session$token]]$data_original) + "Number. of anno options sample_table lost: ", + ncol(res_tmp[[session$token]]$data_original) - ncol(res_tmp[[session$token]]$data) )) - rowData(res_tmp[[session$token]]$data) <- - DataFrame(as.data.frame(rowData(res_tmp[[session$token]]$data)) %>% - purrr::keep(~length(unique(.x)) != 1)) + rowData(res_tmp[[session$token]]$data) <- DataFrame( + as.data.frame(rowData(res_tmp[[session$token]]$data)) %>% + purrr::keep(~length(unique(.x)) != 1) + ) print(paste0( - "(after) No. anno options annotation_rows: ",ncol(res_tmp[[session$token]]$data) + "Number. of anno options annotation_rows lost: ", + nrow(res_tmp[[session$token]]$data_original) - nrow(res_tmp[[session$token]]$data) )) fun_LogIt( - message = - "**DataInput** - All constant annotation entries for entities and samples are removed from the thin out the selection options!" - ) - fun_LogIt( - message = paste0("**DataInput** - The raw data dimensions are:", - paste0(dim(res_tmp[[session$token]]$data_original),collapse = ", ")) + message = "**DataInput** - All constant annotation entries for entities and samples are removed from the thin out the selection options!" ) + fun_LogIt(message = paste0( + "**DataInput** - The raw data dimensions are:", + paste0(dim(res_tmp[[session$token]]$data_original),collapse = ", ") + )) fun_LogIt(message = "### Publication Snippet") fun_LogIt(message = snippet_dataInput( @@ -535,20 +516,15 @@ server <- function(input,output,session){ req(data_input_shiny()) isTruthy(res_tmp[[session$token]]$data) # Row - output$providedRowAnnotationTypes_ui=renderUI({ - req(data_input_shiny()) - shinyWidgets::virtualSelectInput( - inputId = "providedRowAnnotationTypes", - label = "Which annotation type do you want to select on?", - choices = c(colnames(rowData(res_tmp[[session$token]]$data_original))), - multiple = F, - search = T, - showSelectedOptionsFirst = T - ) - }) - - output$row_selection_ui=renderUI({ - req(data_input_shiny()) + output$providedRowAnnotationTypes_ui <- renderUI({shinyWidgets::virtualSelectInput( + inputId = "providedRowAnnotationTypes", + label = "Which annotation type do you want to select on?", + choices = c(colnames(rowData(res_tmp[[session$token]]$data_original))), + multiple = F, + search = T, + showSelectedOptionsFirst = T + )}) + output$row_selection_ui <- renderUI({ req(input$providedRowAnnotationTypes) if(is.numeric( rowData(res_tmp[[session$token]]$data_original)[,input$providedRowAnnotationTypes]) @@ -560,7 +536,7 @@ server <- function(input,output,session){ selected = "all", multiple = T ) - }else{ + } else { shinyWidgets::virtualSelectInput( inputId = "row_selection", label = "Which entities to use? (Will be the union if multiple selected)", @@ -572,22 +548,16 @@ server <- function(input,output,session){ ) } }) - observeEvent(input$row_selection,{ + output$propensityChoiceUser_ui <- renderUI({ req(data_input_shiny()) - if(any(input$row_selection == "High Values+IQR")){ - output$propensityChoiceUser_ui=renderUI({ - numericInput(inputId = "propensityChoiceUser", - label = "Specifcy the propensity for variablity & Expr", - value = 0.85, - min = 0, - max = 1 - ) - }) - }else{ - output$propensityChoiceUser_ui <- renderUI({ - NULL - }) - } + req(any(input$row_selection == "High Values+IQR")) + numericInput( + inputId = "propensityChoiceUser", + label = "Specifcy the propensity for variablity & Expr", + value = 0.85, + min = 0, + max = 1 + ) }) # Column /Sample output$providedSampleAnnotationTypes_ui <- renderUI({ @@ -613,16 +583,12 @@ server <- function(input,output,session){ multiple = T ) }) - - output$NextPanel_ui <- renderUI({ - actionButton( - inputId = "NextPanel", - label = "Start the Journey", - width = "100%", - icon = icon("fas fa-angle-double-right") - ) - }) - + output$NextPanel_ui <- renderUI({actionButton( + inputId = "NextPanel", + label = "Start the Journey", + width = "100%", + icon = icon("fas fa-angle-double-right") + )}) }) ## Log Selection ---- @@ -630,50 +596,44 @@ server <- function(input,output,session){ # Do actual selection before logging print(selectedData()) # add row and col selection options - fun_LogIt("## Data Selection") - fun_LogIt( - message = "**DataSelection** - The following selection was conducted:" - ) + fun_LogIt(message = "## Data Selection") + fun_LogIt(message = "**DataSelection** - The following selection was conducted:") print(length(input$sample_selection)) - fun_LogIt( - message = paste0("**DataSelection** - Samples:\n\t DataSelection - based on: ", - input$providedSampleAnnotationTypes,": ", - paste(input$sample_selection,collapse = ", ")) - ) - fun_LogIt( - message = paste0("**DataSelection** - Entities:\n\t DataSelection - based on: ", - input$providedRowAnnotationTypes, - ": ",paste(input$row_selection,collapse = ", ")) - ) + fun_LogIt(message = paste0( + "**DataSelection** - Samples:\n\t DataSelection - based on: ", + input$providedSampleAnnotationTypes,": ", + paste(input$sample_selection,collapse = ", ") + )) + fun_LogIt(message = paste0( + "**DataSelection** - Entities:\n\t DataSelection - based on: ", + input$providedRowAnnotationTypes, + ": ",paste(input$row_selection,collapse = ", ") + )) if(!is.null(input$propensityChoiceUser) & length(input$row_selection)>1){ # also record IQR if this + other selection was selected - fun_LogIt( - message = paste0("**DataSelection** - IQR treshold: ", - input$propensityChoiceUser) - ) - + fun_LogIt(message = paste0( + "**DataSelection** - IQR treshold: ", + input$propensityChoiceUser + )) } showTab(inputId = "tabsetPanel1",target = "Pre-processing",select = T) - }) ## Do Selection ---- selectedData <- reactive({ shiny::req(input$row_selection, input$sample_selection) par_tmp[[session$token]][["row_selection"]] <<- input$row_selection - print("Alright do Row selection") selected <- c() if(any(input$row_selection == "all")){ selected <- rownames(rowData(res_tmp[[session$token]]$data_original)) - }else if(!(length(input$row_selection) == 1 & any(input$row_selection == "High Values+IQR"))){ - selected <- unique( - c(selected, - rownames(rowData(res_tmp[[session$token]]$data_original))[ - which(rowData(res_tmp[[session$token]]$data_original)[,input$providedRowAnnotationTypes]%in%input$row_selection) - ] - ) - ) + } else if(!(length(input$row_selection) == 1 & any(input$row_selection == "High Values+IQR"))){ + selected <- unique(c( + selected, + rownames(rowData(res_tmp[[session$token]]$data_original))[ + which(rowData(res_tmp[[session$token]]$data_original)[,input$providedRowAnnotationTypes]%in%input$row_selection) + ] + )) } if(any(input$row_selection == "High Values+IQR")){ if(length(input$row_selection) == 1){ @@ -683,16 +643,13 @@ server <- function(input,output,session){ ) filteredIQR_Expr <- assay(res_tmp[[session$token]]$data_original)[toKeep,] selected <- rownames(filteredIQR_Expr) - }else{ + } else { toKeep <- filter_rna( rna = assay(res_tmp[[session$token]]$data_original)[selected,], prop = input$propensityChoiceUser ) filteredIQR_Expr <- assay(res_tmp[[session$token]]$data_original)[toKeep,] - selected <- intersect( - selected, - rownames(filteredIQR_Expr) - ) + selected <- intersect(selected, rownames(filteredIQR_Expr)) } remove(filteredIQR_Expr) } @@ -709,9 +666,7 @@ server <- function(input,output,session){ )] ) } - # Data set selection - print("Alright do Column selection") res_tmp[[session$token]]$data <<- res_tmp[[session$token]]$data_original[selected,samples_selected] tmp_data_selected <<- res_tmp[[session$token]]$data_original[selected,samples_selected] return("Selection Success") @@ -723,68 +678,53 @@ server <- function(input,output,session){ ## UI section ---- output$DESeq_formula_main_ui <- renderUI({ req(data_input_shiny()) - if(input$PreProcessing_Procedure == "vst_DESeq"){ - selectInput( - inputId = "DESeq_formula_main", - label = paste0( - "Choose main factor for desing formula in DESeq pipeline ", - "(App might crash if your factor as only 1 sample per level)" - ), - choices = c(colnames(colData(tmp_data_selected))), - multiple = F, - selected = "condition" - ) - }else{ - NULL - } + req(input$PreProcessing_Procedure == "vst_DESeq") + selectInput( + inputId = "DESeq_formula_main", + label = paste0( + "Choose main factor for desing formula in DESeq pipeline ", + "(App might crash if your factor as only 1 sample per level)" + ), + choices = c(colnames(colData(tmp_data_selected))), + multiple = F, + selected = "condition" + ) }) output$DESeq_formula_sub_ui <- renderUI({ req(data_input_shiny()) - if(input$PreProcessing_Procedure == "vst_DESeq"){ - selectInput( - inputId = "DESeq_formula_sub", - label = paste0( - "Choose other factors to account for", - "(App might crash if your factor as only 1 sample per level)" - ), - choices = c(colnames(colData(tmp_data_selected))), - multiple = T, - selected = "condition" - ) - }else{ - NULL - } - }) - observe({ - if(input$DESeq_show_advanced){ - output$DESeq_formula_advanced_ui <- renderUI({ - req(data_input_shiny()) - textInput( - inputId = "DESeq_formula_advanced", - label = "Insert your formula:", - value = "", - width = NULL, - placeholder = NULL - ) - }) - } else { - # hide the advanced UI - hide("DESeq_formula_advanced", anim = T) - } + req(input$PreProcessing_Procedure == "vst_DESeq") + selectInput( + inputId = "DESeq_formula_sub", + label = paste0( + "Choose other factors to account for", + "(App might crash if your factor as only 1 sample per level)" + ), + choices = c(colnames(colData(tmp_data_selected))), + multiple = T, + selected = "condition" + ) }) - - observeEvent(input$NextPanel2,{ - updateTabsetPanel( - session = session, - inputId = "tabsetPanel1", - selected = "PCA") + output$DESeq_show_advanced_ui <- renderUI({ + req(data_input_shiny()) + req(input$PreProcessing_Procedure == "vst_DESeq") + switchInput( + inputId = "DESeq_show_advanced", + label = "Advanced formula options for DESeq2", + inline = T, + size = "mini", + value = F + ) }) - observeEvent(input$NextPanel3,{ - updateTabsetPanel( - session = session, - inputId = "tabsetPanel1", - selected = "Heatmap" - ) + output$DESeq_formula_advanced_ui <- renderUI({ + req(data_input_shiny()) + req(input$PreProcessing_Procedure == "vst_DESeq" & input$DESeq_show_advanced) + textInput( + inputId = "DESeq_formula_advanced", + label = "Insert your formula:", + value = "", + width = NULL, + placeholder = NULL + ) }) ## Do preprocessing ---- @@ -795,159 +735,47 @@ server <- function(input,output,session){ print(selectedData()) addWarning <- "" par_tmp[[session$token]]['PreProcessing_Procedure'] <<- input$PreProcessing_Procedure - processedData_all <- tmp_data_selected - # as general remove all genes which are constant over all rows - print("As general remove all entities which are constant over all samples") - res_tmp[[session$token]]$data <<- tmp_data_selected[rownames(tmp_data_selected[which(apply(assay(tmp_data_selected),1,sd) != 0),]),] - + print("Remove all entities which are constant over all samples") + res_tmp[[session$token]]$data <<- tmp_data_selected[rownames(tmp_data_selected[which(apply(assay(tmp_data_selected),1,sd) != 0),]),] print(dim(res_tmp[[session$token]]$data)) # 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),] - if(input$PreProcessing_Procedure != "none"){ - if(input$PreProcessing_Procedure == "filterOnly"){ - - if(par_tmp[[session$token]]$omic_type == "Transcriptomics"){ - print("Also remove anything of rowCount <=10") - print(dim(tmp_data_selected)) - res_tmp[[session$token]]$data <<- tmp_data_selected[which(rowSums(assay(tmp_data_selected)) > 10),] - } - - if(par_tmp[[session$token]]$omic_type == "Metabolomics"){ - print("Remove anything which has a row median of 0") - print(dim(tmp_data_selected)) - res_tmp[[session$token]]$data <<- tmp_data_selected[which(apply(assay(tmp_data_selected),1,median)!=0),] - } - addWarning <- "Only Filtering of low abundant is done only if Transcriptomics or Metabolomics was chosen\n" - }else{ - if(par_tmp[[session$token]]$omic_type == "Transcriptomics"){ - print("Also remove anything of rowCount <=10") - print(dim(tmp_data_selected)) - res_tmp[[session$token]]$data <<- tmp_data_selected[which(rowSums(assay(tmp_data_selected)) > 10),] - } - - if(par_tmp[[session$token]]$omic_type == "Metabolomics"){ - print("Remove anything which has a row median of 0") - print(dim(tmp_data_selected)) - - addWarning <- "Pre Filtering to remove low abundant entities done if Transcriptomics or Metabolomics was chosen\n" - } - } - - print(dim(res_tmp[[session$token]]$data)) - - print(paste0("Do chosen Preprocessing:",input$PreProcessing_Procedure)) - if(input$PreProcessing_Procedure == "simpleCenterScaling"){ - processedData <- as.data.frame(t( - scale( - x = as.data.frame(t(as.data.frame(assay(res_tmp[[session$token]]$data)))), - scale = T, - center = T - ) - ) - ) - assay(res_tmp[[session$token]]$data) <<- as.data.frame(processedData) - } + # preprocessing + print(paste0("Do chosen Preprocessing:",input$PreProcessing_Procedure)) + tryCatch({ if(input$PreProcessing_Procedure == "vst_DESeq"){ - par_tmp[[session$token]]["DESeq_advanced"] <<- FALSE - if(par_tmp[[session$token]]$omic_type == "Transcriptomics"){ - design_formula <- paste("~", input$DESeq_formula_main) - # only do this locally - colData(res_tmp[[session$token]]$data)[,input$DESeq_formula_main] <- as.factor( - colData(res_tmp[[session$token]]$data)[,input$DESeq_formula_main] + res_tmp[[session$token]]$data <<- deseq_processing( + data = tmp_data_selected, + omic_type = par_tmp[[session$token]]$omic_type, + 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, "") ) - if(length(input$DESeq_formula_sub) > 0){ - design_formula <- paste( - design_formula, " + ", - paste(input$DESeq_formula_sub, collapse = " + ") - ) - # turn each factor into a factor - for(i in input$DESeq_formula_sub){ - colData(res_tmp[[session$token]]$data)[,i] <- as.factor( - colData(res_tmp[[session$token]]$data)[,i] - ) - } - par_tmp[[session$token]][["DESeq_factors"]] <<- c( - input$DESeq_formula_main,input$DESeq_formula_sub - ) - } - else{ - par_tmp[[session$token]][["DESeq_factors"]] <<- c(input$DESeq_formula_main) - } - # if advanced formula is used, overwrite the other formula - if(input$DESeq_show_advanced){ - if(startsWith(input$DESeq_formula_advanced, "~")){ - print("Advanced formula used") - design_formula <- input$DESeq_formula_advanced - par_tmp[[session$token]]["DESeq_advanced"] <<- TRUE - } - } - print(design_formula) - par_tmp[[session$token]]["DESeq_formula"] <<- design_formula - # on purpose local - print(colData(res_tmp[[session$token]]$data)[,input$DESeq_formula_main]) - - dds <- DESeq2::DESeqDataSetFromMatrix( - countData = assay(res_tmp[[session$token]]$data), - colData = colData(res_tmp[[session$token]]$data), - design = as.formula(design_formula) - ) - - de_seq_result <- DESeq2::DESeq(dds) - res_tmp[[session$token]]$DESeq_obj <<- de_seq_result - dds_vst <- vst( - object = de_seq_result, - blind = TRUE - ) - assay(res_tmp[[session$token]]$data) <<- as.data.frame(assay(dds_vst)) - }else{ - addWarning <- "DESeq makes only sense for transcriptomics data - data treated as if 'none' was selected!" - } - } - if(input$PreProcessing_Procedure == "Scaling_0_1"){ - processedData <- as.data.frame(t( - apply(assay(res_tmp[[session$token]]$data),1,function(x){ - (x - min(x))/(max(x) - min(x)) - }) - )) - assay(res_tmp[[session$token]]$data) <<- as.data.frame(processedData) - } - if(input$PreProcessing_Procedure == "ln"){ - processedData <- as.data.frame(log( - as.data.frame(assay(res_tmp[[session$token]]$data)) - )) - assay(res_tmp[[session$token]]$data) <<- as.data.frame(processedData) - } - if(input$PreProcessing_Procedure == "log10"){ - processedData <- as.data.frame(assay(res_tmp[[session$token]]$data)) - if(any(processedData<0)){ - addWarning <- "Negative entries, cannot take log10!!" - } - if(any(processedData==0)){ - processedData <- as.data.frame(log10( - processedData + 1) - ) - } - processedData <- as.data.frame(log10( - processedData + 1) - ) - assay(res_tmp[[session$token]]$data) <<- as.data.frame(processedData) + } else { + res_tmp[[session$token]]$data <- preprocessing( + data = tmp_data_selected, + omic_type = par_tmp[[session$token]]$omic_type, + procedure = input$PreProcessing_Procedure + ) } - if(input$PreProcessing_Procedure == "pareto_scaling"){ - processedData <- as.data.frame(assay(res_tmp[[session$token]]$data)) - centered <- as.data.frame(t( - apply(processedData, 1, function(x){x - mean(x)}) - )) - pareto.matrix <- as.data.frame(t( - apply(centered, 1, function(x){x/sqrt(sd(x))}) - )) + }, error = function(e){ + error_modal(e) + req(FALSE) + }) - assay(res_tmp[[session$token]]$data) <<- as.data.frame(pareto.matrix) - } + if(input$PreProcessing_Procedure == "filterOnly"){ + addWarning <- "Only Filtering of low abundant is done only if Transcriptomics or Metabolomics was chosen
" + } else if(input$PreProcessing_Procedure == "none"){ + addWarning <- "No Pre-Processing done. Use on your own accord.
" + } else{ + addWarning <- "Pre Filtering to remove low abundant entities done if Transcriptomics or Metabolomics was chosen
" } + print(dim(res_tmp[[session$token]]$data)) if(any(is.na(assay(res_tmp[[session$token]]$data)))){ print("This might be problem due to mismatched Annotation Data?!") @@ -955,13 +783,12 @@ server <- function(input,output,session){ nrow_after <- nrow( res_tmp[[session$token]]$data[complete.cases(assay(res_tmp[[session$token]]$data)),] ) - addWarning <- paste0("There were NA's after pre-processing, any row containg such was completly removed! (before/after): ",nrow_before,"/",nrow_after,"") + addWarning <- paste0(addWarning, "There were NA's after pre-processing, any row containg such was completly removed! (before/after): ",nrow_before,"/",nrow_after,"
") if(!(nrow_after > 0)){ - addWarning <- paste0(addWarning, "
There is nothing left, choose different pre-processing other-wise App will crash!") + addWarning <- paste0(addWarning, "
There is nothing left, choose different pre-processing other-wise App will crash!
") } res_tmp[[session$token]]$data <<- res_tmp[[session$token]]$data[complete.cases(assay(res_tmp[[session$token]]$data)),] } - print(colnames(res_tmp[[session$token]]$data)) showTab(inputId = "tabsetPanel1", target = "Sample Correlation") @@ -975,58 +802,44 @@ server <- function(input,output,session){ updating$count <- updating$count + 1 output$Statisitcs_Data <- renderText({ - shinyjs::click("SignificanceAnalysis-refreshUI",asis = T) shinyjs::click("single_gene_visualisation-refreshUI",asis = T) shinyjs::click("EnrichmentAnalysis-refreshUI",asis = T) - paste0(addWarning, - "The data has the dimensions of: ", - paste0(dim(res_tmp[[session$token]]$data),collapse = ", "), - "
","Be aware that depending on omic-Type, basic pre-processing has been done anyway even when selecting none", - "",ifelse(any(as.data.frame(assay(res_tmp[[session$token]]$data)) < 0),"Be aware that processed data has negative values, hence no log fold changes can be calculated","")) + paste0( + addWarning, + "The data has the dimensions of: ", + paste0(dim(res_tmp[[session$token]]$data),collapse = ", "), + "
","Be aware that depending on omic-Type, basic pre-processing has been done anyway even when selecting none", + "",ifelse(any(as.data.frame(assay(res_tmp[[session$token]]$data)) < 0),"Be aware that processed data has negative values, hence no log fold changes can be calculated","")) }) - - return("Pre-Processing successfully") }) - ## DO not why this was moved here ? - - # output$Statisitcs_Data <- renderText({ - # browser() - # selectedData_processed() - # - # paste0("The data has the dimensions of: ", - # paste0(dim(res_tmp$data),collapse = ", "), - # "
","Be aware that depending on omic-Type, basic pre-processing has been done anyway even when selecting none", - # "",ifelse(any(as.data.frame(assay(res_tmp$data))<0),"Be aware that processed data has negative values, hence no log fold changes can be calculated","")) - # }) - - ## Log preprocessing ---- observeEvent(input$Do_preprocessing,{ print(selectedData_processed()) if(par_tmp[[session$token]]$omic_type == "Transcriptomics"){ tmp_logMessage <- "Remove anything which row Count <= 10" - }else if(par_tmp[[session$token]]$omic_type == "Metabolomics"){ + } else if (par_tmp[[session$token]]$omic_type == "Metabolomics"){ tmp_logMessage <- "Remove anything which has a row median of 0" - }else{ + } else { tmp_logMessage <- "none" } fun_LogIt("## Pre Processing") fun_LogIt( message = "**PreProcessing** - As general remove all entities which are constant over all samples (automatically)" - ) + ) fun_LogIt( message = paste0("**PreProcessing** - Preprocessing procedure -standard (depending only on omics-type): ",tmp_logMessage) - ) + ) fun_LogIt( - message = paste0("**PreProcessing** - Preprocessing procedure -specific (user-chosen): ",ifelse(input$PreProcessing_Procedure=="vst_DESeq",paste0(input$PreProcessing_Procedure, "~",input$DESeq_formula_main),input$PreProcessing_Procedure)) + message = paste0( + "**PreProcessing** - Preprocessing procedure -specific (user-chosen): ", + ifelse(input$PreProcessing_Procedure=="vst_DESeq",paste0(input$PreProcessing_Procedure, "~",input$DESeq_formula_main),input$PreProcessing_Procedure) ) + ) fun_LogIt( message = paste0( "**PreProcessing** - The resulting dimensions are: ", @@ -1036,7 +849,7 @@ server <- function(input,output,session){ }) output$debug <- renderText(dim(res_tmp[[session$token]]$data)) - ## UP TILL HERE ## + # Sample Correlation ---- # calling server without reactive it will be init upon start, with no update # of respective data inputs hence need of at least one reactive! @@ -1045,10 +858,9 @@ server <- function(input,output,session){ data = res_tmp[[session$token]], params = par_tmp[[session$token]], reactive(updating$count) - #omic_type = reactive(input$omicType), # par_tmp$omic_type + #omic_type = reactive(input$omic_type), # par_tmp$omic_type #row_select = reactive(input$row_selection) #par_tmp$row_selection ? # only for title? ) - # significance analysis ---- significance_analysis_server( id = 'SignificanceAnalysis', @@ -1077,8 +889,6 @@ server <- function(input,output,session){ params = par_tmp[[session$token]], reactive(updating$count) ) - - # Enrichment Analysis ---- enrichment_analysis_Server( id = 'EnrichmentAnalysis', From ee50acceaf683d0e372dfe1b3c4eac770cce77e9 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Tue, 21 May 2024 16:45:10 +0200 Subject: [PATCH 13/13] Fixed DESeq problem. Integrated suggestions --- program/shinyApp/R/SourceAll.R | 2 -- program/shinyApp/R/data_selection/ui.R | 2 +- program/shinyApp/R/enrichment_analysis/server.R | 9 ++++++--- program/shinyApp/R/pre_processing/util.R | 8 +------- 4 files changed, 8 insertions(+), 13 deletions(-) diff --git a/program/shinyApp/R/SourceAll.R b/program/shinyApp/R/SourceAll.R index 393b1ad5..d1d179ea 100644 --- a/program/shinyApp/R/SourceAll.R +++ b/program/shinyApp/R/SourceAll.R @@ -19,7 +19,5 @@ source("R/sample_correlation/server.R", local = T) source("R/sample_correlation/util.R", local = T) source("R/significance_analysis/server.R", local = T) source("R/significance_analysis/util.R", local = T) -source("R/fun_getCurrentVersionFromChangeLog.R",local = T) -source("R/pre_processing/util.R",local = T) source("R/pre_processing/util.R", local = T) source("R/util.R", local = T) diff --git a/program/shinyApp/R/data_selection/ui.R b/program/shinyApp/R/data_selection/ui.R index 4f90a7a2..23a49c0a 100644 --- a/program/shinyApp/R/data_selection/ui.R +++ b/program/shinyApp/R/data_selection/ui.R @@ -2,7 +2,7 @@ data_selection_sidebar_panel <- sidebarPanel( id = "sidebar_data_selection", div(class = "omic_type", selectInput( - inputId = "omic_type", # RNAorLIPID + inputId = "omic_type", label = "Omic Type that is uploaded", choices = c("Transcriptomics", "Lipidomics", "Metabolomics"), selected = "" diff --git a/program/shinyApp/R/enrichment_analysis/server.R b/program/shinyApp/R/enrichment_analysis/server.R index 678a04e0..e0fc7d2c 100644 --- a/program/shinyApp/R/enrichment_analysis/server.R +++ b/program/shinyApp/R/enrichment_analysis/server.R @@ -704,9 +704,12 @@ enrichment_analysis_Server <- function(id, data, params, updates){ error=function(e){ showModal(modalDialog( title = HTML("An Error occured"), - footer = actionButton( - inputId = ns("translation_again"), - label = "Choose another annotation type" + footer = tagList( + actionButton( + inputId = ns("translation_again"), + label = "Choose another annotation type" + ), + modalButton("Close") ), HTML(paste0( "Error: ",e$message,"

", diff --git a/program/shinyApp/R/pre_processing/util.R b/program/shinyApp/R/pre_processing/util.R index d47eebd5..d31e718b 100644 --- a/program/shinyApp/R/pre_processing/util.R +++ b/program/shinyApp/R/pre_processing/util.R @@ -74,6 +74,7 @@ ln_normalisation <- function(data, omic_type, logarithm_procedure){ # Center and scale the data logarithm <- ifelse(logarithm_procedure == "log10", log10, log) # prefilter the data + browser() data <- prefiltering(data, omic_type) # log the data and always add 1 to avoid -Inf processedData <- as.data.frame(logarithm(as.data.frame(assay(data)) + 1)) @@ -89,7 +90,6 @@ deseq_processing <- function( # prefilter the data data <- prefiltering(data, omic_type) # DESeq2 - par_tmp[[session_token]]["DESeq_advanced"] <<- FALSE if(omic_type == "Transcriptomics"){ design_formula <- paste("~", formula_main) # only do this locally @@ -114,12 +114,6 @@ deseq_processing <- function( else{ par_tmp[[session_token]][["DESeq_factors"]] <<- c(formula_main) } - # if advanced formula is used, overwrite the other formula - if(!(advanced_formula == "") & startsWith(advanced_formula, "~")){ - print("Advanced formula used") - design_formula <- advanced_formula - par_tmp[[session_token]]["DESeq_advanced"] <<- TRUE - } print(design_formula) par_tmp[[session_token]]["DESeq_formula"] <<- design_formula # on purpose local