Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

fix_test_data #442

Merged
merged 9 commits into from
Feb 5, 2025
Merged

fix_test_data #442

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
9 commits
Select commit Hold shift + click to select a range
b30f955
Fixed a wrong artifact in test data (compared with original data on g…
PaulJonasJost Jan 25, 2025
9132fa1
Removed the upload data button in visual inspection and merged with t…
PaulJonasJost Jan 25, 2025
1d2515d
bug fixed - was due to missing input if uploaded data can be used as …
LeaSeep Feb 3, 2025
5eacbba
rm print statements
LeaSeep Feb 3, 2025
147e4e1
formatted data tables nicer according to #432
LeaSeep Feb 3, 2025
f00d310
Merge branch 'develop' into fix_test_data
LeaSeep Feb 3, 2025
6a058f6
fix tables accounting for difference in manual tab and DEseq tab
LeaSeep Feb 5, 2025
e94acb4
make default names clearer
LeaSeep Feb 5, 2025
cbc8a5a
added not for missing icons upon download
LeaSeep Feb 5, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
181 changes: 143 additions & 38 deletions program/shinyApp/R/significance_analysis/util.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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(
Expand Down Expand Up @@ -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 = "<br>")
)
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 = "_"))
Expand Down Expand Up @@ -306,6 +350,7 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n
"Down", " "
)
)

data4Volcano$combined <- ifelse(
data4Volcano$threshold_fc == " ",
data4Volcano$threshold,
Expand All @@ -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]]]
Expand Down Expand Up @@ -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(
Expand Down Expand Up @@ -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 = "<br>")
)
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 = "_"))
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
}
Loading