diff --git a/program/shinyApp/R/significance_analysis/util.R b/program/shinyApp/R/significance_analysis/util.R index c961276a..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( @@ -203,25 +204,68 @@ 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, 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) + + 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(5, 'asc'), list(6, 'desc')), + dom = 'Bfrtip', + lengthMenu = c(10, 25, 50, 100, -1), + buttons = list( + list(extend = 'colvis', text = 'Show/Hide Columns'), + '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 + ) + ), + 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","stat","pvalue","padj"), # lfcStat only avail for DESeq + 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 = "_")) @@ -306,6 +350,7 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n "Down", " " ) ) + data4Volcano$combined <- ifelse( data4Volcano$threshold_fc == " ", data4Volcano$threshold, @@ -323,6 +368,7 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n "Non-Sig + Up", "Non-Sig + Down", "Non-Sig" ) + # remove NA values sig_ana_reactive$data4Volcano <- data4Volcano[complete.cases(data4Volcano),] sig_ana_reactive$data4Volcano$chosenAnno <- rowData(res_tmp[[session$token]]$data)[rownames(sig_ana_reactive$data4Volcano),input[[Volcano_anno_tooltip]]] @@ -673,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( @@ -800,25 +847,66 @@ 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, 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) + + 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', + 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 + ) + ), + 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 = "_")) @@ -1253,6 +1341,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 @@ -1407,3 +1496,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/server.R b/program/shinyApp/server.R index fb4838ff..63043751 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({ @@ -595,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")) @@ -633,13 +603,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) & @@ -648,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){ @@ -673,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", @@ -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,17 @@ 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) + res_tmp[[session$token]]$changedDuringVI <<- 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.
", @@ -855,10 +827,10 @@ server <- function(input,output,session){ "Entitie table no na (missing values) ",check5,"\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) & @@ -867,10 +839,10 @@ server <- function(input,output,session){ } else { res_tmp[[session$token]]$passedVI <<- F } - + }) - + }) if(check6 == "No"){ @@ -922,6 +894,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") @@ -1169,11 +1164,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." diff --git a/program/shinyApp/ui.R b/program/shinyApp/ui.R index 5193ae76..999060cf 100644 --- a/program/shinyApp/ui.R +++ b/program/shinyApp/ui.R @@ -47,6 +47,7 @@ library(pcaPP) # requires gfortran. Not sure how to install on server library(reshape2) library(cowplot) # already imported but now we use it explicitly # library(svglite) +library(formattable) source("R/C.R") source("R/module_DownloadReport.R",local=T) 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"