From b30f9557a725c3531268e0a002cc1aa2761b6d08 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Sat, 25 Jan 2025 18:28:35 +0100 Subject: [PATCH 1/8] Fixed a wrong artifact in test data (compared with original data on geo base) --- program/shinyApp/www/airway-read-counts-LS.csv | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/program/shinyApp/www/airway-read-counts-LS.csv b/program/shinyApp/www/airway-read-counts-LS.csv index 62a4105d..ab781fc0 100644 --- a/program/shinyApp/www/airway-read-counts-LS.csv +++ b/program/shinyApp/www/airway-read-counts-LS.csv @@ -132,7 +132,7 @@ "ENSG00000006530","303","276","344","203","420","467","268","277" "ENSG00000006534"," 875","1108","1391"," 856","1521","2571"," 525"," 843" "ENSG00000006576"," 924"," 653","1538"," 678","1347","1144","1454","1016" -"ENSG00000006606"," 3"," 4",NA," 1"," 7","10"," 2"," 2" +"ENSG00000006606"," 3"," 4"," 2"," 1"," 7","10"," 2"," 2" "ENSG00000006607"," 652"," 733"," 924"," 776"," 674","1458"," 738","1144" "ENSG00000006625","207","186","216","101","289","333","171","133" "ENSG00000006634"," 98"," 70","104"," 48","113","103"," 96"," 72" From 9132fa18277ec321a17dc6c7b7058fe740223e18 Mon Sep 17 00:00:00 2001 From: PaulJonasJost Date: Sat, 25 Jan 2025 18:56:13 +0100 Subject: [PATCH 2/8] Removed the upload data button in visual inspection and merged with the "Inspect Data" --- program/shinyApp/server.R | 114 ++++++++++++++++++-------------------- 1 file changed, 54 insertions(+), 60 deletions(-) diff --git a/program/shinyApp/server.R b/program/shinyApp/server.R index 2964d4d3..f9721d9c 100644 --- a/program/shinyApp/server.R +++ b/program/shinyApp/server.R @@ -475,10 +475,6 @@ server <- function(input,output,session){ title = "Upload Visual Inspection", helpText("If you have uploaded your data, you might want to visually check the tables to confirm the correct data format. If you notice irregualarities you will need to correct the input data - this cannot be done in cOmicsArt, See the help on how your data is expected."), br(), - actionButton( - inputId = "DoVisualDataInspection", - label = "Upload data for visual inspection" - ) %>% helper(type = "markdown", content = "DataSelection_UploadInspection"), splitLayout( style = "border: 1px solid silver:", cellWidths = c("70%", "30%"), DT::dataTableOutput("DataMatrix_VI"), @@ -503,32 +499,7 @@ server <- function(input,output,session){ size = "l", # large modal class = "custom-modal" # custom class for this modal )) - }) - - observeEvent(input$usingVIdata,{ - if(res_tmp[[session$token]]$passedVI){ - uploaded_from("VI_data") - removeModal() - # take specification from file_input as only here VI applicable - par_tmp[[session$token]]['omic_type'] <<- input[[paste0("omic_type_file_input")]] - omic_type(input[[paste0("omic_type_file_input")]]) - shinyjs::click("refresh1") - }else{ - show_toast( - title = "Data did not passed visual inspection. Data is not used and needs adjustments before reuploading and usage within cOmicsArt!", - type = "error", - position = "top", - timerProgressBar = FALSE, - width = "100%" - ) - } - }) - observeEvent(input$CloseVI,{ - removeModal() - }) - - observeEvent(input$DoVisualDataInspection,{ tryCatch({ if(isTruthy(input$data_preDone)){ output$DataMatrix_VI_Info <- renderText({ @@ -536,8 +507,8 @@ server <- function(input,output,session){ }) req(F) } - if(!(isTruthy(input$data_matrix1) & - (isTruthy(input$data_sample_anno1)|isTruthy(input$metadataInput)) & + if(!(isTruthy(input$data_matrix1) & + (isTruthy(input$data_sample_anno1)|isTruthy(input$metadataInput)) & isTruthy(input$data_row_anno1))){ output$OverallChecks <- renderText( "The Upload has failed completely, or you haven't uploaded anything yet. Need to uploade all three matrices!" @@ -557,7 +528,7 @@ server <- function(input,output,session){ ) } ) - + if(flag_csv == F){ tryCatch( expr = { @@ -581,7 +552,7 @@ server <- function(input,output,session){ expr = { withCallingHandlers( { - dim(Matrix) # to envoke an error if it is not present + dim(Matrix) # to envoke an error if it is not present # (needed sometime as DT sometimes seem to handle errors internally and does not throw an error) # not the cleanest but works output$DataMatrix_VI <- DT::renderDataTable({ @@ -633,13 +604,13 @@ server <- function(input,output,session){ check4 <- tryCatch(ifelse(any(is.na(sample_table) == T),snippetNo,snippetYes),error = function(e) snippetNo) check5 <- tryCatch(ifelse(any(is.na(annotation_rows) == T),snippetNo,snippetYes),error = function(e) snippetNo) check6 <- tryCatch(ifelse(all(colnames(Matrix2) == colnames(Matrix)),snippetYes,snippetNo),error = function(e) snippetNo) - + check7 <- tryCatch(ifelse(all(sapply(Matrix,is.numeric)),snippetYes,snippetNo),error = function(e) snippetNo) - - if(grepl(snippetYes,check0) & - grepl(snippetYes,check1) & - grepl(snippetYes,check2) & - grepl(snippetYes,check3) & + + if(grepl(snippetYes,check0) & + grepl(snippetYes,check1) & + grepl(snippetYes,check2) & + grepl(snippetYes,check3) & grepl(snippetYes,check4) & # not crucial # grepl(snippetYes,check5) & # not crucial grepl(snippetYes,check6) & @@ -694,12 +665,12 @@ server <- function(input,output,session){ annotation_rows$original_rownames <- as.character(rownames(Matrix)) idxTochange <- grepl(invalidStart_regex, rownames(Matrix)) rownames(Matrix)[idxTochange] <- paste0("entite_", rownames(Matrix)[idxTochange]) - + idxTochange_space <- grepl(space_regex, rownames(Matrix)) rownames(Matrix)[idxTochange_space] <- gsub(space_regex,".",rownames(Matrix)[idxTochange_space]) - + allIdx_changes <- sort(unique(c(idxTochange_space,idxTochange))) - + oldnames_matrix <- rownames(Matrix)[allIdx_changes] newName_matrix <- rownames(Matrix)[allIdx_changes] info_snippet_matrix_row <- paste0("Changes:
Matrix: Number of rownames changed: ",length(oldnames_matrix),"
", @@ -716,12 +687,12 @@ server <- function(input,output,session){ colnames(Matrix) <- gsub("^X","",colnames(Matrix)) } colnames(Matrix)[idxTochange] <- paste0("sample_", colnames(Matrix)[idxTochange]) - + idxTochange_space <- grepl(space_regex, colnames(Matrix)) colnames(Matrix)[idxTochange_space] <- gsub(space_regex,".",colnames(Matrix)[idxTochange_space]) - + allIdx_changes <- sort(unique(c(idxTochange_space,idxTochange))) - + oldnames_matrix <- colnames(Matrix)[allIdx_changes] newName_matrix <- colnames(Matrix)[allIdx_changes] info_snippet_matrix_column <- paste0("Changes:
Matrix: Number of colnames changed: ",length(oldnames_matrix),"
", @@ -733,12 +704,12 @@ server <- function(input,output,session){ if(any(grepl(invalidStart_regex, rownames(sample_table))) | any(grepl(space_regex, rownames(sample_table)))){ idxTochange <- grepl(invalidStart_regex, rownames(sample_table)) rownames(sample_table)[idxTochange] <- paste0("sample_", rownames(sample_table)[idxTochange]) - + idxTochange_space <- grepl(space_regex, rownames(sample_table)) rownames(sample_table)[idxTochange_space] <- gsub(space_regex,".",rownames(sample_table)[idxTochange_space]) - + allIdx_changes <- sort(unique(c(idxTochange_space,idxTochange))) - + oldnames_sample <- rownames(sample_table)[allIdx_changes] newName_sample <- rownames(sample_table)[allIdx_changes] info_snippet_sample <- paste0("Changes:
Sample Table: Number of rownames changed: ",length(oldnames_sample),"
", @@ -750,12 +721,12 @@ server <- function(input,output,session){ if(any(grepl(invalidStart_regex, rownames(annotation_rows))) | any(grepl(space_regex, rownames(annotation_rows)))){ idxTochange <- grepl(invalidStart_regex, rownames(annotation_rows)) rownames(annotation_rows)[idxTochange] <- paste0("entite_", rownames(annotation_rows)[idxTochange]) - + idxTochange_space <- grepl(space_regex, rownames(annotation_rows)) rownames(annotation_rows)[idxTochange_space] <- gsub(space_regex,".",rownames(annotation_rows)[idxTochange_space]) - + allIdx_changes <- sort(unique(c(idxTochange_space,idxTochange))) - + oldnames_entitie <- rownames(annotation_rows)[allIdx_changes] newNames_entitie <- rownames(annotation_rows)[allIdx_changes] info_snippet_entitie <- paste0("Changes:
Entitie Table: Number of rownames changed: ",length(oldnames_entitie),"
", @@ -764,16 +735,16 @@ server <- function(input,output,session){ }else{ info_snippet_entitie <- "" } - + # TODO if rownames updated put also to report - + # Write the matrices to csv's to allow reupload for later write.csv(Matrix, file = paste0("www/",session$token,"/updatedMatrix.csv"), row.names = T) write.csv(sample_table, file = paste0("www/",session$token,"/updatedSampleTable.csv"), row.names = T) write.csv(annotation_rows, file = paste0("www/",session$token,"/updatedEntitieAnnotation.csv"), row.names = T) # TODO also set flag to update matrixes upon 'upload new data' within app for this round - + showModal(modalDialog( title = "Download Updated Data", HTML(paste0("You can download your updated data for later reupload.
", @@ -853,10 +824,10 @@ server <- function(input,output,session){ "Sample IDs have valid names ", check6, "\n" ) }) - if(grepl(snippetYes,check0) & - grepl(snippetYes,check1) & - grepl(snippetYes,check2) & - grepl(snippetYes,check3) & + if(grepl(snippetYes,check0) & + grepl(snippetYes,check1) & + grepl(snippetYes,check2) & + grepl(snippetYes,check3) & grepl(snippetYes,check4) & # not crucial # grepl(snippetYes,check5) & # not crucial grepl(snippetYes,check6) & @@ -865,10 +836,10 @@ server <- function(input,output,session){ } else { res_tmp[[session$token]]$passedVI <<- F } - + }) - + }) if(check6 == "No"){ @@ -919,6 +890,29 @@ server <- function(input,output,session){ }) }) + observeEvent(input$usingVIdata,{ + if(res_tmp[[session$token]]$passedVI){ + uploaded_from("VI_data") + removeModal() + # take specification from file_input as only here VI applicable + par_tmp[[session$token]]['omic_type'] <<- input[[paste0("omic_type_file_input")]] + omic_type(input[[paste0("omic_type_file_input")]]) + shinyjs::click("refresh1") + }else{ + show_toast( + title = "Data did not passed visual inspection. Data is not used and needs adjustments before reuploading and usage within cOmicsArt!", + type = "error", + position = "top", + timerProgressBar = FALSE, + width = "100%" + ) + } + + }) + observeEvent(input$CloseVI,{ + removeModal() + }) + observeEvent(input$refresh_file_input, { uploaded_from("file_input") From 1d2515dd2836b225c579a9184ebb3d3405c8e684 Mon Sep 17 00:00:00 2001 From: "Lea@Mac" Date: Mon, 3 Feb 2025 10:15:46 +0100 Subject: [PATCH 3/8] bug fixed - was due to missing input if uploaded data can be used as it is --- program/shinyApp/server.R | 30 +++++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/program/shinyApp/server.R b/program/shinyApp/server.R index f9721d9c..72d96a64 100644 --- a/program/shinyApp/server.R +++ b/program/shinyApp/server.R @@ -566,7 +566,6 @@ server <- function(input,output,session){ ) }, error = function(e) { - browser() # Handle errors specifically output$DataMatrix_VI <- DT::renderDataTable({ DT::datatable(data = data.frame(Error = "Invalid data for display")) @@ -619,6 +618,7 @@ server <- function(input,output,session){ } else { res_tmp[[session$token]]$passedVI <<- F } + res_tmp[[session$token]]$changedDuringVI <<- F #TODO ensure that if there are e.g. invalid sample names but als different sample names in data and annotation tables that we catch this if(check0 == snippetNo){ @@ -644,7 +644,7 @@ server <- function(input,output,session){ "\n\tNa's will be replaced by rownames per default") } # ensuring we try to rescue names only if crucial checks pass - if(check6 == snippetNo & check0 == snippetYes & check7==snippetYes ){ + if(check6 == snippetNo & check0 == snippetYes & check7 == snippetYes ){ # add option to user for automatic column name correction showModal(modalDialog( title = "Column Name Correction", @@ -742,6 +742,7 @@ server <- function(input,output,session){ write.csv(Matrix, file = paste0("www/",session$token,"/updatedMatrix.csv"), row.names = T) write.csv(sample_table, file = paste0("www/",session$token,"/updatedSampleTable.csv"), row.names = T) write.csv(annotation_rows, file = paste0("www/",session$token,"/updatedEntitieAnnotation.csv"), row.names = T) + res_tmp[[session$token]]$changedDuringVI <<- T # TODO also set flag to update matrixes upon 'upload new data' within app for this round @@ -938,6 +939,7 @@ server <- function(input,output,session){ ## Do Upload ---- observeEvent(input$refresh1,{ req(data_input_shiny()) + print("This sould be seond") par_tmp[[session$token]]['addedGeneAnno'] <<- FALSE fun_LogIt(message = "## Data Selection {.tabset .tabset-fade}") fun_LogIt(message = "### Info") @@ -1015,6 +1017,7 @@ server <- function(input,output,session){ ## create data object ---- data_input_shiny <- eventReactive(input$refresh1,{ + print("This sould be first") if(is.null(unlist(par_tmp[[session$token]]['omic_type']))){ par_tmp[[session$token]]['omic_type'] <<- input[[paste0("omic_type_", uploaded_from())]] omic_type(input[[paste0("omic_type_", uploaded_from())]]) @@ -1160,11 +1163,24 @@ server <- function(input,output,session){ message = paste0("**Attention** - Test Data set used") ) } else if(uploaded_from() == "VI_data"){ - data_input <- list( - Matrix = read_file(paste0("www/",session$token,"/updatedMatrix.csv"), check.names=T), - sample_table = read_file(paste0("www/",session$token,"/updatedSampleTable.csv"), check.names=T), - annotation_rows = read_file(paste0("www/",session$token,"/updatedEntitieAnnotation.csv"), check.names=T) - ) + if(res_tmp[[session$token]]$changedDuringVI){ + data_input <- list( + Matrix = read_file(paste0("www/",session$token,"/updatedMatrix.csv"), check.names=T), + sample_table = read_file(paste0("www/",session$token,"/updatedSampleTable.csv"), check.names=T), + annotation_rows = read_file(paste0("www/",session$token,"/updatedEntitieAnnotation.csv"), check.names=T) + ) + }else{ + data_input <- list( + 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) + ) + # 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){ + data_input$annotation_rows$origRownames <- rownames(data_input$annotation_rows) + } + } } else { output$debug <- renderText({ "Upload failed, please check your input." From 5eacbba171029e093013b81a80e1642ae8092642 Mon Sep 17 00:00:00 2001 From: "Lea@Mac" Date: Mon, 3 Feb 2025 10:16:02 +0100 Subject: [PATCH 4/8] rm print statements --- program/shinyApp/server.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/program/shinyApp/server.R b/program/shinyApp/server.R index 72d96a64..5709b881 100644 --- a/program/shinyApp/server.R +++ b/program/shinyApp/server.R @@ -939,7 +939,6 @@ server <- function(input,output,session){ ## Do Upload ---- observeEvent(input$refresh1,{ req(data_input_shiny()) - print("This sould be seond") par_tmp[[session$token]]['addedGeneAnno'] <<- FALSE fun_LogIt(message = "## Data Selection {.tabset .tabset-fade}") fun_LogIt(message = "### Info") @@ -1017,7 +1016,6 @@ server <- function(input,output,session){ ## create data object ---- data_input_shiny <- eventReactive(input$refresh1,{ - print("This sould be first") if(is.null(unlist(par_tmp[[session$token]]['omic_type']))){ par_tmp[[session$token]]['omic_type'] <<- input[[paste0("omic_type_", uploaded_from())]] omic_type(input[[paste0("omic_type_", uploaded_from())]]) From 147e4e147a0a2a320648b5f856c4d3b1f36c6564 Mon Sep 17 00:00:00 2001 From: "Lea@Mac" Date: Mon, 3 Feb 2025 16:02:34 +0100 Subject: [PATCH 5/8] formatted data tables nicer according to #432 --- .../shinyApp/R/significance_analysis/util.R | 176 +++++++++++++----- program/shinyApp/ui.R | 1 + 2 files changed, 134 insertions(+), 43 deletions(-) diff --git a/program/shinyApp/R/significance_analysis/util.R b/program/shinyApp/R/significance_analysis/util.R index df97a8cf..cd9a2f81 100644 --- a/program/shinyApp/R/significance_analysis/util.R +++ b/program/shinyApp/R/significance_analysis/util.R @@ -192,25 +192,64 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n output[[ns(paste(contrast[1], contrast[2], "summary", sep = "_"))]] <- renderText( paste(resume, collapse = "
") ) - output[[ns(paste(contrast[1], contrast[2], "table", sep = "_"))]] <- DT::renderDataTable({DT::datatable( - data = result, - extensions = 'Buttons', - filter = 'top', - rownames = T, - colnames = c('Gene' = 1), - options = list( - paging = TRUE, - searching = TRUE, - fixedColumns = TRUE, - autoWidth = TRUE, - ordering = TRUE, - order = list(list(4, 'asc'), list(5, 'asc')), # 4=padj, 5=pvalue - dom = 'Bfrtip', - lengthMenu = c(10, 25, 50, 100, -1), - buttons = c('pageLength', 'copy', 'csv', 'excel') - ), - class = "cell-border compact stripe hover order-column" - )}) + + result <- addStars(result) + + brks_log2FC_neg <- seq(min(result$log2FoldChange) -1, 0, length.out = 100) # -1 for towning down color match + brks_log2FC_pos <- seq(0, max(result$log2FoldChange) +1 , length.out = 100) # +a for towning down color match + brks <- c(brks_log2FC_neg, brks_log2FC_pos) + clrs <- colorRampPalette(c("#0e5bcfCD","#fafafa","#cf0e5bCD"))(length(brks) + 1) + + brks_padj_sig <- seq(0, par_tmp[[session$token]]$SigAna$significance_level, length.out = 10) + brks_padj_unsig <- seq(par_tmp[[session$token]]$SigAna$significance_level,1, length.out = 10) + brks_padj <- c(brks_padj_sig, brks_padj_unsig) + clrs_padj <- colorRampPalette(c("#ffce78","#fafafa","#fafafa"))(length(brks_padj) + 1) + + output[[ns(paste(contrast[1], contrast[2], "table", sep = "_"))]] <- + DT::renderDataTable({ + DT::datatable( + data = result, + extensions = 'Buttons', + filter = 'top', + rownames = TRUE, + colnames = c('Gene' = 1), + options = list( + paging = TRUE, + searching = TRUE, + fixedColumns = TRUE, + autoWidth = TRUE, + ordering = TRUE, + order = list(list(7, 'asc'), list(3, 'desc')), # 6=padj, 2=log2FoldChange + dom = 'Bfrtip', + lengthMenu = c(10, 25, 50, 100, -1), + buttons = list( + list(extend = 'colvis', text = 'Show/Hide Columns'), + 'pageLength', 'copy', 'csv', 'excel'), + columnDefs = list( + list(searchable = FALSE, targets = which(colnames(result) == "sig_level")), # Disable filter for "sig_level" + list(visible = FALSE, targets = c(2, 4, 5, 6)) # Hide specific columns initially + ) + ), + escape = F, + class = "cell-border compact stripe hover order-column" + ) %>% + formatStyle( + c("log2FoldChange"), + backgroundColor = styleInterval(brks, clrs) + ) %>% + formatStyle( + c("padj","pvalue"), + backgroundColor = styleInterval(brks_padj, clrs_padj) + ) %>% + formatSignif( + c("log2FoldChange","baseMean","lfcSE","stat","pvalue","padj"), + digits = 4, + interval = 3, + dec.mark = getOption("OutDec"), + zero.print = NULL, + rows = NULL + ) + }) psig_th <- ns(paste(contrast[1], contrast[2], "psig_th", sep = "_")) lfc_th <- ns(paste(contrast[1], contrast[2], "lfc_th", sep = "_")) @@ -284,11 +323,7 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n ) data4Volcano$combined <- paste0(data4Volcano$threshold," + ",data4Volcano$threshold_fc) data4Volcano$combined_raw <- paste0(data4Volcano$threshold_raw," + ",data4Volcano$threshold_fc) - colorScheme2 <- c("#cf0e5bCD", "#0e5bcfCD", "#939596CD","#cf0e5b1A", "#0e5bcf1A", "#9395961A") - names(colorScheme2) <- c( - "significant + up-regulated", "significant + down-regulated", "significant + ", - "non-significant + up-regulated", "non-significant + down-regulated", "non-significant + " - ) + # remove NA values sig_ana_reactive$data4Volcano <- data4Volcano[complete.cases(data4Volcano),] @@ -754,25 +789,64 @@ create_new_tab_DESeq <- function(title, targetPanel, result, contrast, alpha, ns output[[ns(paste(contrast[1], contrast[2], "summary", sep = "_"))]] <- renderText( paste(resume, collapse = "
") ) - output[[ns(paste(contrast[1], contrast[2], "table", sep = "_"))]] <- DT::renderDataTable({DT::datatable( - data = as.data.frame(result), - extensions = 'Buttons', - filter = 'top', - rownames = TRUE, - colnames = c('Gene' = 1), - options = list( - paging = TRUE, - searching = TRUE, - fixedColumns = TRUE, - autoWidth = TRUE, - ordering = TRUE, - order = list(list(6, 'asc'), list(2, 'desc')), # 6=padj, 2=log2FoldChange - dom = 'Bfrtip', - lengthMenu = c(10, 25, 50, 100, -1), - buttons = c('pageLength', 'copy', 'csv', 'excel') - ), - class = "cell-border compact stripe hover order-column" - )}) + + result <- addStars(result) + + brks_log2FC_neg <- seq(min(result$log2FoldChange) -1, 0, length.out = 100) # -1 for towning down color match + brks_log2FC_pos <- seq(0, max(result$log2FoldChange) +1 , length.out = 100) # +a for towning down color match + brks <- c(brks_log2FC_neg, brks_log2FC_pos) + clrs <- colorRampPalette(c("#0e5bcfCD","#fafafa","#cf0e5bCD"))(length(brks) + 1) + + brks_padj_sig <- seq(0, par_tmp[[session$token]]$SigAna$significance_level, length.out = 10) + brks_padj_unsig <- seq(par_tmp[[session$token]]$SigAna$significance_level,1, length.out = 10) + brks_padj <- c(brks_padj_sig, brks_padj_unsig) + clrs_padj <- colorRampPalette(c("#ffce78","#fafafa","#fafafa"))(length(brks_padj) + 1) + + output[[ns(paste(contrast[1], contrast[2], "table", sep = "_"))]] <- + DT::renderDataTable({ + DT::datatable( + data = result, + extensions = 'Buttons', + filter = 'top', + rownames = TRUE, + colnames = c('Gene' = 1), + options = list( + paging = TRUE, + searching = TRUE, + fixedColumns = TRUE, + autoWidth = TRUE, + ordering = TRUE, + order = list(list(7, 'asc'), list(3, 'desc')), # 6=padj, 2=log2FoldChange + dom = 'Bfrtip', + lengthMenu = c(10, 25, 50, 100, -1), + buttons = list( + list(extend = 'colvis', text = 'Show/Hide Columns'), + 'pageLength', 'copy', 'csv', 'excel'), + columnDefs = list( + list(searchable = FALSE, targets = which(colnames(result) == "sig_level")), # Disable filter for "sig_level" + list(visible = FALSE, targets = c(2, 4, 5, 6)) # Hide specific columns initially + ) + ), + escape = F, + class = "cell-border compact stripe hover order-column" + ) %>% + formatStyle( + c("log2FoldChange"), + backgroundColor = styleInterval(brks, clrs) + ) %>% + formatStyle( + c("padj","pvalue"), + backgroundColor = styleInterval(brks_padj, clrs_padj) + ) %>% + formatSignif( + c("log2FoldChange","baseMean","lfcSE","stat","pvalue","padj"), + digits = 4, + interval = 3, + dec.mark = getOption("OutDec"), + zero.print = NULL, + rows = NULL + ) + }) psig_th <- ns(paste(contrast[1], contrast[2], "psig_th", sep = "_")) lfc_th <- ns(paste(contrast[1], contrast[2], "lfc_th", sep = "_")) @@ -1325,3 +1399,19 @@ log_messages_volcano<- function(plot, table, contrast, file_path){ removeNotification(notificationID) showNotification("Saved!",type = "message", duration = 1) } + + +addStars <- function(result){ # assumes padj column present + result <- as.data.frame(result) %>% + mutate(sig_level = case_when( + padj < 0.0001 ~ as.character(HTML(paste0(icon("star", lib = "font-awesome"), + icon("star", lib = "font-awesome"), + icon("star", lib = "font-awesome")))), # Three stars for padj < 0.0001 + padj < 0.001 ~ as.character(HTML(paste0(icon("star", lib = "font-awesome"), + icon("star", lib = "font-awesome")))), # Two stars for padj < 0.001 + padj < par_tmp[[session$token]]$SigAna$significance_level ~ as.character(icon("star", lib = "font-awesome")), # One star if below significance threshold + padj >= par_tmp[[session$token]]$SigAna$significance_level ~ as.character(icon("minus", lib = "font-awesome")) # Default case + )) + result <- result[,c("sig_level", colnames(result)[1:(ncol(result)-1)])] + return(result) +} diff --git a/program/shinyApp/ui.R b/program/shinyApp/ui.R index 60948aea..341f369e 100644 --- a/program/shinyApp/ui.R +++ b/program/shinyApp/ui.R @@ -46,6 +46,7 @@ library(sva) library(pcaPP) # requires gfortran. Not sure how to install on server library(reshape2) # library(svglite) +library(formattable) source("R/C.R") source("R/module_DownloadReport.R",local=T) From 6a058f63924ee766a376a8c986905b50da52a0ac Mon Sep 17 00:00:00 2001 From: "Lea@Mac" Date: Wed, 5 Feb 2025 09:26:23 +0100 Subject: [PATCH 6/8] fix tables accounting for difference in manual tab and DEseq tab --- .../shinyApp/R/significance_analysis/util.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/program/shinyApp/R/significance_analysis/util.R b/program/shinyApp/R/significance_analysis/util.R index 34d2c65d..d79943e0 100644 --- a/program/shinyApp/R/significance_analysis/util.R +++ b/program/shinyApp/R/significance_analysis/util.R @@ -203,11 +203,11 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n output[[ns(paste(contrast[1], contrast[2], "summary", sep = "_"))]] <- renderText( paste(resume, collapse = "
") ) - + result <- addStars(result) - brks_log2FC_neg <- seq(min(result$log2FoldChange) -1, 0, length.out = 100) # -1 for towning down color match - brks_log2FC_pos <- seq(0, max(result$log2FoldChange) +1 , length.out = 100) # +a for towning down color match + brks_log2FC_neg <- seq(min(result$log2FoldChange, na.rm = T) -1 , 0, length.out = 100) # -1 for towning down color match + brks_log2FC_pos <- seq(0, max(result$log2FoldChange, na.rm = T) +1 , length.out = 100) # +a for towning down color match brks <- c(brks_log2FC_neg, brks_log2FC_pos) clrs <- colorRampPalette(c("#0e5bcfCD","#fafafa","#cf0e5bCD"))(length(brks) + 1) @@ -230,7 +230,7 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n fixedColumns = TRUE, autoWidth = TRUE, ordering = TRUE, - order = list(list(7, 'asc'), list(3, 'desc')), # 6=padj, 2=log2FoldChange + order = list(list(5, 'asc'), list(6, 'desc')), dom = 'Bfrtip', lengthMenu = c(10, 25, 50, 100, -1), buttons = list( @@ -238,7 +238,7 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n 'pageLength', 'copy', 'csv', 'excel'), columnDefs = list( list(searchable = FALSE, targets = which(colnames(result) == "sig_level")), # Disable filter for "sig_level" - list(visible = FALSE, targets = c(2, 4, 5, 6)) # Hide specific columns initially + list(visible = FALSE, targets = c(3, 4)) # Hide specific columns initially ) ), escape = F, @@ -253,7 +253,7 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n backgroundColor = styleInterval(brks_padj, clrs_padj) ) %>% formatSignif( - c("log2FoldChange","baseMean","lfcSE","stat","pvalue","padj"), + c("log2FoldChange","baseMean","stat","pvalue","padj"), # lfcStat only avail for DESeq digits = 4, interval = 3, dec.mark = getOption("OutDec"), @@ -841,11 +841,10 @@ create_new_tab_DESeq <- function(title, targetPanel, result, contrast, alpha, ns output[[ns(paste(contrast[1], contrast[2], "summary", sep = "_"))]] <- renderText( paste(resume, collapse = "
") ) - result <- addStars(result) - brks_log2FC_neg <- seq(min(result$log2FoldChange) -1, 0, length.out = 100) # -1 for towning down color match - brks_log2FC_pos <- seq(0, max(result$log2FoldChange) +1 , length.out = 100) # +a for towning down color match + brks_log2FC_neg <- seq(min(result$log2FoldChange, na.rm = T) -1, 0, length.out = 100) # -1 for towning down color match + brks_log2FC_pos <- seq(0, max(result$log2FoldChange, na.rm = T) +1 , length.out = 100) # +a for towning down color match brks <- c(brks_log2FC_neg, brks_log2FC_pos) clrs <- colorRampPalette(c("#0e5bcfCD","#fafafa","#cf0e5bCD"))(length(brks) + 1) @@ -1333,6 +1332,7 @@ significance_analysis <- function( ) } sig_results <- list() + # for each comparison get the data and do the test # introduce a running parameter alongside the loop for the name comp_name <- 1 From e94acb4018bdc0535ecbe0d853fb09ef40950a8e Mon Sep 17 00:00:00 2001 From: "Lea@Mac" Date: Wed, 5 Feb 2025 14:35:40 +0100 Subject: [PATCH 7/8] make default names clearer --- program/shinyApp/R/significance_analysis/util.R | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/program/shinyApp/R/significance_analysis/util.R b/program/shinyApp/R/significance_analysis/util.R index d79943e0..c418fa2a 100644 --- a/program/shinyApp/R/significance_analysis/util.R +++ b/program/shinyApp/R/significance_analysis/util.R @@ -235,7 +235,11 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n lengthMenu = c(10, 25, 50, 100, -1), buttons = list( list(extend = 'colvis', text = 'Show/Hide Columns'), - 'pageLength', 'copy', 'csv', 'excel'), + 'pageLength', + 'copy', + list(extend = 'csv', filename = 'significance_table'), + list(extend = 'excel', filename = 'significance_table') + ), columnDefs = list( list(searchable = FALSE, targets = which(colnames(result) == "sig_level")), # Disable filter for "sig_level" list(visible = FALSE, targets = c(3, 4)) # Hide specific columns initially @@ -872,7 +876,10 @@ create_new_tab_DESeq <- function(title, targetPanel, result, contrast, alpha, ns lengthMenu = c(10, 25, 50, 100, -1), buttons = list( list(extend = 'colvis', text = 'Show/Hide Columns'), - 'pageLength', 'copy', 'csv', 'excel'), + 'pageLength', 'copy', + list(extend = 'csv', text = 'CSV', filename = 'significance_table'), + list(extend = 'excel', text = 'xlsx', filename = 'significance_table') + ), columnDefs = list( list(searchable = FALSE, targets = which(colnames(result) == "sig_level")), # Disable filter for "sig_level" list(visible = FALSE, targets = c(2, 4, 5, 6)) # Hide specific columns initially From cbc8a5a156b658957f113bc4c2d04f8447d27443 Mon Sep 17 00:00:00 2001 From: "Lea@Mac" Date: Wed, 5 Feb 2025 16:48:57 +0100 Subject: [PATCH 8/8] added not for missing icons upon download --- program/shinyApp/R/significance_analysis/util.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/program/shinyApp/R/significance_analysis/util.R b/program/shinyApp/R/significance_analysis/util.R index c418fa2a..52cbeaeb 100644 --- a/program/shinyApp/R/significance_analysis/util.R +++ b/program/shinyApp/R/significance_analysis/util.R @@ -77,6 +77,7 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n h4(paste("Summary of the results comparing ", contrast[1], " and ", contrast[2])), htmlOutput(outputId = ns(paste(contrast[1], contrast[2], "summary", sep = "_")), container = pre), # create table with results, that allows filtering + p("Note that the sig_level column will not show icons if downloaded"), DT::dataTableOutput(outputId = ns(paste(contrast[1], contrast[2], "table", sep = "_"))) ), tabPanel( @@ -718,6 +719,7 @@ create_new_tab_DESeq <- function(title, targetPanel, result, contrast, alpha, ns h4(paste("Summary of the results comparing ", contrast[1], " and ", contrast[2])), htmlOutput(outputId = ns(paste(contrast[1], contrast[2], "summary", sep = "_")), container = pre), # create table with results, that allows filtering + p("Note that the sig_level column will not show icons if downloaded"), DT::dataTableOutput(outputId = ns(paste(contrast[1], contrast[2], "table", sep = "_"))) ), tabPanel(