inst/shiny/server.R
In campbio/musicatk: Mutational Signature Comprehensive Analysis Toolkit
library(musicatk)
library(plotly)
library(sortable)
library(shinyBS)
library(shinyalert)
library(TCGAbiolinks)
library(shinyjqui)
options(shiny.maxRequestSize = 10000 * 1024 ^ 2)
server <- function(input, output, session) {
#################### GENERAL ##################################################
#Deactivate all tabs except import
shinyjs::addCssClass(selector = "a[data-value='musica']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='annotations']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='tables']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='discover']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='predict']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='visualization']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='compare']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='differentialanalysis']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='cluster']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='heatmap']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='download']",
class = "inactiveLink")
#Initialize variables
vals <- reactiveValues(
genome = NULL,
musica = NULL,
files = NULL,
res_names = NULL,
res_names_full = list(),
#result_objects = list(),
p_sigs = NULL, #cosmic sig
p_res = NULL, #cosmic result object
annotations = NULL,
diff = NULL,
df = NULL,
musica_upload = NULL,
data = NULL,
point_ind = 0, #indicator for point option in exposure
annot = NULL,
deleted_rows = NULL,
deleted_row_indices = list(),
cluster = NULL,
var = NULL,
musica_name_user = NULL,
musica_message = NULL,
sort_sigs = NULL
)
#Control flow to detect user's progress and active tabs
observeEvent(input$menu, {
if (input$menu == "musica") {
if (is.null(vals$var)) {
shinyalert::shinyalert("Error",
paste0("No data was uploaded. ",
"Please go to \"Import\" ",
"and upload your data.", "error"))
updateTabItems(session, "menu", "import")
}
else{
removeCssClass(selector = "a[data-value='musica']",
class = "inactiveLink")
}
}
else if (input$menu == "annotations") {
if (is.null(vals$musica) && length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No musica object was found. ",
"Please go to \"Import\" or ",
"\"Create Musica Object\" to upload or ",
"create an object.", "error"))
updateTabItems(session, "menu", "import")
}
}
else if (input$menu == "download") {
if (is.null(vals$musica) && length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No musica object was found. ",
"Please go to \"Import\" or ",
"\"Create Musica Object\" to upload or ",
"create an object.", "error"))
updateTabItems(session, "menu", "import")
}
}
else if (input$menu == "tables") {
if (is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No data was uploaded. ",
"Please go to \"Import\" and upload ",
"your data.", "error"))
updateTabItems(session, "menu", "import")
}
else if (!is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No musica object was created. ",
"Please go to \"Create Musica Object\", ",
"to create a musica object or go to ",
"\"Import\" -> \"Import Musica Result ",
"Object\" to upload a muscia object."),
"error")
updateTabItems(session, "menu", "musica")
}
else{
removeCssClass(selector = "a[data-value='tables']",
class = "inactiveLink")
}
}
else if (input$menu %in% c("discover", "predict")) {
if (is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No data was uploaded. ",
"Please go to \"Import\" and upload ",
"your data."), "error")
updateTabItems(session, "menu", "import")
}
else if (!is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No musica object was created.",
"Please go to \"Create Musica Object\",",
"to create a musica object or go to ",
"\"Import\" -> \"Import Musica Result Object\" ",
"to upload a muscia object."), "error")
updateTabItems(session, "menu", "musica")
}
else if (!is.null(vals$var) && !is.null(vals$musica) &&
length(tables(vals$musica)) == 0 &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No mutation count table was created. ",
"Please go to \"Build Tables\" to ",
"create count table."),
"error")
updateTabItems(session, "menu", "tables")
}
else if (!is.null(vals$var) && is.null(vals$musica) &&
!is.null(vals$musica_upload) &&
length(tables(vals$musica_upload)) == 0) {
shinyalert::shinyalert("Error",
paste0("No mutation count table was created. ",
"Please go to \"Build Tables\" to ",
"create count table."),
"error")
updateTabItems(session, "menu", "tables")
}
else{
removeCssClass(selector = "a[data-value='discover']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='predict']",
class = "inactiveLink")
}
}
else if (input$menu %in% c("visualization", "compare",
"differentialanalysis", "cluster", "heatmap")) {
if (is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload) && length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No data was uploaded. ",
"Please go to \"Import\" and upload ",
"your data."), "error")
updateTabItems(session, "menu", "import")
}
else if (!is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload) &&
length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No musica object was created. ",
"Please go to \"Create Musica Object\" ",
"to create a musica object or go to ",
"\"Import\" -> \"Import Musica ",
"Object\ to upload a muscia object."),
"error")
updateTabItems(session, "menu", "musica")
}
else if (!is.null(vals$var) && !is.null(vals$musica) &&
length(tables(vals$musica)) == 0 &&
is.null(vals$musica_upload) &&
length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No mutation count table was created. ",
"Please go to \"Build Tables\" ",
"to create count table."),
"error")
updateTabItems(session, "menu", "tables")
}
else if (!is.null(vals$var) && is.null(vals$musica)
&& !is.null(vals$musica_upload)
&& length(tables(vals$musica_upload)) == 0
&& length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No mutation count table was created. ",
"Please go to \"Build Tables\" to ",
"create count table."),
"error")
updateTabItems(session, "menu", "tables")
}
else if (!is.null(vals$var) && (!is.null(vals$musica) ||
!is.null(vals$musica_upload))
&& (length(tables(vals$musica)) != 0 ||
length(tables(vals$musica_upload)) != 0)
&& length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No results in the musica object. ",
"Please go to \"Signatures and ",
"Exposures\" -> \"Discover Signatures ",
"and Exposures\" to create ",
"results."), "error")
updateTabItems(session, "menu", "discover")
}
else if (!is.null(vals$musica_upload) && length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No results in the musica object. ",
"Please go to \"Signatures and ",
"Exposures\" -> \"Discover Signatures ",
"and Exposures\" to create ",
"results."), "error")
updateTabItems(session, "menu", "discover")
}
else{
removeCssClass(selector = "a[data-value='visualization']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='compare']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='differentialanalysis']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='cluster']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='heatmap']",
class = "inactiveLink")
}
}
else{
return()
}
})
#If variants uplodaed, enable musica tab
observeEvent(vals$var, {
if (!is.null(vals$var)) {
removeCssClass(selector = "a[data-value='musica']",
class = "inactiveLink")
}
})
#If musica object present, enable downstream tabs
observeEvent(vals$musica, {
if (!is.null(vals$musica)) {
removeCssClass(selector = "a[data-value='tables']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='annotations']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='download']",
class = "inactiveLink")
}
if (length(tables(vals$musica)) != 0) {
removeCssClass(selector = "a[data-value='discover']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='predict']",
class = "inactiveLink")
}
})
#If there's uploaded musica object, enable downstream tabs
observeEvent(vals$musica_upload, {
if (!is.null(vals$musica_upload)) {
removeCssClass(selector = "a[data-value='tables']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='annotations']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='download']",
class = "inactiveLink")
}
if (length(tables(vals$musica_upload)) != 0) {
removeCssClass(selector = "a[data-value='discover']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='predict']",
class = "inactiveLink")
}
})
#If there's result object, enable downstream tabs
observeEvent(vals$res_names, {
if (length(vals$res_names) > 0) {
removeCssClass(selector = "a[data-value='annotations']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='visualization']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='compare']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='differentialanalysis']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='cluster']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='heatmap']",
class = "inactiveLink")
}
})
###################### Zainab's Code ##########################################
output$tcga_tumor <- renderUI({
hr()
#Extracting TCGA tumors and formatting it to display only the abbreviations
projects <- TCGAbiolinks:::getGDCprojects()
matches <- grepl("TCGA", projects$id)
projects <- projects[matches,]
project.name <- paste0(projects$id, ": ", projects$name)
p <- projects$id
names(p) <- project.name
p <- sort(p)
textInput("tcga_tumor", "Enter TCGA tumor type")
tags$style("#tcga_tumor {
font-size:8px;
height:10px;
}")
checkboxGroupInput("tcga_tumor", " ", choices = as.list(p))
})
observeEvent(input$import_tcga, {
req(input$import_tcga)
if (!is.null(input$tcga_tumor)) {
shinybusy::show_spinner()
# Now defunct in TCGAbiolink
# maf <- TCGAbiolinks::GDCquery_Maf(input$tcga_tumor, pipelines = "mutect")
# New way:
query <- GDCquery(project = input$tcga_tumor,
data.category = "Simple Nucleotide Variation",
data.type = "Masked Somatic Mutation",
workflow.type = "Aliquot Ensemble Somatic Variant Merging and Masking",
experimental.strategy = "WXS",
data.format = "MAF")
GDCdownload(query)
maf <- GDCprepare(query)
vals$var <- extract_variants_from_maf_file(maf)
showNotification("TCGA dataset successfully imported!")
shinybusy::hide_spinner()
}
else if (is.null(input$tcga_tumor)) {
shinyalert("Error: No tumor found. Please select a tumor from the list!")
}
})
#Displaying thr table for TCGA tumor variants
output$tcga_contents <- DT::renderDT({
req(vals$var)
req(input$tcga_tumor)
return(head(vals$var))
shinyjs::show(id = "tcga_contents")
js$enableTabs()
})
observeEvent(input$import, {
req(input$file)
file_name <- vals$data$datapath
summaries_list <- list()
if (all(tools::file_ext(file_name) != c("maf", "vcf", "txt"))) {
shinyalert::shinyalert(paste0("Error: File format not supported! ",
"Please upload .maf or .vcf files"))
}
if (all(tools::file_ext(file_name) == c("txt"))){
shinybusy::show_spinner()
vals$var <- extract_variants_from_maf_file(c(file_name))
shinybusy::hide_spinner()
showNotification("Import successfully completed!")
}
else{
shinybusy::show_spinner()
for (i in seq_along(file_name)) {
# Try to read the file
result <- tryCatch({
vcf <- extract_variants(file_name[i])
}, error = function(e) {
# If there is an error, return NULL or an error message
message(paste("Error reading file:", file_name[i], "\nError message:", e$message))
return(NULL)
})
# If result is not NULL, add it to the list
if (!is.null(result)) {
summaries_list[[i]] <- result
}
}
# Combine the list of data frames into one data frame
do.call(rbind, summaries_list)
vals$var <- do.call(rbind, summaries_list)
shinybusy::hide_spinner()
showNotification("Import successfully completed!")
}
})
#Displaying list of available genomes
output$genome_list <- renderUI({
g <- BSgenome::available.genomes()
g <- strsplit(g, ",")
gg <- gsub("^.*?\\.", "", g)
selectInput("GenomeSelect", "Choose genome:",
list("Common genomes" =
list("hg38", "hg19", "hg18", "mm9", "mm10"),
"Genomes" = gg),
width = "100%")
})
output$genome_select <- renderText({
paste("Genome selected:", input$GenomeSelect)
})
check_chr <- reactive({
chr <- input$ref_chr
return(chr)
})
check_bases <- reactive({
bases <- input$ref_bases
return(bases)
})
convert_dbs <- reactive({
conv_dbs <- input$convert_dbs
return(conv_dbs)
})
stand_indels <- reactive({
stand_indels <- input$stand_indels
return(stand_indels)
})
#Adding the create musica funcionality
tryCatch({
observeEvent(input$get_musica_object, {
shinybusy::show_spinner()
vals$genome <- input$GenomeSelect
if (!is.null(vals$var)) {
vals$musica <- create_musica_from_variants(x = vals$var,
genome = select_genome(vals$genome),
check_ref_chromosomes = check_chr(),
check_ref_bases = check_bases(),
convert_dbs = convert_dbs(),
standardize_indels = stand_indels())
if (req(input$get_musica_object)) {
shinyjs::show(id = "download_musica")
}
else {
shinyjs::hide(id = "download_musica")
}
shinybusy::hide_spinner()
showNotification("Musica Object successfully created! ")
}
else{
shinyalert("Error: Please import files first in the Import section!")
}
})},
error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
},
warning = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
})
output$musica_console <- renderPrint({
return(print(vals$musica_message))
})
#Displaying musica object variants
output$musica_contents <- DT::renderDT({
req(vals$var)
return(head(vals$var))
shinyjs::show(id = "musica_contents")
js$enableTabs()
})
output$musica_contents_summary <- renderText({
req(vals$musica)
vt <- unique(vals$musica@variants$Variant_Type) #variant types
ns <- length(vals$musica@variants$sample) #sample length
mylist <- c("No. of Samples:\n", ns)
return(mylist)
shinyjs::show(id = "musica_contents_summary")
js$enableTabs();
})
output$musica_contents_table <- DT::renderDT({
req(vals$musica)
nvt <- as.data.frame(table(vals$musica@variants$Variant_Type))
return(nvt)
shinyjs::show(id = "musica_contents_table")
js$enableTabs();
})
#Adding resetting functionality
observeEvent(input$reset, {
removeUI("#musica_contents")
removeUI("#musica_contents_summary")
removeUI("#musica_contents_table")
showNotification("Tables cleared!")
})
#Adding upload musica tab functionality
observe(
if (!is.null(req(input$musica_file))) {
vals$musica_name_user <- tools::file_path_sans_ext(input$musica_file$name)
})
#output$musica_result_name <- renderUI(
# textInput("musica_result_name", value = paste0(vals$musica_name_user),
# h3("Name your musica result object:"))
#)
#observeEvent(input$musica_button, {
# if (input$musica_button == "result") {
# shinyjs::show(id = "musica_result_name")
# }
# else if (input$musica_button == "object") {
# shinyjs::hide(id = "musica_result_name")
# }
#})
observeEvent(input$upload_musica, {
req(input$musica_file)
if (all(tools::file_ext(tolower(input$musica_file$name)) !=
c("rda", "rds"))) {
shinyalert::shinyalert(paste0("Error: File format not supported! ",
"Please upload .rda or .rds files"))
}
else{
#if (input$musica_button == "result") {
# if (all(tools::file_ext(tolower(input$musica_file$name)) == "rda")) {
# vals$musica_upload <- load(input$musica_file$datapath)
# vals$musica_upload <- get(vals$musica_upload)
# vals$result_objects[[input$musica_result_name]] <- vals$musica_upload
# }
# else if (all(tools::file_ext(tolower(input$musica_file$name)) ==
# "rds")) {
# vals$musica_upload <- readRDS(input$musica_file$datapath)
# vals$result_objects[[input$musica_result_name]] <- vals$musica_upload
# }
# showNotification("Musica Result Object successfully imported!")
#}
#else if (input$musica_button == "object") {
if (all(tools::file_ext(tolower(input$musica_file$name)) ==
"rda")) {
vals$musica_upload <- load(input$musica_file$datapath)
vals$musica_upload <- get(vals$musica_upload)
vals$musica <- vals$musica_upload
}
else if (all(tools::file_ext(tolower(input$musica_file$name)) ==
"rds")) {
vals$musica_upload <- readRDS(input$musica_file$datapath)
vals$musica <- vals$musica_upload
}
# check if any result objects present
if (length(result_list(vals$musica)) > 0){
for (result_name in names(result_list(vals$musica))){
vals$res_names_full[[result_name]] <- list()
for (modality in names(get_result_list_entry(vals$musica, result_name)@modality)){
vals$res_names_full[[result_name]][[modality]] <- NULL
for (model in names(get_modality(vals$musica, result_name, modality))){
vals$res_names_full[[result_name]][[modality]] <- c(vals$res_names_full[[result_name]][[modality]], model)
vals$res_names <- c(vals$res_names, paste0(result_name, "/", modality, "/", model))
}
}
}
}
vals$var <- variants(vals$musica)
showNotification("Musica Object successfully imported!")
}}
# }
)
#Displaying musica result/object summary table
output$musica_upload <- DT::renderDT({
req(vals$musica_upload)
#if(input$musica_button == "result")
# {return(head(vals$musica_upload@musica@variants))
#}else{
return(head(vals$musica_upload@variants))
# }
shinyjs::show(id = "musica_upload")
js$enableTabs();
})
output$musica_upload_summary <- renderText({
req(vals$musica_upload)
#if(input$musica_button == "result"){
#vt <- unique(vals$musica_upload@musica@variants$Variant_Type) #variant types
#nvt <- table(vals$musica_upload@musica@variants$Variant_Type)
#ns <- length(vals$musica_upload@musica@variants$sample) #sample length
#mylist <- c("No. of Samples:\n", ns, "\n", "Variant types", vt, "\n", nvt)
#return(mylist)
#}else{
vt <- unique(vals$musica_upload@variants$Variant_Type) #variant types
nvt <- table(vals$musica_upload@variants$Variant_Type)
ns <- length(vals$musica_upload@variants$sample) #sample length
mylist <- c("No. of Samples:\n", ns, "\n", "Variant types", vt, "\n", nvt)
return(mylist)
#}
shinyjs::show(id = "musica_upload_summary")
js$enableTabs();
})
observeEvent(input$reset_musica, {
removeUI("#musica_upload")
removeUI("#musica_upload_summary")
showNotification("Tables cleared!")
})
#Adding download feature
output$download_musica <- downloadHandler(
filename = function() {
paste("musica_variants", ".csv", sep = "")
},
content = function(file) {
write.csv(vals$musica@variants, file, row.names = FALSE)
}
)
#output$download_musica_result <- downloadHandler(
# filename = function() {
# paste("musica_variants", ".csv", sep = "")
# },
# content = function(file) {
# if(input$musica_button == "result"){
# write.csv(vals$musica_upload@musica@variants, file, row.names = FALSE)
# }else{
# write.csv(vals$musica_upload@variants, file, row.names = FALSE)
# }
# }
#)
output$download_musica_object <- downloadHandler(
filename = function() {
paste("musica_object", ".rda", sep = "")
},
content = function(file) {
save(as.data.frame(vals$musica), file = filename)
}
)
observeEvent(input$upload, {
# Clear the previous deletions in the import table in the Import files tab
vals$files <- list(input$file[["name"]])
vals$files <- unlist(vals$files)
vals$files <- c(vals$files)
dt <- list(input$file[["datapath"]])
dt <- unlist(dt)
dt <- c(dt)
vals$files <- data.frame(files = vals$files, datapath = dt,
stringsAsFactors = FALSE)
vals$data <- vals$files
vals$deleted_rows <- NULL
vals$deleted_row_indices <- list()
})
observeEvent(input$example, {
#vals$files <- list(system.file("extdata", "public_LUAD_TCGA-97-7938.vcf",
# package = "musicatk"))
#vals$files <- "public_TCGA.LUSC.maf"
#dt <- system.file("extdata", "public_TCGA.LUSC.maf", package = "musicatk")
#vals$files <- data.frame(files = vals$files, datapath = dt,
# stringsAsFactors = FALSE)
#vals$data <- vals$files
#vals$deleted_rows <- NULL
#vals$deleted_row_indices <- list()
shinybusy::show_spinner()
#vars <- extract_variants_from_maf_file(system.file("extdata", "public_TCGA.LUSC.maf", package = "musicatk"))
#vals$var <- vars
data(musica_annot)
vals$musica <- musica_annot
vals$var <- vals$musica@variants
shinybusy::hide_spinner()
showNotification("Example musica object imported. Proceed to discovery/prediction.")
})
observeEvent(input$deletep_ressed, {
row_num <- parse_delete_event(input$deletep_ressed)
data_row <- vals$data[row_num, ]
vals$deleted_rows <- rbind(data_row, vals$deleted_rows)
vals$deleted_row_indices <- append(vals$deleted_row_indices,
row_num, after = 0)
# Delete the row from the data frame
vals$data <- vals$data[-row_num, ]
})
observeEvent(input$undo, {
if (nrow(vals$deleted_rows) > 0) {
row <- vals$deleted_rows[1, ]
vals$data <- add_row_at(vals$data, row, vals$deleted_row_indices[[1]])
# Remove row
vals$deleted_rows <- vals$deleted_rows[-1, ]
# Remove index
vals$deleted_row_indices <- vals$deleted_row_indices[-1]
}
})
#Disable the undo button if we have not deleted anything
output$undo_ui <- renderUI({
if (!is.null(vals$deleted_rows) && nrow(vals$deleted_rows) > 0) {
actionButton("undo", label = "Undo delete", icon("undo"))
} else {
actionButton("undo", label = "Undo delete", icon("undo"), disabled = TRUE)
}
})
output$dtable <- DT::renderDT({
# Add the delete button column
req(vals$data)
delete_button_column(vals$data, "delete_button")
})
#Code taken from an online open source
#' Adds a row at a specified index
#'
#' @param df a data frame
#' @param row a row with the same columns as \code{df}
#' @param i the index we want to add row at.
#' @return the data frame with \code{row} added to \code{df} at index \code{i}
add_row_at <- function(df, row, i) {
if (i > 1) {
rbind(df[1:(i - 1), ], row, df[- (1:(i - 1)), ])
} else {
rbind(row, df)
}
}
#' A column of delete buttons for each row in the data frame for the
#' first column
#'
#' @param df data frame
#' @param id id prefix to add to each actionButton. The buttons will be
#' id'd as id_INDEX.
#' @return A DT::datatable with escaping turned off that has the delete
#' buttons in the first column and \code{df} in the other
delete_button_column <- function(df, id, ...) {
# function to create one action button as string
f <- function(i) {
# https://shiny.rstudio.com/articles/communicating-with-js.html
as.character(actionButton(paste(id, i, sep = "_"), label = NULL,
icon = icon("trash"),
onclick =
paste('Shiny.setInputValue(\"deletep_ressed\",',
'this.id, {priority: "event"})')))
}
delete_col <- unlist(lapply(seq(nrow(df)), f))
# Return a data table
DT::datatable(cbind(delete = delete_col, df),
# Need to disable escaping for html as string to work
escape = FALSE,
options = list(
# Disable sorting for the delete column
columnDefs = list(list(targets = 1, sortable = FALSE))
))
}
#' Extracts the row id number from the id string
#' @param idstr the id string formated as id_INDEX
#' @return INDEX from the id string id_INDEX
parse_delete_event <- function(idstr) {
res <- as.integer(sub(".*_([0-9]+)", "\\1", idstr))
if (! is.na(res)) res
}
###############################################################################
###################### Nathan's Code ##########################################
# rep_range needed for SBS192 replication strand
data(rep_range)
# needed to predict cosmic sigs
data("cosmic_v2_sigs")
data("cosmic_v3_sbs_sigs")
data("cosmic_v3_dbs_sigs")
data("cosmic_v3_indel_sigs")
# Renaming COSMIC signatures.
sbs_aet <- list("SBS1" =
"SBS1 - Spontaneous deamination of 5-methylcytosine",
"SBS2" = "SBS2 - APOBEC activity",
"SBS3" = "SBS3 - HR deficiency",
"SBS4" = "SBS4 - Tobacco smoking",
"SBS5" =
"SBS5 - Unknown (Aging / Tobacco smoking / NER deficiency)",
"SBS6" = "SBS6 - MMR deficiency",
"SBS7a" = "SBS7a - UV light exposure",
"SBS7b" = "SBS7b - UV light exposure",
"SBS7c" = "SBS7c - UV light exposure",
"SBS7d" = "SBS7d - UV light exposure",
"SBS8" = "SBS8 - Unknown (HR deficiency / NER deficiency)",
"SBS9" =
"SBS9 - Unknown (Polymerase eta somatic hypermutation)",
"SBS10a" = "SBS10a - POLE exonuclease domain mutation",
"SBS10b" = "SBS10b - POLE exonuclease domain mutation",
"SBS10c" = "SBS10c - Unknown (Defective POLD1 proofreading)",
"SBS10d" = "SBS10d - Unknown (Defective POLD1 proofreading)",
"SBS11" =
paste0("SBS11 - Unknown (Temozolomide chemotherapy ",
"/ MMR deficiency + temozolomide)"),
"SBS12" = "SBS12 - Unknown",
"SBS13" = "SBS13 - APOBEC activity",
"SBS14" = "SBS14 - MMR deficiency + POLE mutation",
"SBS15" = "SBS15 - MMR deficiency",
"SBS16" = "SBS16 - Unknown",
"SBS17a" = "SBS17a - Unknown (Damage by ROS)",
"SBS17b" =
"SBS17b - Unknown (Damage by ROS / 5FU chemotherapy)",
"SBS18" = "SBS18 - Damage by ROS",
"SBS19" = "SBS19 - Unknown",
"SBS20" = "SBS20 - MMR deficiency + POLD1 mutation",
"SBS21" = "SBS21 - MMR deficiency",
"SBS22" = "SBS22 - Aristolochic acid exposure",
"SBS23" = "SBS23 - Unknown",
"SBS24" = "SBS24 - Aflatoxin exposure",
"SBS25" = "SBS25 - Unknown (Unknown chemotherapy)",
"SBS26" = "SBS26 - MMR deficiency",
"SBS27" = "SBS27 - Sequencing artifact",
"SBS28" =
"SBS28 - Unknown (POLE exonuclease domain mutation)",
"SBS29" = "SBS29 - Unknown (Tobacco chewing)",
"SBS30" = "SBS30 - BER deficiency",
"SBS31" = "SBS31 - Platinum chemotherapy",
"SBS32" = "SBS32 - Azathioprine exposure",
"SBS33" = "SBS33 - Unknown (Unknown)",
"SBS34" = "SBS34 - Unknown",
"SBS35" = "SBS35 - Platinum chemotherapy",
"SBS36" = "SBS36 - BER deficiency",
"SBS37" = "SBS37 - Unknown",
"SBS38" =
"SBS38 - Unknown (UV light exposure (indirect effect))",
"SBS39" = "SBS39 - Unknown",
"SBS40" = "SBS40 - Unknown",
"SBS41" = "SBS41 - Unknown",
"SBS42" = "SBS42 - Haloalkanes exposure",
"SBS43" = "SBS43 - Unknown (Possible sequencing artifact)",
"SBS44" = "SBS44 - MMR deficiency",
"SBS45" =
"SBS45 - 8-oxo-guanine introduced during sequencing",
"SBS46" =
"SBS46 - Sequencing artifact (early releases of TCGA)",
"SBS47" =
paste0("SBS47 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS48" =
paste0("SBS48 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS49" =
paste0("SBS49 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS50" =
paste0("SBS50 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS51" = "SBS51 - Unknown (Possible sequencing artifact)",
"SBS52" =
paste0("SBS52 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS53" =
paste0("SBS53 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS54" = "SBS54 - Germline variants contamination",
"SBS55" = "SBS55 - Unknown (Possible sequencing artifact)",
"SBS56" = "SBS56 - Unknown (Possible sequencing artifact)",
"SBS57" = "SBS57 - Unknown (Possible sequencing artifact)",
"SBS58" = "SBS58 - Unknown (Possible sequencing artifact)",
"SBS59" = "SBS59 - Unknown (Possible sequencing artifact)",
"SBS60" = "SBS60 - Sequencing artifact",
"SBS84" = "SBS84 - AID activity",
"SBS85" = "SBS85 - AID activity",
"SBS86" = "SBS86 - Unkown (Unknown chemotherapy)",
"SBS87" = "SBS87 - Thiopurine chemotherapy",
"SBS88" = "SBS88 - Colibactin exposure",
"SBS89" = "SBS89 - Unknown",
"SBS90" = "SBS90 - Duocarmycin exposure",
"SBS91" = "SBS91 - Unknown",
"SBS92" = "SBS92 - Unknown (Tobacco smoking)",
"SBS93" = "SBS93 - Unknown",
"SBS94" = "SBS94 - Unknown"
)
dbs_aet <- list("DBS1" = "DBS1 - UV light exposure",
"DBS2" =
"DBS2 - Unknown (Tobacco smoking / Acetaldehyde exposure)",
"DBS3" = "DBS3 - POLE exonuclease domain mutation",
"DBS4" = "DBS4 - Unknown",
"DBS5" = "DBS5 - Platinum chemotherapy",
"DBS6" = "DBS6 - Unknown",
"DBS7" = "DBS7 - MMR deficiency",
"DBS8" = "DBS8 - Unknown",
"DBS9" = "DBS9 - Unknown",
"DBS10" = "DBS10 - MMR deficiency",
"DBS11" = "DBS11 - Unknown (APOBEC activity)"
)
indel_aet <- list("ID1" =
"ID1 - Slippage of nascent strand during DNA replication",
"ID2" =
paste0("ID2 - Slippage of template strand during ",
"DNA replication"),
"ID3" = "ID3 - Tobacco smoking",
"ID4" = "ID4 - Unknown",
"ID5" = "ID5 - Unknown",
"ID6" = "ID6 - HR deficiency",
"ID7" = "ID7 - MMR deficiency",
"ID8" =
"ID8 - Unknown (DSB repair by NHEJ / TOP2A mutation)",
"ID9" = "ID9 - Unknown",
"ID10" = "ID10 - Unknown",
"ID11" = "ID11 - Unknown",
"ID12" = "ID12 - Unknown",
"ID13" = "ID13 - UV light exposure",
"ID14" = "ID14 - Unknown",
"ID15" = "ID15 - Unknown",
"ID16" = "ID16 - Unknown",
"ID17" = "ID17 - TOP2A mutation",
"ID18" = "ID18 - Colibactin exposure"
)
colnames(signatures(cosmic_v3_sbs_sigs)) <-
sbs_aet[colnames(signatures(cosmic_v3_sbs_sigs))]
colnames(signatures(cosmic_v3_dbs_sigs)) <-
dbs_aet[colnames(signatures(cosmic_v3_dbs_sigs))]
colnames(signatures(cosmic_v3_indel_sigs)) <-
indel_aet[colnames(signatures(cosmic_v3_indel_sigs))]
cosmic_objects <- list("cosmic_v3_sbs_sigs" = cosmic_v3_sbs_sigs,
"cosmic_v3_dbs_sigs" = cosmic_v3_dbs_sigs,
"cosmic_v3_indel_sigs" = cosmic_v3_indel_sigs,
"cosmic_v2_sigs" = cosmic_v2_sigs)
# Update musica object list whenever a result or musica object is altered
output$annotation_musica_list <- renderUI({
#result_names <- list(names(vals$result_objects))
#if (is.null(vals$musica)) {
# tagList(
# selectInput("annotation_musica_list", "Select object",
# choices = list("result objects" =
# list(names(vals$result_objects))))
# )
#} else if (is.null(result_names[[1]])) {
tagList(
selectInput("annotation_musica_list", "Select object",
choices = list("musica object" = list("musica")))
)
#}
#else {
# tagList(
# selectInput("annotation_musica_list", "Select object",
# choices = list("musica object" = list("musica"),
# "result objects" =
# list(names(vals$result_objects))))
# )
#}
})
# Input to choose the annotation delimiter.
observeEvent(input$annotation_delimiter, {
if (input$annotation_delimiter == "custom") {
shinyjs::show(id = "CustomAnnotDelim")
} else {
shinyjs::hide(id = "CustomAnnotDelim")
}
})
# Read the annotation file, store it in vals$annotations, and display the
# contents as a data table.
output$annotations <- DT::renderDT({
file <- input$annotations_file
ext <- tools::file_ext(file$datapath)
req(file)
delim <- input$annotation_delimiter
if (delim == "custom") {
delim <- input$CustomAnnotDelim
}
vals$annotations <- read.delim(file$datapath,
header = input$annotation_header,
sep = delim,
as.is = TRUE)
vals$annotations
}, options = list(autoWidth = FALSE, scrollX = TRUE))
# Input to choose the column containing the sample names.
output$annotation_samples <- renderUI({
if (is.null(vals$annotations)) {
return(NULL)
}
tagList(
selectInput("annot_sample_column", "Sample Name Column",
choices = colnames(vals$annotations))
)
})
# Add annotations to the provided musica_object
add_annot <- function(musica_object) {
new_annot <- merge(samp_annot(musica_object),
vals$annotations, by.x = "Samples",
by.y = input$annot_sample_column,
all.x = TRUE)
for (a in names(new_annot)) {
samp_annot(musica_object, a) <-
new_annot[, a]
}
showNotification("Annotations have been added")
return(musica_object)
}
# Event that triggers add_annotation function.
observeEvent(input$add_annotation, {
# Add annotation to result object
#if (!is.null(get_result(input$annotation_musica_list))) {
# tryCatch({
# vals$result_objects[[input$annotation_musica_list]] <-
# add_annot(vals$result_objects[[input$annotation_musica_list]])
# }, error = function(cond) {
# shinyalert::shinyalert(title = "Error", text = cond$message)
# return()
# })
# Add annotation to musica object
if (!is.null(vals$musica)) {
tryCatch({
vals$musica <- add_annot(vals$musica)
}, error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
return()
})
} else {
print("Error: selected object does not exist")
}
})
####### Section for the Build Table Tab #######
# Input to select count table
output$discover_table <- renderUI({
tagList(
selectInput("select_discover_table", "Select Modality",
choices = names(
extract_count_tables(vals$musica))),
bsTooltip("select_discover_table",
"Modality to use for signature discovery.",
placement = "right", trigger = "hover", options = NULL)
)
})
# UI for inputs to combine tables.
output$combine_table <- renderUI({
if (length(names(extract_count_tables(vals$musica))) > 1) {
tagList(
box(width = 6,
helpText(paste0("Combine any 2 or more tables contained in your ",
"musica object. This is optional.")),
checkboxGroupInput("combine_tables", "Tables to Combine",
choices = names(extract_count_tables(vals$musica))),
textInput("combined_table_name", "Name of combined table"),
uiOutput("combine_warning"),
actionButton("Combine", "Build Combined Table"),
bsTooltip("combined_table_name",
"Combine tables into a single table that can be used for
discovery/prediction.",
placement = "bottom", trigger = "hover", options = NULL),
bsTooltip("Combine",
paste0("Combines tables into a single table that can ",
"be used for discovery/prediction."),
placement = "bottom", trigger = "hover", options = NULL),
bsTooltip("combine_tables",
"Tables to combine.",
placement = "left", trigger = "hover", options = NULL),
bsTooltip("combined_table_name",
"Name for the combined table.",
placement = "bottom", trigger = "hover", options = NULL)
)
)
}
})
#
observeEvent(input$Combine, {
if (input$combined_table_name == "" | length(input$combine_tables) < 2) {
output$combine_warning <- renderText({
validate(
need(input$combined_table_name != "",
"You must provide a name for the new result object."),
need(length(input$combine_tables) < 2,
"You must select two or more tables to combine.")
)
})
return()
}
shinybusy::show_spinner()
tryCatch({
combine_count_tables(vals$musica, input$combine_tables,
input$combined_table_name)
}, error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
shinybusy::hide_spinner()
})
shinybusy::hide_spinner()
showNotification("Table created.")
})
output$allow_table <- renderUI({
if (!is.null(vals$musica)) {
tagList(
actionButton("add_table", "Create Table"),
bsTooltip("add_table",
paste0("Create a table containig the mutationl count ",
"information of each sample."),
placement = "bottom", trigger = "hover",
options = NULL)
)
} else {
tagList(
helpText("You must first create or upload a musica object to generate
count tables.")
)
}
})
# Event listener for add table button.
observeEvent(input$add_table, {
table_name <- input$select_table
if (table_name == "SBS192 - Replication_Strand") {
table_name <- "SBS192_Rep"
}
if (table_name == "SBS192 - Transcript_Strand") {
table_name <- "SBS192_Trans"
}
if (table_name %in% names(extract_count_tables(vals$musica))) {
# Modal to confirm overwrite of existing table
showModal(modalDialog(
title = "Existing Table.",
"Do you want to overwrite the existing table?",
easyClose = TRUE,
footer = list(
actionButton("confirmOverwrite", "OK"),
modalButton("Cancel"))
))
} else{
add_tables(input, vals)
}
})
# Function used in server.R to add counts tables.
add_tables <- function(input, vals) {
table_name <- input$select_table
strand_type <- NULL
if (input$select_table != "Custom") {
# Check inputs for SBS192
if (input$select_table == "SBS192 - Transcript_Strand") {
annotate_transcript_strand(vals$musica, input$table_genome_list,
build_table = FALSE)
table_name <- "SBS192"
strand_type <- "Transcript_Strand"
}
if (input$select_table == "SBS192 - Replication_Strand") {
annotate_replication_strand(vals$musica, rep_range, build_table = FALSE)
table_name <- "SBS192"
strand_type <- "Replication_Strand"
}
tryCatch({
build_standard_table(vals$musica,
select_genome(input$table_genome_list),
modality = table_name,
strand_type = strand_type,
overwrite = TRUE)
shiny::showNotification("Table created.")
}, error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
}
)
return()
}
shinyalert::shinyalert(title = "Oops",
text = "Custom tables are not yet supported.")
}
# Confirm overwrite for existing table
observeEvent(input$confirmOverwrite, {
removeModal()
add_tables(input, vals)
})
####### Section for the Discover Signatures and Exposures Tab #######
# Event listener for discover_signatures.
observeEvent(input$discover_signatures, {
if (input$discover_result_name == "" |
input$discover_model_name == "" |
input$number_of_signatures == "" |
input$n_start == "" |
dim(extract_count_tables(vals$musica)[[
input$select_discover_table]]@count_table)[2] < 2 |
input$number_of_signatures < 2) {
output$discover_warning <- renderText({
validate(
need(input$discover_result_name != "",
"You must provide a result list name."),
need(input$discover_model_name != "",
"You must provide a model ID."),
need(input$number_of_signatures != "",
"You must specify the number of expected signatures."),
need(input$n_start != "",
"Please specify the number of random starts."),
need(input$number_of_signatures >= 2,
"Must specify 2 or more signatures."),
need(dim(extract_count_tables(vals$musica)[[
input$select_discover_table]]@count_table)[2] > 2,
"You must provide 2 or more samples")
)
})
return()
}
if (paste0(input$discover_result_name, "/", input$select_discover_table, "/", input$discover_model_name) %in% names(vals$res_names)) {
#if ("lda5" %in% names(vals$result_objects)) {
# Confirm overwrite of result object
showModal(modalDialog(
title = "This model ID already exists in the chosen result list entry.",
"Do you want to overwrite the existing result?",
easyClose = TRUE,
footer = list(
actionButton("confirm_result_overwrite", "OK"),
modalButton("Cancel"))
))
} else {
disc_sigs(input, vals)
showNotification(paste0("Disocvery, ",
input$discover_model_name,
", completed and saved to ",
input$discover_result_name, "."))
}
})
# Wrapper function for discover_signature
disc_sigs <- function(input, vals) {
name <- paste0(input$discover_result_name, "/", input$select_discover_table, "/", input$discover_model_name)
vals$musica <- discover_signatures(
vals$musica, modality = input$select_discover_table,
num_signatures = as.numeric(input$number_of_signatures),
algorithm = input$Method, result_name = input$discover_result_name,
model_id = input$discover_model_name,
#seed = input$Seed,
nstart = as.numeric(input$n_start), make_copy = TRUE)
#set_result(name, "test")
vals$res_names <- c(vals$res_names, name)
vals$res_names_full[[input$discover_result_name]][[input$select_discover_table]] <-
c(vals$res_names_full[[input$discover_result_name]][[input$select_discover_table]],
input$discover_model_name)
}
# Run discover_signatures if overwrite confirmed.
observeEvent(input$confirm_result_overwrite, {
removeModal()
disc_sigs(input, vals)
showNotification("Existing result overwritten.")
})
# Discover Musica Result Object
output$discover_result_name <- renderUI({
#name <- input$select_discover_table
tagList(
textInput("discover_result_name", "Name of result list entry to save result",
value = "result"),
bsTooltip("discover_result_name",
"Which result list entry the discovery results will be stored in.",
placement = "right", trigger = "hover", options = NULL)
)
})
output$discover_model_name <- renderUI({
#name <- input$select_discover_table
tagList(
textInput("discover_model_name", "Model ID for the result",
value = paste0(input$Method, input$number_of_signatures)),
bsTooltip("discover_model_name",
"An identifier for the discovery result.",
placement = "right", trigger = "hover", options = NULL)
)
})
# UI to select musica object.
#output$discover_musica_list <- renderUI({
# tagList(
# selectInput("discover_musica_list", h3("Select Musica Object"),
# choices = names(vals$result_objects))
# )
#})
# Select counts table for prediction.
output$predict_table <- renderUI({
tagList(
selectInput("predict_table", "Select Modality",
choices = names(extract_count_tables(vals$musica))),
bsTooltip("predict_table",
"Modality used for posterior prediction",
placement = "right", trigger = "hover", options = NULL)
)
})
# Event listener alters UI based on selected COSMIC table.
#observeEvent(input$predict_table, {
# if (input$predict_table == "SBS96") {
# shinyjs::show(id = "cosmic_SBS_sigs")
# shinyjs::hide(id = "cosmic_DBS_sigs")
# shinyjs::hide(id = "cosmic_INDEL_sigs")
# } else if (input$predict_table == "DBS78") {
# shinyjs::hide(id = "cosmic_SBS_sigs")
# shinyjs::show(id = "cosmic_DBS_sigs")
# shinyjs::hide(id = "cosmic_INDEL_sigs")
# } else {
# shinyjs::hide(id = "cosmic_SBS_sigs")
# shinyjs::hide(id = "cosmic_DBS_sigs")
# shinyjs::show(id = "cosmic_INDEL_sigs")
# }
#})
# UI to name Predict result object
output$predict_result_name <- renderUI({
#name <- names(extract_count_tables(vals$musica))[1]
tagList(
textInput("predict_result_name", "Name of result list entry to save result",
value = "result"),
bsTooltip("predict_result_name",
"Which result list entry the discovery results will be stored in.",
placement = "right", trigger = "hover", options = NULL)
)
})
output$predict_model_name <- renderUI({
tagList(
textInput("predict_model_name", "Model ID for the result",
value = paste0(input$Method, length(input$pred_sigs), "_exp_pred")),
bsTooltip("predict_model_name",
"An identifier for the prediction result.",
placement = "right", trigger = "hover", options = NULL)
)
})
# UI to select which result objects to predict.
output$predicted_result <- renderUI({
other <- vals$res_names
if (is.null(other)) {
tagList(
selectInput("predicted_result", "Result to Predict",
choices = list("Cosmic" = list(
"Cosmic V3 SBS Signatures" = "cosmic_v3_sbs_sigs",
"Cosmic V3 DBS Signatures" = "cosmic_v3_dbs_sigs",
"Cosmic V3 INDEL Signatures" = "cosmic_v3_indel_sigs",
"Cosmic V2 Signatures" = "cosmic_v2_sigs"
)),
selected = "cosmic_v3_sbs_sigs"),
bsTooltip("predicted_result",
"Result model object containing the signatures to predict.
Can use existing COSMIC signatures or signatures from a
previously generated result_model object.",
placement = "right", trigger = "hover", options = NULL)
) }
else {
tagList(
selectInput("predicted_result", "Result to Predict",
choices = list("Cosmic" = list(
"Cosmic V3 SBS Signatures" = "cosmic_v3_sbs_sigs",
"Cosmic V3 DBS Signatures" = "cosmic_v3_dbs_sigs",
"Cosmic V3 INDEL Signatures" = "cosmic_v3_indel_sigs",
"Cosmic V2 Signatures" = "cosmic_v2_sigs"),
"your signatures" = as.list(other)),
selected = "cosmic_v3_sbs_sigs"),
#bsTooltip("predicted_result",
# "Result model object containing the signatures to predict.
# Can use existing COSMIC signatures or signatures from a
# previously generated result_model object.",
# placement = "right", trigger = "hover", options = NULL)
)
}
})
# UI to select signatures to predict
observeEvent(input$predicted_result, {
output$predicted_signatures <- renderUI({
if (input$predicted_result %in% names(cosmic_objects)) {
vals$p_sigs <- colnames(signatures(
cosmic_objects[[input$predicted_result]]))
vals$p_res <- cosmic_objects[[input$predicted_result]]
}
else {
identifiers <- strsplit(input$predicted_result, "/")[[1]]
vals$p_sigs <- colnames(signatures(vals$musica, identifiers[1], identifiers[2], identifiers[3]))
#vals$p_sigs <- colnames(signatures(
# vals$result_objects[[input$predicted_result]]))
vals$p_res <- get_model(vals$musica, identifiers[1], identifiers[2], identifiers[3])
#vals$p_res <- vals$result_objects[[input$predicted_result]]
}
tagList(
shinyWidgets::dropdownButton(circle = FALSE, label = "Signatures",
div(style =
"max-height:80vh; overflow-y: scroll",
checkboxGroupInput("pred_sigs", "",
choices = vals$p_sigs, inline = FALSE,
selected = vals$p_sigs))),
bsTooltip("predicted_signatures",
"Signatures to predict.",
placement = "right", trigger = "hover", options = NULL),
bsTooltip("predicted_result",
"Result model object containing the signatures to predict.
Can use existing COSMIC signatures or signatures from a
previously generated result_model object.",
placement = "right", trigger = "hover", options = NULL)
)
})
})
# Event listener for Predict signatures
observeEvent(input$predict_sigs, {
if (input$predict_result_name == "" |
input$predict_model_name == "" |
length(input$pred_sigs) < 2) {
output$predict_warning <- renderText({
validate(
need(input$predict_result_name != "",
"You must provide a result list name."),
need(input$predict_model_name != "",
"You must provide a model ID."),
need(length(c(input$pred_sigs)) >= 2,
"You must select two or more signatures to predict.")
)
})
return()
}
if (paste0(input$predict_result_name, "/", input$predict_table,
"/", input$predict_model_name) %in% names(vals$res_names)) {
#if (input$predict_result_name %in% names(vals$result_objects)) {
showModal(modalDialog(
title = "This model ID already exists in the chosen result list entry.",
"Do you want to overwrite the existing result object?",
easyClose = TRUE,
footer = list(
actionButton("confirm_predict_overwrite", "OK"),
modalButton("Cancel"))
))
} else {
get_predict(input, vals)
showNotification(paste0("Prediction, ",
input$predict_model_name,
", completed and saved to ",
input$predict_result_name, "."))
}
})
# Event listener displays additional options for deconstructSigs algorithm.
#observeEvent(input$predict_algorithm, {
# if (input$predict_algorithm == "deconstructSigs") {
# shinyjs::show(id = "predict_genome_list")
# } else {
# shinyjs::hide(id = "predict_genome_list")
# }
#})
# Wrapper function for predict_exposures
get_predict <- function(inputs, vals) {
name <- paste0(input$predict_result_name, "/", input$predict_table, "/", input$predict_model_name)
vals$musica <- predict_exposure(
vals$musica,
modality = input$predict_table,
signature_res = vals$p_res,
algorithm = input$predict_algorithm,
result_name = input$predict_result_name,
model_id = input$predict_model_name,
signatures_to_use = input$pred_sigs,
make_copy = TRUE)
#set_result(name, "test")
vals$res_names <- c(vals$res_names, name)
vals$res_names_full[[input$predict_result_name]][[input$predict_table]] <-
c(vals$res_names_full[[input$predict_result_name]][[input$predict_table]],
input$predict_model_name)
}
# Event triggers predict_exposures when user confirms overwrite.
observeEvent(input$confirm_predict_overwrite, {
removeModal()
get_predict(input, vals)
showNotification("Existing result overwritten.")
})
####### Compare Tab ########
observeEvent(input$cosmic_button, {
if (input$cosmic_button == "cosmic") {
shinyjs::hide(id = "compare_result_b")
shinyjs::hide(id = "compare_model_b")
shinyjs::show(id = "compare_result_b_cosmic")
}
else if (input$cosmic_button == "model") {
shinyjs::show(id = "compare_result_b")
shinyjs::show(id = "compare_model_b")
shinyjs::hide(id = "compare_result_b_cosmic")
}
})
output$compare_result_a <- renderUI({
tagList(
selectInput("select_result_a", "Select result list name",
choices = c(names(vals$res_names_full))),
bsTooltip("select_result_a",
"A result list name",
placement = "right", trigger = "hover", options = NULL)
)
})
observeEvent(input$select_result_a, {
output$compare_modality_a <- renderUI({
tagList(
selectInput("select_modality_a", "Select modality",
choices = c(names(vals$res_names_full[[input$select_result_a]]))),
bsTooltip("select_modality_a",
"A modality",
placement = "right", trigger = "hover", options = NULL)
)
})
})
observeEvent(input$select_modality_a, {
output$compare_model_a <- renderUI({
tagList(
selectInput("select_model_a", "Select model ID",
choices = c("", vals$res_names_full[[input$select_result_a]][[input$select_modality_a]]),
selected = NULL),
bsTooltip("select_model_a",
"A model ID",
placement = "right", trigger = "hover", options = NULL)
)
})
})
observeEvent(input$cosmic_button, {
if (input$cosmic_button == "model") {
observeEvent(input$select_modality_a, {
output$compare_result_b <- renderUI({
tagList(
selectInput("select_result_b", "Select comparison result list name",
#choices = list("cosmic signatures" =
# as.list(names(cosmic_objects)),
# "your signatures" = as.list(
# names(vals$result_objects)))),
choices = c(names(vals$res_names_full)),
selected = input$select_result_a),
bsTooltip("select_result_b",
"Result list name for other model being compared",
placement = "right", trigger = "hover", options = NULL)
)
})
})
observeEvent(input$select_result_b, {
output$compare_model_b <- renderUI({
tagList(
selectInput("select_model_b", "Select model ID",
choices = c("", vals$res_names_full[[input$select_result_b]][[input$select_modality_a]]),
selected = NULL),
bsTooltip("select_model_a",
"A model ID",
placement = "right", trigger = "hover", options = NULL)
)
})
})
}
else{
output$compare_result_b_cosmic <- renderUI({
tagList(
selectInput("select_result_b_cosmic", "Select Cosmic",
choices = as.list(names(cosmic_objects))),
bsTooltip("select_result_b_cosmic",
"Cosmic database to compare to",
placement = "right", trigger = "hover", options = NULL)
)
})
}
})
# Event listener triggers comparison.
observeEvent(input$compare_results, {
if (is.null(input$select_result_a) | input$select_result_a == "" |
input$select_model_a == "" |
input$Threshold == "") {
output$compare_validate <- renderText({
validate(
need(input$select_result_a != "",
"Please select a result object to compare."),
need(input$select_model_a != "",
"Please select a model ID to compare."),
need(input$Threshold == "",
"Please provide a similarity threshold from 0 to 1.")
)
})
return()
}
# Retreive either cosmic or custom result objects.
#if (input$select_result_b %in% names(cosmic_objects)) {
# other <- cosmic_objects[[input$select_result_b]]
#} else {
# other <- isolate(get_result(input$select_result_b))
#}
# Attempt to compare signatures
tryCatch({
if (input$cosmic_button == "cosmic"){
if(input$select_result_b_cosmic == "cosmic_v2_sigs"){
isolate(vals$comparison <-
compare_cosmic_v2(vals$musica, model_id = input$select_model_a,
modality = input$select_modality_a,
result_name = input$select_result_a,
threshold = as.numeric(input$Threshold),
metric = input$compare_metric,
result_rename = paste0(input$select_model_a)))
b_name <- input$select_result_b_cosmic
}
else{
isolate(vals$comparison <-
compare_cosmic_v3(vals$musica, model_id = input$select_model_a,
sample_type = "genome",
modality = input$select_modality_a,
result_name = input$select_result_a,
threshold = as.numeric(input$Threshold),
metric = input$compare_metric,
result_rename = paste0(input$select_model_a)))
b_name <- input$select_result_b_cosmic
}
}
else{
isolate(vals$comparison <-
compare_results(vals$musica, model_id = input$select_model_a,
other_model_id = input$select_model_b,
modality = input$select_modality_a,
result_name = input$select_result_a,
other_result_name = input$select_result_b,
threshold = as.numeric(input$Threshold),
metric = input$compare_metric,
result_rename = paste0(input$select_model_a),
other_result_rename = paste0(input$select_model_b)))
b_name <- input$select_model_b
}
#isolate(vals$comparison <-
# compare_results(isolate(get_result(input$select_result_a)),
# other, threshold = as.numeric(input$Threshold),
# metric = input$compare_metric))
}, error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
})
colnames(vals$comparison) <- c(input$compare_metric,
paste0(input$select_model_a, "-Index"),
paste0(b_name, "-Index"),
paste0(input$select_model_a, "-Signature"),
paste0(b_name, "-Signature"))
# generate table containing comparison statistics.
if (!is.null(isolate(vals$comparison))) {
output$compare_table <- DT::renderDT({
isolate(vals$comparison)
}, options = list(autoWidth = FALSE, scrollX = TRUE))
output$download_comparison <- renderUI({
tagList(
downloadButton("download_compare", "Download"),
bsTooltip("download_compare",
"Download the comparison table",
placement = "bottom", trigger = "hover", options = NULL)
)
})
}
})
output$download_compare <- downloadHandler(
filename = function() {
paste0("Sig-Compare-", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(vals$comparison, file)
}
)
######## Differential Analysis Tab #########
output$diff_anal_result <- renderUI({
tagList(
selectInput("diff_anal_result", "Result list name",
choices = names(vals$res_names_full)),
bsTooltip("diff_anal_result", "Name of result list entry containing desiered result")
)
})
observeEvent(input$diff_anal_result, {
output$diff_anal_modality <- renderUI({
tagList(
selectInput("diff_anal_modality", "Modality",
choices = c(names(vals$res_names_full[[input$diff_anal_result]]))),
bsTooltip("diff_anal_modality", "Desired modality")
)
})
})
observeEvent(input$diff_anal_modality, {
output$diff_anal_model <- renderUI({
tagList(
selectInput("diff_anal_model", "Model ID",
choices = c("", vals$res_names_full[[input$diff_anal_result]][[input$diff_anal_modality]])),
bsTooltip("diff_anal_model", "Model ID of desired result")
)
})
})
# UI for Wilcoxon Rank Sum Test bucket list
observeEvent(input$diff_anal_annot, {
output$diff_anal_groups <- renderUI({
if (interactive()) {
tagList(
sortable::bucket_list(
header = "Groups",
orientation = "horizontal",
add_rank_list(
text = "Group 1",
labels = unique(samp_annot(vals$musica)[[input$diff_anal_annot]]),
input_id = "diff_group1"
),
add_rank_list(
text = "Group2",
input_id = "diff_group2"
)
)
)
}
})
})
# UI to select sample annotation.
output$diff_anal_annot <- renderUI({
tagList(
selectInput("diff_anal_annot", "Sample annotation",
choices = colnames(
samp_annot(vals$musica))[-1],
selected = 1),
bsTooltip("diff_anal_annot",
"Sample annotation used to run differential analysis.")
)
})
# Event handler controls Wilcoxon bucket list.
observeEvent(input$diff_method, {
method <- input$diff_method
if (method == "wilcox") {
shinyjs::show(id = "diff_anal_groups")
} else {
shinyjs::hide(id = "diff_anal_groups")
}
})
# Event handler for differential analysis.
observeEvent(input$run_diff_anal, {
shinyjs::hide("diff_error")
g1 <- input$diff_group1
g2 <- input$diff_group2
errors <- NULL
if (!is.null(g1) & !is.null(g2)) {
g_min <- min(length(g1), length(g2))
g1 <- g1[1:g_min]
g2 <- g2[1:g_min]
}
# Run differential analysis
tryCatch({
vals$diff <-
exposure_differential_analysis(vals$musica,
model_name = input$diff_anal_model,
annotation = input$diff_anal_annot,
modality = input$diff_anal_modality,
result_name = input$diff_anal_result,
method = input$diff_method,
group1 = g1,
group2 = g2)
output$diff_table <- DT::renderDT(
if (input$diff_method == "wilcox") {
vals$diff
} else {
if(colnames(vals$diff)[1] != "Signature"){
vals$diff %>% tibble::rownames_to_column(var = "Signature")
}
#vals$diff %>% tibble::rownames_to_column(var = "Signature")
},
options = list(autoWidth = FALSE, scrollX = TRUE)
)
}, error = function(cond) {
output$diff_table <- DT::renderDT({
NULL
})
})
output$diff_error <- renderText({
errors
})
})
# Download differential analysis results.
output$download_diff <- downloadHandler(
filename = function() {
paste0("Exp-Diff-", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(vals$diff, file)
}
)
####### Helper Functions #######
# Set a result object
#set_result <- function(x, y) {
# vals$result_objects[[x]] <- y
#}
#get_result <- function(name) {
# return(vals$result_objects[[name]])
#}
#example_load = reactive({
# req(input$file)
# vars <- extract_variants_from_vcf_file(system.file("extdata", "public_LUAD_TCGA-97-7938.vcf", package = "musicatk"))
# return(vars)
#})
###############################################################################
##################Visualization#################
#select box for signature
output$select_res1 <- renderUI({
tagList(
selectInput(
inputId = "selected_res1",
label = "Select result list name",
choices = c(names(vals$res_names_full)),
width = "50%"
),
bsTooltip(id = "selected_res1",
title =
"Select the result list entry that contains the desired signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
observeEvent(input$selected_res1, {
output$select_modality1 <- renderUI({
tagList(
selectInput(
inputId = "selected_modality1",
label = "Select modality",
#choices = c(names(vals$musica@result_list[[input$selected_res1]]@modality)),
choices = c(names(vals$res_names_full[[input$selected_res1]])),
width = "50%"
),
bsTooltip(id = "selected_modality1",
title =
"Select the modality of the desired signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
})
observeEvent(input$selected_modality1, {
output$select_model1 <- renderUI({
tagList(
selectInput(
inputId = "selected_model1",
label = "Select model ID",
choices = c(vals$res_names_full[[input$selected_res1]][[input$selected_modality1]]),
width = "50%"
),
bsTooltip(id = "selected_model1",
title =
"Select the model ID desired signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
})
#select box for exposure
output$select_res2 <- renderUI({
tagList(
selectInput(
inputId = "selected_res2",
label = "Select result list name",
choices = c(names(vals$res_names_full))
),
bsTooltip(id = "selected_res2",
title =
"Select the result list entry that contains the desired exposures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
observeEvent(input$selected_res2, {
output$select_modality2 <- renderUI({
tagList(
selectInput(
inputId = "selected_modality2",
label = "Select modality",
#choices = c(names(vals$musica@result_list[[input$selected_res1]]@modality)),
choices = c(names(vals$res_names_full[[input$selected_res2]])),
width = "50%"
),
bsTooltip(id = "selected_modality2",
title =
"Select the modality of the desired signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
})
observeEvent(input$selected_modality2, {
output$select_model2 <- renderUI({
tagList(
selectInput(
inputId = "selected_model2",
label = "Select model ID",
choices = c(vals$res_names_full[[input$selected_res2]][[input$selected_modality2]]),
width = "50%"
),
bsTooltip(id = "selected_model2",
title =
"Select the model ID of the signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
})
#create text input for changing signature names
observeEvent(input$rename, {
n <- ncol(vals$musica@result_list[[input$selected_res1]]@modality[[input$selected_modality1]][[input$selected_model1]]@signatures)
#n <- ncol(signatures(vals$musica, input$selected_res1, input$selected_modality1, input$selected_model1))
#n <- ncol(vals$result_objects[[input$selected_res1]]@signatures)
for (i in 1:n) {
id <- paste0("sig", i)
if (input$rename) {
insertUI(
selector = "#signame",
ui = textInput(inputId = id, paste0("Signature", i))
)
}
else{
removeUI(selector = paste0("div:has(> #", id, ")"))
}
}
}, ignoreInit = TRUE)
#observeEvent(input$annotation1, {
# n <- ncol(vals$musica@result_list[[input$selected_res1]]@modality[[input$selected_modality1]][[input$selected_model1]]@signatures)
#n <- ncol(signatures(vals$musica, input$selected_res1, input$selected_modality1, input$selected_model1))
#n <- ncol(vals$result_objects[[input$selected_res1]]@signatures)
# for (i in 1:n) {
# id2 <- paste0("sig", i)
# if (input$annotation1) {
# insertUI(
# selector = "#annotations",
# ui = textInput(inputId = id2, paste0("Signature", i))
# )
# }
# else{
# removeUI(selector = paste0("div:has(> #", id2, ")"))
# }
# }
#}, ignoreInit = TRUE)
#save plotting options for signatures in a list
get_sig_option <- function(input) {
n <- ncol(vals$musica@result_list[[input$selected_res1]]@modality[[input$selected_modality1]][[input$selected_model1]]@signatures)
#n <- ncol(signatures(vals$musica, input$selected_res1, input$selected_modality1, input$selected_model1))
#n <- ncol(vals$result_objects[[input$selected_res1]]@signatures)
if (input$rename) {
ids <- vector()
for (i in 1:n) {
ids <- c(ids, input[[paste0("sig", i)]])
}
name_signatures(vals$musica, input$selected_model2, ids, input$selected_modality1, input$selected_res1)
#name_signatures(result = vals$result_objects[[input$selected_res1]], ids)
}
#if (input$annotation1) {
# ids2 <- vector()
# for (i in 1:n) {
# ids2 <- c(ids2, input[[paste0("sig", i)]])
# }
# #name_signatures(result = vals$result_objects[[input$selected_res1]], ids)
#}
#else{
# ids2 <- NULL
#}
#legend <- input$legend1
text_size <- input$text_size1
#facet_size <- input$facet_size
show_x_labels <- input$xlab1
show_y_labels <- input$ylab1
same_scale <- input$scale1
percent <- input$percent1
plotly <- input$plotly1
#annotation = ids2
options <- list(
#legend,
text_size,
#facet_size,
show_x_labels, show_y_labels, same_scale, percent, plotly)
return(options)
}
#Make signature plot
observeEvent(input$get_plot1, {
options <- get_sig_option(input)
#result <- vals$result_objects[[input$selected_res1]]
n <- ncol(vals$musica@result_list[[input$selected_res1]]@modality[[input$selected_modality1]][[input$selected_model1]]@signatures)
#n <- ncol(signatures(vals$musica, input$selected_res1, input$selected_modality1, input$selected_model1))
#n <- ncol(vals$result_objects[[input$selected_res1]]@signatures)
height <- paste0(as.character(n * 90), "px")
if (options[[6]]) {
#disable resizable
jqui_resizable("#sigplot_plotly", operation = "destroy")
jqui_resizable("#sigplot_plot", operation = "destroy")
#remove previous plot
removeUI(selector = "#sigplot_plot")
removeUI(selector = "#sigplot_plotly")
insertUI(
selector = "#plot_div1",
ui = plotlyOutput(outputId = "sigplot_plotly", height = height)
)
output$sigplot_plotly <- renderPlotly(
plot_signatures(
vals$musica,
input$selected_model1,
input$selected_modality1,
input$selected_res1,
#legend = options[[1]],
percent = options[[5]],
plotly = options[[6]],
text_size = options[[1]],
#facet_size = options[[3]],
show_x_labels = options[[2]],
show_y_labels = options[[3]],
#annotation = options[[7]],
same_scale = options[[4]]
)
)
#enable resizable
jqui_resizable("#sigplot_plotly")
}
else{
jqui_resizable("#sigplot_plotly", operation = "destroy")
jqui_resizable("#sigplot_plot", operation = "destroy")
removeUI(selector = "#sigplot_plotly")
removeUI(selector = "#sigplot_plot")
insertUI(
selector = "#plot_div1",
ui = plotOutput(outputId = "sigplot_plot", height = height)
)
output$sigplot_plot <- renderPlot(
plot_signatures(
vals$musica,
input$selected_model1,
input$selected_modality1,
input$selected_res1,
#legend = options[[1]],
percent = options[[5]],
plotly = options[[6]],
text_size = options[[1]],
#facet_size = options[[3]],
show_x_labels = options[[2]],
show_y_labels = options[[3]],
#annotation = options[[7]],
same_scale = options[[4]]
)
)
jqui_resizable("#sigplot_plot")
}
})
observeEvent(input$plot_type, {
#If box or violin selected, generate options for plotting points;
#group by and color by have two choices
if (input$plot_type %in% c("box", "violin") & vals$point_ind == 0) {
removeUI(selector = "#point_opt")
insertUI(
selector = "#points",
ui = tags$div(
id = "point_opt",
checkboxInput(inputId = "add_point", label = "Add Points",
value = TRUE),
numericInput(inputId = "point_size", label = "Point Size", value = 2),
bsTooltip(id = "add_point",
title =
"If checked, then points for individual sample exposures will be
plotted on top of the violin/box plots.",
placement = "right", options = list(container = "body")),
bsTooltip(id = "point_size",
title = paste0("Size of the points to be plotted on ",
"top of the violin/box plots."),
placement = "right", options = list(container = "body"))
)
)
removeUI(selector = "#group1")
insertUI(
selector = "#insert_group",
ui = tagList(
radioButtons(
inputId = "group1",
label = "Group By",
choices = list("Signature" = "signature",
"Annotation" = "annotation"),
inline = TRUE,
selected = "signature"
),
bsTooltip(id = "group1",
title =
paste0("Determines how to group samples into ",
"the subplots. If set to \"annotation\", ",
"then a sample annotation must be supplied ",
"via the annotation parameter."),
placement = "right",
options = list(container = "body"))
)
)
removeUI(selector = "#color")
insertUI(
selector = "#insert_color",
ui = tagList(
radioButtons(
inputId = "color",
label = "Color By",
choices = list("Signature" = "signature",
"Annotation" = "annotation"),
inline = TRUE,
selected = "signature"
),
bsTooltip(id = "color", title = "Determines how to color samples.",
placement = "right", options = list(container = "body"))
)
)
vals$point_ind <- 1
}
#if scatter is selected, generate point size option, remove group by option,
#color by has 3 choices
else if (input$plot_type == "scatter") {
removeUI(selector = "#point_opt")
removeUI(selector = "#group1")
insertUI(
selector = "#points",
ui = tags$div(
id = "point_opt",
numericInput(inputId = "point_size",
label = "Point Size", value = 0.7),
bsTooltip(id = "point_size",
title = "Size of the points on scatter plots.",
placement = "right", options = list(container = "body"))
)
)
removeUI(selector = "#color")
insertUI(
selector = "#insert_color",
ui = tagList(
radioButtons(
inputId = "color",
label = "Color By",
choices = list("None" = "none", "Signature" = "signatures",
"Annotation" = "annotation"),
inline = TRUE,
selected = "none"
),
bsTooltip(id = "color", title = "Determines how to color samples.",
placement = "right", options = list(container = "body"))
)
)
vals$point_ind <- 0
}
#if bar is selected, remove all points related options,
#group by has 3 choices, color by has 2 choices
else if (input$plot_type == "bar") {
removeUI(selector = "#point_opt")
removeUI(selector = "#group1")
insertUI(
selector = "#insert_group",
ui = tagList(
radioButtons(
inputId = "group1",
label = "Group By",
choices = list("None" = "none", "Signature" = "signature",
"Annotation" = "annotation"),
inline = TRUE,
selected = "none"
),
bsTooltip(id = "group1",
title =
paste0("Determines how to group samples into the ",
"subplots. If set to \"annotation\", then a ",
"sample annotation must be supplied via ",
"the annotation parameter."),
placement = "right", options = list(container = "body"))
)
)
removeUI(selector = "#color")
insertUI(
selector = "#insert_color",
ui = tagList(
radioButtons(
inputId = "color",
label = "Color By",
choices = list("Signature" = "signature",
"Annotation" = "annotation"),
inline = TRUE,
selected = "signature"
),
bsTooltip(id = "color", title = "Determines how to color samples.",
placement = "right", options = list(container = "body"))
)
)
vals$point_ind <- 0
}
else{
return(NULL)
}
})
addTooltip(session, id = "proportional",
title = "If checked, the exposures will be normalized to
between 0 and 1 by dividing by the total
number of counts for each sample.",
placement = "right", options = list(container = "body"))
addTooltip(session, id = "color",
title = "Determines how to color the bars or box/violins.
If set to \"annotation\", then a sample annotation must be
supplied via the annotation parameter",
placement = "right", options = list(container = "body"))
#if annotation is selected for group by, enable annotation option
observeEvent(input$group1, {
if (input$group1 == "annotation" & input$color != "annotation") {
if (ncol(samp_annot(vals$musica)) == 1) {
shinyalert::shinyalert(title = "Error",
text = paste0("Annotation not found. ",
"Please add annotation to the musica object."))
}
else{
vals$annot <-
as.list(colnames(samp_annot(
vals$musica))[-1])
names(vals$annot) <-
colnames(samp_annot(vals$musica))[-1]
insertUI(
selector = "#insert_annot",
ui = tagList(
selectInput(
inputId = "annotation",
label = "Annotation",
choices = vals$annot
),
bsTooltip(id = "annotation",
title = paste0("Sample annotation used to group the ",
"subplots or color the bars, boxes, or violins."),
placement = "right", options = list(container = "body"))
)
)
}
}
else{
if (input$color != "annotation") {
removeUI(selector = "div:has(>> #annotation)")
}
}
})
#if annotation is selected for color by, enable annotation option
observeEvent(input$color, {
if (input$color == "annotation" & input$group1 != "annotation") {
if (ncol(samp_annot(vals$musica)) == 1) {
shinyalert::shinyalert(title = "Error",
text = "Annotation not found.
Please add annotation to the musica object.")
}
else{
vals$annot <- as.list(colnames(samp_annot(
vals$musica))[-1])
names(vals$annot) <- colnames(samp_annot(
vals$musica))[-1]
insertUI(
selector = "#insert_annot",
ui = tagList(
selectInput(
inputId = "annotation",
label = "Annotation",
choices = vals$annot
),
bsTooltip(id = "annotation",
title = "Sample annotation used to group the subplots
or color the bars, boxes, or violins.",
placement = "right", options = list(container = "body"))
)
)
}
}
else{
if (input$group1 != "annotation") {
removeUI(selector = "div:has(>> #annotation)")
}
}
})
#If bar plot is sorted by signature exposure, generate a bucket_list
observeEvent(input$sort, {
if (input$sort == "signature") {
insertUI(
selector = "#sort_by_sig",
ui = tags$div(
id = "insert_sig",
bucket_list(
header = "Select signatures to sort",
group_name = "bucket",
orientation = "horizontal",
add_rank_list(
text = "Available Signatures:",
labels = as.list(colnames(
signatures(vals$musica, input$selected_res2, input$selected_modality2, input$selected_model2))),
#vals$result_objects[[input$selected_res2]]@signatures)),
input_id = "sig_from"
),
add_rank_list(
text = "Selected Signatures:",
labels = NULL,
input_id = "sig_to"
)
),
bsTooltip(id = "bucket",
title = "Drag signatures from top bucket to the bottom bucket.
Samples will be sorted in descending order by signatures.
If multiple signatures are supplied,
samples will be sorted by each signature sequentially",
placement = "right", options = list(container = "body"))
)
)
}
else{
removeUI(selector = "#insert_sig")
}
})
#generate the option to determine number of top samples to include in bar plot
#observeEvent(input$selected_res2, {
observeEvent(input$selected_model2, {
output$number <- renderUI(
tagList(
numericInput(inputId = "num_samp", label = "# of Top Samples",
value = dim(exposures(vals$musica, input$selected_res2,
input$selected_modality2, input$selected_model2))[2],
#value = dim(vals$result_objects[[
#input$selected_res2]]@exposures)[2],
min = 1,
max = dim(exposures(vals$musica, input$selected_res2,
input$selected_modality2, input$selected_model2))[2]),
#max = dim(vals$result_objects[[
#input$selected_res2]]@exposures)[2]),
bsTooltip(id = "num_samp",
title = "The top number of sorted samples to display.",
placement = "right", options = list(container = "body"))
)
)
})
#save plotting options for exposures in a list
get_exp_option <- function(input) {
plot_type <- input$plot_type
proportional <- input$proportional
group_by <- input$group1
color_by <- input$color
if (input$group1 == "annotation" | input$color == "annotation") {
annot <- input$annotation
}
else{
annot <- NULL
}
if (!is.numeric(input$num_samp)) {
num_samples <- NULL
}
else{
num_samples <- input$num_samp
}
sort_by <- input$sort
if (sort_by == "signature") {
sort_samples <- input$sig_to
}
else{
sort_samples <- sort_by
}
if (!is.numeric(input$theta)) {
threshold <- NULL
}
else{
threshold <- input$theta
}
same_scale <- input$scale2
label_x_axis <- input$xlab2
legend <- input$legend2
if (length(input$add_point) == 0) {
add_points <- FALSE
}
else{
add_points <- input$add_point
}
point_size <- input$point_size
plotly <- input$plotly2
options <- list(plot_type, proportional, group_by, color_by,
annot, num_samples, sort_samples, threshold,
same_scale, label_x_axis, legend, add_points,
point_size, plotly)
return(options)
}
#plot exposures
observeEvent(input$get_plot2, {
options <- get_exp_option(input)
#else{
# result <- vals$result_objects[[input$selected_res2]]
#}
if (options[[14]]) {
jqui_resizable("#exp_plotly", operation = "destroy")
jqui_resizable("#exp_plot", operation = "destroy")
removeUI(selector = "#exp_plotly")
removeUI(selector = "#exp_plot")
insertUI(
selector = "#plot_div2",
ui = plotlyOutput(outputId = "exp_plotly")
)
if (options[[1]] == "scatter") {
if (is.na(umap(vals$musica, input$selected_res2, input$selected_modality2, input$selected_model2)[1])) {
create_umap(vals$musica, input$selected_model2, input$selected_modality2, input$selected_res2)
#result <- vals$result_objects[[input$selected_res2]]
}
output$exp_plotly <- renderPlotly(
plot_umap(
vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2,
color_by = options[[4]],
proportional = options[[2]],
same_scale = options[[9]],
annotation = options[[5]],
plotly = options[[14]],
legend = options[[11]],
point_size = options[[13]]
)
)
}
else{
output$exp_plotly <- renderPlotly(
plot_exposures(
vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2,
plot_type = options[[1]],
proportional = options[[2]],
group_by = options[[3]],
color_by = options[[4]],
annotation = options[[5]],
num_samples = options[[6]],
sort_samples = options[[7]],
threshold = options[[8]],
same_scale = options[[9]],
label_x_axis = options[[10]],
legend = options[[11]],
add_points = options[[12]],
point_size = options[[13]],
plotly = options[[14]]
)
)
}
jqui_resizable("#exp_plotly")
}
else{
jqui_resizable("#exp_plotly", operation = "destroy")
jqui_resizable("#exp_plot", operation = "destroy")
removeUI(selector = "#exp_plot")
removeUI(selector = "#exp_plotly")
insertUI(
selector = "#plot_div2",
ui = plotOutput(outputId = "exp_plot")
)
if (options[[1]] == "scatter") {
if (length(umap(vals$musica, input$selected_res2, input$selected_modality2, input$selected_model2)) == 0) {
#create_umap(vals$result_objects[[input$selected_res3]])
create_umap(vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2)
#result <- vals$result_objects[[input$selected_res3]]
}
output$exp_plot <- renderPlot(
plot_umap(
vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2,
color_by = options[[4]],
proportional = options[[2]],
same_scale = options[[9]],
annotation = options[[5]],
plotly = options[[14]],
legend = options[[11]],
point_size = options[[13]]
)
)
}
else{
output$exp_plot <- renderPlot(
plot_exposures(
vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2,
plot_type = options[[1]],
proportional = options[[2]],
group_by = options[[3]],
color_by = options[[4]],
annotation = options[[5]],
num_samples = options[[6]],
sort_samples = options[[7]],
threshold = options[[8]],
same_scale = options[[9]],
label_x_axis = options[[10]],
legend = options[[11]],
add_points = options[[12]],
point_size = options[[13]],
plotly = options[[14]]
)
)
}
jqui_resizable("#exp_plot")
}
})
################################################
####################Heatmap##############
output$select_res_heatmap <- renderUI({
tagList(
selectInput(
inputId = "select_res_heatmap",
label = "Select Result",
choices = c(names(vals$res_names_full))
)
)
})
observeEvent(input$select_res_heatmap, {
output$select_modality_heatmap <- renderUI({
tagList(
selectInput("select_modality_heatmap", "Modality",
choices = c(names(vals$res_names_full[[input$select_res_heatmap]]))),
bsTooltip("select_modality_heatmap", "Desired modality")
)
})
})
observeEvent(input$select_modality_heatmap, {
output$select_model_heatmap <- renderUI({
tagList(
selectInput("select_model_heatmap", "Model ID",
choices = c(vals$res_names_full[[input$select_res_heatmap]][[input$select_modality_heatmap]])),
bsTooltip("select_model_heatmap", "Model ID of desired result")
)
})
})
propor <- reactive({
props <- input$prop
return(props)
})
sel_col_names <- reactive({
cc <- input$col_names
return(cc)
})
sel_row_names <- reactive({
rr <- input$row_names
return(rr)
})
zscale <- reactive({
zscale <- input$scale
return(zscale)
})
#Subsetting my signatures
observeEvent(input$subset, {
if (input$subset == "signature") {
insertUI(
selector = "#sortbysigs",
ui = tags$div(
id = "insert_sig",
bucket_list(
header = "Select signatures to sort",
group_name = "bucket",
orientation = "horizontal",
add_rank_list(
text = "Available Signatures:",
labels = as.list(colnames(signatures(vals$musica,
input$select_res_heatmap,
input$select_modality_heatmap,
input$select_model_heatmap))),
#labels = as.list(colnames(
# vals$result_objects[[input$select_res_heatmap]]@signatures)),
input_id = "sig_from"
),
add_rank_list(
text = "Selected Signatures:",
labels = NULL,
input_id = "sort_sigs"
)
)
)
)
}
else if (input$subset == "all_signatures") {
removeUI(selector = "#insert_sig")
}
})
get_sigs <- function(input) {
req(input$subset)
if (input$subset == "signature") {
sig <- input$sort_sigs
}
else if (input$subset == "all_signatures") {
sig <- NULL
}
return(sig)
}
#Subsetting by tumors
observeEvent(input$subset_tum, {
if (input$subset_tum == "tumors") {
insertUI(
selector = "#sortbytum",
ui = tags$div(
id = "inserttum",
checkboxGroupInput(
"tum_val", "Available Samples:",
as.list(unique(samp_annot(vals$musica)$Tumor_Subtypes)))
#as.list(unique(vals$result_objects[[
# input$select_res_heatmap
# ]]@musica@sample_annotations$Tumor_Subtypes)))
)
)
}
else{
removeUI(selector = "#inserttum")
}
})
get_tums <- function(input) {
req(input$subset_tum)
if (input$subset_tum == "tumors") {
tums <- input$tum_val
}
else{
tums <- NULL
}
return(tums)
}
#Subsetting by annotation
observeEvent(input$subset_annot, {
if (input$subset_annot == TRUE) {
insertUI(
selector = "#sortbyannot",
ui = tags$div(
id = "#insert_annot",
checkboxGroupInput("annot_val", "Available annotations:",
#c(as.list(colnames(samp_annot(
# vals$result_objects[[input$select_res_heatmap
# ]]))))
c(as.list(colnames(samp_annot(vals$musica))))
)
))
}
else{
removeUI(selector = "#insert_annot")
}
})
#Add heatmap functionality
observeEvent(input$get_heatmap, {
sigs <- get_sigs(input)
tums <- get_tums(input)
output$heatmap <- renderPlot({
req(input$select_res_heatmap)
input$get_heatmap
isolate(plot_heatmap(vals$musica,
model_name = input$select_model_heatmap,
modality = input$select_modality_heatmap,
result_name = input$select_res_heatmap,
proportional = propor(),
show_row_names = sel_row_names(),
show_column_names = sel_col_names(),
scale = zscale(),
subset_signatures = c(sigs),
subset_tumor = c(tums),
annotation = input$annot_val,
column_title = paste0("Heatmap for ",
input$select_model_heatmap)))
})
})
##############Clustering################
#select box for clustering
output$select_res3 <- renderUI({
tagList(
selectInput(
inputId = "selected_res3",
label = "Select result list name",
choices = c(names(vals$res_names_full))
),
bsTooltip(id = "selected_res3",
title = "Select name of result list entry containing the
signatures to visualize.",
placement = "right", options = list(container = "body"))
)
})
observeEvent(input$selected_res3, {
output$select_modality3 <- renderUI({
tagList(
selectInput("selected_modality3", "Modality",
choices = c(names(vals$res_names_full[[input$selected_res3]]))),
bsTooltip("selected_modality3", "Desired modality")
)
})
})
observeEvent(input$selected_modality3, {
output$select_model3 <- renderUI({
tagList(
selectInput("selected_model3", "Model ID",
choices = c(vals$res_names_full[[input$selected_res3]][[input$selected_modality3]])),
bsTooltip("selected_model3", "Model ID of desired result")
)
})
})
#generate options for selecting number of clusters
observeEvent(input$selected_model3, {
default <- min(10, dim(exposures(vals$musica, input$selected_res3,
input$selected_modality3,
input$selected_model3))[2] - 1)
output$no_cluster1 <- renderUI(
tagList(
numericInput(inputId = "num_clust1", label = "Max Number of Clusters",
min = 2,
max = dim(exposures(vals$musica, input$selected_res3,
input$selected_modality3,
input$selected_model3))[2] - 1,
value = default)
#max = dim(vals$result_objects[[
# input$selected_res3]]@exposures)[2])
)
)
output$no_cluster2 <- renderUI(
tagList(
numericInput(inputId = "num_clust2", label = "Max Number of Clusters",
value = 2,
min = 2,
max = dim(exposures(vals$musica, input$selected_res3,
input$selected_modality3,
input$selected_model3))[2] - 1)
)
)
})
#make plot for exploratory analysis
observeEvent(input$explore, {
jqui_resizable("#explore_plot", operation = "destroy")
removeUI(selector = "#explore_plot")
insertUI(
selector = "#insert_explore_plot",
ui = plotOutput(outputId = "explore_plot")
)
method <- input$metric
clust.method <- input$algorithm1
n <- input$num_clust1
proportional <- input$proportional2
output$explore_plot <- renderPlot(
k_select(
#result = vals$result_objects[[input$selected_res3]],
vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3,
method = method,
clust.method = clust.method,
n = n,
proportional = proportional
)
)
jqui_resizable("#explore_plot")
})
#generate select box for dissimilarity matrix and options specific to
#certain algorithms
observeEvent(input$algorithm2, {
choices <- list(hkmeans =
c("Euclidean" = "euclidean", "Manhattan" = "manhattan",
"Canberra" = "canberra"),
clara = c("Euclidean" = "euclidean",
"Manhattan" = "manhattan", "Jaccard" = "jaccard"),
kmeans = c("Euclidean" = "euclidean",
"Manhattan" = "manhattan", "Jaccard" = "jaccard",
"Cosine" = "cosine", "Canberra" = "canberra"),
hclust = c("Euclidean" = "euclidean",
"Manhattan" = "manhattan", "Jaccard" = "jaccard",
"Cosine" = "cosine", "Canberra" = "canberra"),
pam = c("Euclidean" = "euclidean",
"Manhattan" = "manhattan", "Jaccard" = "jaccard",
"Cosine" = "cosine", "Canberra" = "canberra"))
output$diss <- renderUI(
selectInput(
inputId = "diss_method",
label = "Method for Dissimilarity Matrix",
choices = choices[[input$algorithm2]]
)
)
if (input$algorithm2 == "hclust") {
insertUI(
selector = "#hclust",
ui = selectInput(
inputId = "hclust_method",
label = "Hierarchical Clustering Method",
choices = c("ward.D" = "ward.D", "ward.D2" = "ward.D2",
"single" = "single", "complete" = "complete",
"average" = "average", "mcquitty" = "mcquitty",
"median" = "median", "centroid" = "centroid")
)
)
}
else{
removeUI(selector = "div:has(>> #hclust_method)")
}
if (input$algorithm2 == "clara") {
insertUI(
selector = "#clara",
ui = numericInput(inputId = "clara_num",
label = "No. of Samples for CLARA",
value = 5,
min = 1,
max = dim(exposures(vals$musica, input$selected_res3,
input$selected_modality3,
input$selected_model3))[2])
)
}
else{
removeUI(selector = "div:has(>> #clara_num)")
}
if (input$algorithm2 %in% c("kmeans", "hkmeans")) {
insertUI(
selector = "#iter",
ui = numericInput(inputId = "max_iter",
label = "Max No. of Iterations",
value = 10,
min = 1)
)
}
else{
removeUI(selector = "div:has(>> #max_iter)")
}
})
#create select box to allow users to color plot by annotation
observeEvent(input$group2, {
if (input$group2 == "annotation") {
vals$annot <- as.list(colnames(samp_annot(vals$musica))[-1])
names(vals$annot) <- colnames(samp_annot(vals$musica))[-1]
insertUI(
selector = "#insert_annot2",
ui = tagList(
selectInput(
inputId = "annotation2",
label = "Annotation",
choices = vals$annot
)
)
)
}
else{
removeUI(selector = "div:has(>> #annotation2)")
}
})
#perform clustering analysis
observeEvent(input$cluster_calc, {
#result <- vals$result_objects[[input$selected_res3]]
nclust <- input$num_clust2
proportional <- input$proportional3
method <- input$algorithm2
dis.method <- input$diss_method
if (!is.null(input$hclust_method)) {
hc.method <- input$hclust_method
}
else{
hc.method <- "ward.D"
}
if (!is.numeric(input$clara_num)) {
clara.samples <- 5
}
else{
clara.samples <- input$clara_num
}
if (!is.numeric(input$max_iter)) {
iter.max <- 10
}
else{
iter.max <- input$max_iter
}
vals$cluster <- cluster_exposure(vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3,
nclust = nclust,
proportional = proportional,
method = method,
dis.method = dis.method,
hc.method = hc.method,
clara.samples = clara.samples,
iter.max = iter.max)
insertUI(
selector = "#insert_cluster_table",
ui = tags$div(
DT::DTOutput("cluster_table"),
downloadButton("download_cluster", "Download")
)
)
#annot <- samp_annot(vals$result_objects[[input$selected_res3]])
annot <- samp_annot(vals$musica)
row.names(annot) <- annot$Samples
dat <- cbind(annot, vals$cluster)
output$cluster_table <- DT::renderDT(
DT::datatable(dat[-1])
)
output$download_cluster <- downloadHandler(
filename = function() {
paste0(input$selected_model3, "_cluster.txt")
},
content = function(file) {
write.table(dat[-1], file, sep = "\t", quote = FALSE)
}
)
})
#visualize clustering result
observeEvent(input$cluster_vis, {
#if (length(umap(vals$result_objects[[input$selected_res3]])) == 0) {
if (is.na(umap(vals$musica, input$selected_res3, input$selected_modality3, input$selected_model3)[1])) {
#create_umap(vals$result_objects[[input$selected_res3]])
create_umap(vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3)
#result <- vals$result_objects[[input$selected_res3]]
}
else{
#result <- vals$result_objects[[input$selected_res3]]
}
clusters <- vals$cluster
group <- input$group2
if (group == "annotation") {
annotation <- input$annotation2
}
else{
annotation <- NULL
}
plotly <- input$plotly3
if (plotly) {
jqui_resizable("#cluster_plot", operation = "destroy")
jqui_resizable("#cluster_plotly", operation = "destroy")
removeUI(selector = "#cluster_plot")
removeUI(selector = "#cluster_plotly")
insertUI(
selector = "#cluster_plot_div",
ui = plotlyOutput(outputId = "cluster_plotly")
)
output$cluster_plotly <- renderPlotly(
plot_cluster(vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3,
clusters = clusters,
group = group,
annotation = annotation,
plotly = plotly)
)
jqui_resizable("#cluster_plotly")
}
else{
jqui_resizable("#cluster_plot", operation = "destroy")
jqui_resizable("#cluster_plotly", operation = "destroy")
removeUI(selector = "#cluster_plot")
removeUI(selector = "#cluster_plotly")
insertUI(
selector = "#cluster_plot_div",
ui = plotOutput(outputId = "cluster_plot")
)
output$cluster_plot <- renderPlot(
plot_cluster(vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3,
clusters = clusters,
group = group,
annotation = annotation,
plotly = plotly)
)
jqui_resizable("#cluster_plot")
}
})
########################################
########################################Download#############################
output$select_mus_obj_download <- renderUI({
tagList(
selectInput(
inputId = "select_mus_obj_download",
label = "Select Musica Object",
choices = "musica"
)
)
})
#output$select_res_download <- renderUI({
# tagList(
# selectInput(
# inputId = "select_res_download",
# label = "Select Musica Result Object",
# choices = c(names(vals$result_objects))
# )
# )
#})
#Adding the download feature
output$download_mus_obj <- downloadHandler(
filename = function() {
paste("musica_object", ".rds", sep = "")
},
content = function(file) {
saveRDS(vals$musica, file = file)
}
)
# output$download_res <- downloadHandler(
#filename = function() {
# paste("musica_results", ".rds", sep = "")
#},
#content = function(file) {
# saveRDS(vals$result_objects[[input$select_res_download]], file = file)
#}
#)
}
campbio/musicatk documentation built on Dec. 25, 2024, 9:34 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library(musicatk)
library(plotly)
library(sortable)
library(shinyBS)
library(shinyalert)
library(TCGAbiolinks)
library(shinyjqui)
options(shiny.maxRequestSize = 10000 * 1024 ^ 2)
server <- function(input, output, session) {
#################### GENERAL ##################################################
#Deactivate all tabs except import
shinyjs::addCssClass(selector = "a[data-value='musica']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='annotations']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='tables']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='discover']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='predict']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='visualization']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='compare']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='differentialanalysis']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='cluster']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='heatmap']",
class = "inactiveLink")
shinyjs::addCssClass(selector = "a[data-value='download']",
class = "inactiveLink")
#Initialize variables
vals <- reactiveValues(
genome = NULL,
musica = NULL,
files = NULL,
res_names = NULL,
res_names_full = list(),
#result_objects = list(),
p_sigs = NULL, #cosmic sig
p_res = NULL, #cosmic result object
annotations = NULL,
diff = NULL,
df = NULL,
musica_upload = NULL,
data = NULL,
point_ind = 0, #indicator for point option in exposure
annot = NULL,
deleted_rows = NULL,
deleted_row_indices = list(),
cluster = NULL,
var = NULL,
musica_name_user = NULL,
musica_message = NULL,
sort_sigs = NULL
)
#Control flow to detect user's progress and active tabs
observeEvent(input$menu, {
if (input$menu == "musica") {
if (is.null(vals$var)) {
shinyalert::shinyalert("Error",
paste0("No data was uploaded. ",
"Please go to \"Import\" ",
"and upload your data.", "error"))
updateTabItems(session, "menu", "import")
}
else{
removeCssClass(selector = "a[data-value='musica']",
class = "inactiveLink")
}
}
else if (input$menu == "annotations") {
if (is.null(vals$musica) && length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No musica object was found. ",
"Please go to \"Import\" or ",
"\"Create Musica Object\" to upload or ",
"create an object.", "error"))
updateTabItems(session, "menu", "import")
}
}
else if (input$menu == "download") {
if (is.null(vals$musica) && length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No musica object was found. ",
"Please go to \"Import\" or ",
"\"Create Musica Object\" to upload or ",
"create an object.", "error"))
updateTabItems(session, "menu", "import")
}
}
else if (input$menu == "tables") {
if (is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No data was uploaded. ",
"Please go to \"Import\" and upload ",
"your data.", "error"))
updateTabItems(session, "menu", "import")
}
else if (!is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No musica object was created. ",
"Please go to \"Create Musica Object\", ",
"to create a musica object or go to ",
"\"Import\" -> \"Import Musica Result ",
"Object\" to upload a muscia object."),
"error")
updateTabItems(session, "menu", "musica")
}
else{
removeCssClass(selector = "a[data-value='tables']",
class = "inactiveLink")
}
}
else if (input$menu %in% c("discover", "predict")) {
if (is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No data was uploaded. ",
"Please go to \"Import\" and upload ",
"your data."), "error")
updateTabItems(session, "menu", "import")
}
else if (!is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No musica object was created.",
"Please go to \"Create Musica Object\",",
"to create a musica object or go to ",
"\"Import\" -> \"Import Musica Result Object\" ",
"to upload a muscia object."), "error")
updateTabItems(session, "menu", "musica")
}
else if (!is.null(vals$var) && !is.null(vals$musica) &&
length(tables(vals$musica)) == 0 &&
is.null(vals$musica_upload)) {
shinyalert::shinyalert("Error",
paste0("No mutation count table was created. ",
"Please go to \"Build Tables\" to ",
"create count table."),
"error")
updateTabItems(session, "menu", "tables")
}
else if (!is.null(vals$var) && is.null(vals$musica) &&
!is.null(vals$musica_upload) &&
length(tables(vals$musica_upload)) == 0) {
shinyalert::shinyalert("Error",
paste0("No mutation count table was created. ",
"Please go to \"Build Tables\" to ",
"create count table."),
"error")
updateTabItems(session, "menu", "tables")
}
else{
removeCssClass(selector = "a[data-value='discover']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='predict']",
class = "inactiveLink")
}
}
else if (input$menu %in% c("visualization", "compare",
"differentialanalysis", "cluster", "heatmap")) {
if (is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload) && length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No data was uploaded. ",
"Please go to \"Import\" and upload ",
"your data."), "error")
updateTabItems(session, "menu", "import")
}
else if (!is.null(vals$var) && is.null(vals$musica) &&
is.null(vals$musica_upload) &&
length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No musica object was created. ",
"Please go to \"Create Musica Object\" ",
"to create a musica object or go to ",
"\"Import\" -> \"Import Musica ",
"Object\ to upload a muscia object."),
"error")
updateTabItems(session, "menu", "musica")
}
else if (!is.null(vals$var) && !is.null(vals$musica) &&
length(tables(vals$musica)) == 0 &&
is.null(vals$musica_upload) &&
length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No mutation count table was created. ",
"Please go to \"Build Tables\" ",
"to create count table."),
"error")
updateTabItems(session, "menu", "tables")
}
else if (!is.null(vals$var) && is.null(vals$musica)
&& !is.null(vals$musica_upload)
&& length(tables(vals$musica_upload)) == 0
&& length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No mutation count table was created. ",
"Please go to \"Build Tables\" to ",
"create count table."),
"error")
updateTabItems(session, "menu", "tables")
}
else if (!is.null(vals$var) && (!is.null(vals$musica) ||
!is.null(vals$musica_upload))
&& (length(tables(vals$musica)) != 0 ||
length(tables(vals$musica_upload)) != 0)
&& length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No results in the musica object. ",
"Please go to \"Signatures and ",
"Exposures\" -> \"Discover Signatures ",
"and Exposures\" to create ",
"results."), "error")
updateTabItems(session, "menu", "discover")
}
else if (!is.null(vals$musica_upload) && length(vals$res_names) == 0) {
shinyalert::shinyalert("Error",
paste0("No results in the musica object. ",
"Please go to \"Signatures and ",
"Exposures\" -> \"Discover Signatures ",
"and Exposures\" to create ",
"results."), "error")
updateTabItems(session, "menu", "discover")
}
else{
removeCssClass(selector = "a[data-value='visualization']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='compare']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='differentialanalysis']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='cluster']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='heatmap']",
class = "inactiveLink")
}
}
else{
return()
}
})
#If variants uplodaed, enable musica tab
observeEvent(vals$var, {
if (!is.null(vals$var)) {
removeCssClass(selector = "a[data-value='musica']",
class = "inactiveLink")
}
})
#If musica object present, enable downstream tabs
observeEvent(vals$musica, {
if (!is.null(vals$musica)) {
removeCssClass(selector = "a[data-value='tables']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='annotations']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='download']",
class = "inactiveLink")
}
if (length(tables(vals$musica)) != 0) {
removeCssClass(selector = "a[data-value='discover']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='predict']",
class = "inactiveLink")
}
})
#If there's uploaded musica object, enable downstream tabs
observeEvent(vals$musica_upload, {
if (!is.null(vals$musica_upload)) {
removeCssClass(selector = "a[data-value='tables']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='annotations']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='download']",
class = "inactiveLink")
}
if (length(tables(vals$musica_upload)) != 0) {
removeCssClass(selector = "a[data-value='discover']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='predict']",
class = "inactiveLink")
}
})
#If there's result object, enable downstream tabs
observeEvent(vals$res_names, {
if (length(vals$res_names) > 0) {
removeCssClass(selector = "a[data-value='annotations']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='visualization']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='compare']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='differentialanalysis']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='cluster']",
class = "inactiveLink")
removeCssClass(selector = "a[data-value='heatmap']",
class = "inactiveLink")
}
})
###################### Zainab's Code ##########################################
output$tcga_tumor <- renderUI({
hr()
#Extracting TCGA tumors and formatting it to display only the abbreviations
projects <- TCGAbiolinks:::getGDCprojects()
matches <- grepl("TCGA", projects$id)
projects <- projects[matches,]
project.name <- paste0(projects$id, ": ", projects$name)
p <- projects$id
names(p) <- project.name
p <- sort(p)
textInput("tcga_tumor", "Enter TCGA tumor type")
tags$style("#tcga_tumor {
font-size:8px;
height:10px;
}")
checkboxGroupInput("tcga_tumor", " ", choices = as.list(p))
})
observeEvent(input$import_tcga, {
req(input$import_tcga)
if (!is.null(input$tcga_tumor)) {
shinybusy::show_spinner()
# Now defunct in TCGAbiolink
# maf <- TCGAbiolinks::GDCquery_Maf(input$tcga_tumor, pipelines = "mutect")
# New way:
query <- GDCquery(project = input$tcga_tumor,
data.category = "Simple Nucleotide Variation",
data.type = "Masked Somatic Mutation",
workflow.type = "Aliquot Ensemble Somatic Variant Merging and Masking",
experimental.strategy = "WXS",
data.format = "MAF")
GDCdownload(query)
maf <- GDCprepare(query)
vals$var <- extract_variants_from_maf_file(maf)
showNotification("TCGA dataset successfully imported!")
shinybusy::hide_spinner()
}
else if (is.null(input$tcga_tumor)) {
shinyalert("Error: No tumor found. Please select a tumor from the list!")
}
})
#Displaying thr table for TCGA tumor variants
output$tcga_contents <- DT::renderDT({
req(vals$var)
req(input$tcga_tumor)
return(head(vals$var))
shinyjs::show(id = "tcga_contents")
js$enableTabs()
})
observeEvent(input$import, {
req(input$file)
file_name <- vals$data$datapath
summaries_list <- list()
if (all(tools::file_ext(file_name) != c("maf", "vcf", "txt"))) {
shinyalert::shinyalert(paste0("Error: File format not supported! ",
"Please upload .maf or .vcf files"))
}
if (all(tools::file_ext(file_name) == c("txt"))){
shinybusy::show_spinner()
vals$var <- extract_variants_from_maf_file(c(file_name))
shinybusy::hide_spinner()
showNotification("Import successfully completed!")
}
else{
shinybusy::show_spinner()
for (i in seq_along(file_name)) {
# Try to read the file
result <- tryCatch({
vcf <- extract_variants(file_name[i])
}, error = function(e) {
# If there is an error, return NULL or an error message
message(paste("Error reading file:", file_name[i], "\nError message:", e$message))
return(NULL)
})
# If result is not NULL, add it to the list
if (!is.null(result)) {
summaries_list[[i]] <- result
}
}
# Combine the list of data frames into one data frame
do.call(rbind, summaries_list)
vals$var <- do.call(rbind, summaries_list)
shinybusy::hide_spinner()
showNotification("Import successfully completed!")
}
})
#Displaying list of available genomes
output$genome_list <- renderUI({
g <- BSgenome::available.genomes()
g <- strsplit(g, ",")
gg <- gsub("^.*?\\.", "", g)
selectInput("GenomeSelect", "Choose genome:",
list("Common genomes" =
list("hg38", "hg19", "hg18", "mm9", "mm10"),
"Genomes" = gg),
width = "100%")
})
output$genome_select <- renderText({
paste("Genome selected:", input$GenomeSelect)
})
check_chr <- reactive({
chr <- input$ref_chr
return(chr)
})
check_bases <- reactive({
bases <- input$ref_bases
return(bases)
})
convert_dbs <- reactive({
conv_dbs <- input$convert_dbs
return(conv_dbs)
})
stand_indels <- reactive({
stand_indels <- input$stand_indels
return(stand_indels)
})
#Adding the create musica funcionality
tryCatch({
observeEvent(input$get_musica_object, {
shinybusy::show_spinner()
vals$genome <- input$GenomeSelect
if (!is.null(vals$var)) {
vals$musica <- create_musica_from_variants(x = vals$var,
genome = select_genome(vals$genome),
check_ref_chromosomes = check_chr(),
check_ref_bases = check_bases(),
convert_dbs = convert_dbs(),
standardize_indels = stand_indels())
if (req(input$get_musica_object)) {
shinyjs::show(id = "download_musica")
}
else {
shinyjs::hide(id = "download_musica")
}
shinybusy::hide_spinner()
showNotification("Musica Object successfully created! ")
}
else{
shinyalert("Error: Please import files first in the Import section!")
}
})},
error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
},
warning = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
})
output$musica_console <- renderPrint({
return(print(vals$musica_message))
})
#Displaying musica object variants
output$musica_contents <- DT::renderDT({
req(vals$var)
return(head(vals$var))
shinyjs::show(id = "musica_contents")
js$enableTabs()
})
output$musica_contents_summary <- renderText({
req(vals$musica)
vt <- unique(vals$musica@variants$Variant_Type) #variant types
ns <- length(vals$musica@variants$sample) #sample length
mylist <- c("No. of Samples:\n", ns)
return(mylist)
shinyjs::show(id = "musica_contents_summary")
js$enableTabs();
})
output$musica_contents_table <- DT::renderDT({
req(vals$musica)
nvt <- as.data.frame(table(vals$musica@variants$Variant_Type))
return(nvt)
shinyjs::show(id = "musica_contents_table")
js$enableTabs();
})
#Adding resetting functionality
observeEvent(input$reset, {
removeUI("#musica_contents")
removeUI("#musica_contents_summary")
removeUI("#musica_contents_table")
showNotification("Tables cleared!")
})
#Adding upload musica tab functionality
observe(
if (!is.null(req(input$musica_file))) {
vals$musica_name_user <- tools::file_path_sans_ext(input$musica_file$name)
})
#output$musica_result_name <- renderUI(
# textInput("musica_result_name", value = paste0(vals$musica_name_user),
# h3("Name your musica result object:"))
#)
#observeEvent(input$musica_button, {
# if (input$musica_button == "result") {
# shinyjs::show(id = "musica_result_name")
# }
# else if (input$musica_button == "object") {
# shinyjs::hide(id = "musica_result_name")
# }
#})
observeEvent(input$upload_musica, {
req(input$musica_file)
if (all(tools::file_ext(tolower(input$musica_file$name)) !=
c("rda", "rds"))) {
shinyalert::shinyalert(paste0("Error: File format not supported! ",
"Please upload .rda or .rds files"))
}
else{
#if (input$musica_button == "result") {
# if (all(tools::file_ext(tolower(input$musica_file$name)) == "rda")) {
# vals$musica_upload <- load(input$musica_file$datapath)
# vals$musica_upload <- get(vals$musica_upload)
# vals$result_objects[[input$musica_result_name]] <- vals$musica_upload
# }
# else if (all(tools::file_ext(tolower(input$musica_file$name)) ==
# "rds")) {
# vals$musica_upload <- readRDS(input$musica_file$datapath)
# vals$result_objects[[input$musica_result_name]] <- vals$musica_upload
# }
# showNotification("Musica Result Object successfully imported!")
#}
#else if (input$musica_button == "object") {
if (all(tools::file_ext(tolower(input$musica_file$name)) ==
"rda")) {
vals$musica_upload <- load(input$musica_file$datapath)
vals$musica_upload <- get(vals$musica_upload)
vals$musica <- vals$musica_upload
}
else if (all(tools::file_ext(tolower(input$musica_file$name)) ==
"rds")) {
vals$musica_upload <- readRDS(input$musica_file$datapath)
vals$musica <- vals$musica_upload
}
# check if any result objects present
if (length(result_list(vals$musica)) > 0){
for (result_name in names(result_list(vals$musica))){
vals$res_names_full[[result_name]] <- list()
for (modality in names(get_result_list_entry(vals$musica, result_name)@modality)){
vals$res_names_full[[result_name]][[modality]] <- NULL
for (model in names(get_modality(vals$musica, result_name, modality))){
vals$res_names_full[[result_name]][[modality]] <- c(vals$res_names_full[[result_name]][[modality]], model)
vals$res_names <- c(vals$res_names, paste0(result_name, "/", modality, "/", model))
}
}
}
}
vals$var <- variants(vals$musica)
showNotification("Musica Object successfully imported!")
}}
# }
)
#Displaying musica result/object summary table
output$musica_upload <- DT::renderDT({
req(vals$musica_upload)
#if(input$musica_button == "result")
# {return(head(vals$musica_upload@musica@variants))
#}else{
return(head(vals$musica_upload@variants))
# }
shinyjs::show(id = "musica_upload")
js$enableTabs();
})
output$musica_upload_summary <- renderText({
req(vals$musica_upload)
#if(input$musica_button == "result"){
#vt <- unique(vals$musica_upload@musica@variants$Variant_Type) #variant types
#nvt <- table(vals$musica_upload@musica@variants$Variant_Type)
#ns <- length(vals$musica_upload@musica@variants$sample) #sample length
#mylist <- c("No. of Samples:\n", ns, "\n", "Variant types", vt, "\n", nvt)
#return(mylist)
#}else{
vt <- unique(vals$musica_upload@variants$Variant_Type) #variant types
nvt <- table(vals$musica_upload@variants$Variant_Type)
ns <- length(vals$musica_upload@variants$sample) #sample length
mylist <- c("No. of Samples:\n", ns, "\n", "Variant types", vt, "\n", nvt)
return(mylist)
#}
shinyjs::show(id = "musica_upload_summary")
js$enableTabs();
})
observeEvent(input$reset_musica, {
removeUI("#musica_upload")
removeUI("#musica_upload_summary")
showNotification("Tables cleared!")
})
#Adding download feature
output$download_musica <- downloadHandler(
filename = function() {
paste("musica_variants", ".csv", sep = "")
},
content = function(file) {
write.csv(vals$musica@variants, file, row.names = FALSE)
}
)
#output$download_musica_result <- downloadHandler(
# filename = function() {
# paste("musica_variants", ".csv", sep = "")
# },
# content = function(file) {
# if(input$musica_button == "result"){
# write.csv(vals$musica_upload@musica@variants, file, row.names = FALSE)
# }else{
# write.csv(vals$musica_upload@variants, file, row.names = FALSE)
# }
# }
#)
output$download_musica_object <- downloadHandler(
filename = function() {
paste("musica_object", ".rda", sep = "")
},
content = function(file) {
save(as.data.frame(vals$musica), file = filename)
}
)
observeEvent(input$upload, {
# Clear the previous deletions in the import table in the Import files tab
vals$files <- list(input$file[["name"]])
vals$files <- unlist(vals$files)
vals$files <- c(vals$files)
dt <- list(input$file[["datapath"]])
dt <- unlist(dt)
dt <- c(dt)
vals$files <- data.frame(files = vals$files, datapath = dt,
stringsAsFactors = FALSE)
vals$data <- vals$files
vals$deleted_rows <- NULL
vals$deleted_row_indices <- list()
})
observeEvent(input$example, {
#vals$files <- list(system.file("extdata", "public_LUAD_TCGA-97-7938.vcf",
# package = "musicatk"))
#vals$files <- "public_TCGA.LUSC.maf"
#dt <- system.file("extdata", "public_TCGA.LUSC.maf", package = "musicatk")
#vals$files <- data.frame(files = vals$files, datapath = dt,
# stringsAsFactors = FALSE)
#vals$data <- vals$files
#vals$deleted_rows <- NULL
#vals$deleted_row_indices <- list()
shinybusy::show_spinner()
#vars <- extract_variants_from_maf_file(system.file("extdata", "public_TCGA.LUSC.maf", package = "musicatk"))
#vals$var <- vars
data(musica_annot)
vals$musica <- musica_annot
vals$var <- vals$musica@variants
shinybusy::hide_spinner()
showNotification("Example musica object imported. Proceed to discovery/prediction.")
})
observeEvent(input$deletep_ressed, {
row_num <- parse_delete_event(input$deletep_ressed)
data_row <- vals$data[row_num, ]
vals$deleted_rows <- rbind(data_row, vals$deleted_rows)
vals$deleted_row_indices <- append(vals$deleted_row_indices,
row_num, after = 0)
# Delete the row from the data frame
vals$data <- vals$data[-row_num, ]
})
observeEvent(input$undo, {
if (nrow(vals$deleted_rows) > 0) {
row <- vals$deleted_rows[1, ]
vals$data <- add_row_at(vals$data, row, vals$deleted_row_indices[[1]])
# Remove row
vals$deleted_rows <- vals$deleted_rows[-1, ]
# Remove index
vals$deleted_row_indices <- vals$deleted_row_indices[-1]
}
})
#Disable the undo button if we have not deleted anything
output$undo_ui <- renderUI({
if (!is.null(vals$deleted_rows) && nrow(vals$deleted_rows) > 0) {
actionButton("undo", label = "Undo delete", icon("undo"))
} else {
actionButton("undo", label = "Undo delete", icon("undo"), disabled = TRUE)
}
})
output$dtable <- DT::renderDT({
# Add the delete button column
req(vals$data)
delete_button_column(vals$data, "delete_button")
})
#Code taken from an online open source
#' Adds a row at a specified index
#'
#' @param df a data frame
#' @param row a row with the same columns as \code{df}
#' @param i the index we want to add row at.
#' @return the data frame with \code{row} added to \code{df} at index \code{i}
add_row_at <- function(df, row, i) {
if (i > 1) {
rbind(df[1:(i - 1), ], row, df[- (1:(i - 1)), ])
} else {
rbind(row, df)
}
}
#' A column of delete buttons for each row in the data frame for the
#' first column
#'
#' @param df data frame
#' @param id id prefix to add to each actionButton. The buttons will be
#' id'd as id_INDEX.
#' @return A DT::datatable with escaping turned off that has the delete
#' buttons in the first column and \code{df} in the other
delete_button_column <- function(df, id, ...) {
# function to create one action button as string
f <- function(i) {
# https://shiny.rstudio.com/articles/communicating-with-js.html
as.character(actionButton(paste(id, i, sep = "_"), label = NULL,
icon = icon("trash"),
onclick =
paste('Shiny.setInputValue(\"deletep_ressed\",',
'this.id, {priority: "event"})')))
}
delete_col <- unlist(lapply(seq(nrow(df)), f))
# Return a data table
DT::datatable(cbind(delete = delete_col, df),
# Need to disable escaping for html as string to work
escape = FALSE,
options = list(
# Disable sorting for the delete column
columnDefs = list(list(targets = 1, sortable = FALSE))
))
}
#' Extracts the row id number from the id string
#' @param idstr the id string formated as id_INDEX
#' @return INDEX from the id string id_INDEX
parse_delete_event <- function(idstr) {
res <- as.integer(sub(".*_([0-9]+)", "\\1", idstr))
if (! is.na(res)) res
}
###############################################################################
###################### Nathan's Code ##########################################
# rep_range needed for SBS192 replication strand
data(rep_range)
# needed to predict cosmic sigs
data("cosmic_v2_sigs")
data("cosmic_v3_sbs_sigs")
data("cosmic_v3_dbs_sigs")
data("cosmic_v3_indel_sigs")
# Renaming COSMIC signatures.
sbs_aet <- list("SBS1" =
"SBS1 - Spontaneous deamination of 5-methylcytosine",
"SBS2" = "SBS2 - APOBEC activity",
"SBS3" = "SBS3 - HR deficiency",
"SBS4" = "SBS4 - Tobacco smoking",
"SBS5" =
"SBS5 - Unknown (Aging / Tobacco smoking / NER deficiency)",
"SBS6" = "SBS6 - MMR deficiency",
"SBS7a" = "SBS7a - UV light exposure",
"SBS7b" = "SBS7b - UV light exposure",
"SBS7c" = "SBS7c - UV light exposure",
"SBS7d" = "SBS7d - UV light exposure",
"SBS8" = "SBS8 - Unknown (HR deficiency / NER deficiency)",
"SBS9" =
"SBS9 - Unknown (Polymerase eta somatic hypermutation)",
"SBS10a" = "SBS10a - POLE exonuclease domain mutation",
"SBS10b" = "SBS10b - POLE exonuclease domain mutation",
"SBS10c" = "SBS10c - Unknown (Defective POLD1 proofreading)",
"SBS10d" = "SBS10d - Unknown (Defective POLD1 proofreading)",
"SBS11" =
paste0("SBS11 - Unknown (Temozolomide chemotherapy ",
"/ MMR deficiency + temozolomide)"),
"SBS12" = "SBS12 - Unknown",
"SBS13" = "SBS13 - APOBEC activity",
"SBS14" = "SBS14 - MMR deficiency + POLE mutation",
"SBS15" = "SBS15 - MMR deficiency",
"SBS16" = "SBS16 - Unknown",
"SBS17a" = "SBS17a - Unknown (Damage by ROS)",
"SBS17b" =
"SBS17b - Unknown (Damage by ROS / 5FU chemotherapy)",
"SBS18" = "SBS18 - Damage by ROS",
"SBS19" = "SBS19 - Unknown",
"SBS20" = "SBS20 - MMR deficiency + POLD1 mutation",
"SBS21" = "SBS21 - MMR deficiency",
"SBS22" = "SBS22 - Aristolochic acid exposure",
"SBS23" = "SBS23 - Unknown",
"SBS24" = "SBS24 - Aflatoxin exposure",
"SBS25" = "SBS25 - Unknown (Unknown chemotherapy)",
"SBS26" = "SBS26 - MMR deficiency",
"SBS27" = "SBS27 - Sequencing artifact",
"SBS28" =
"SBS28 - Unknown (POLE exonuclease domain mutation)",
"SBS29" = "SBS29 - Unknown (Tobacco chewing)",
"SBS30" = "SBS30 - BER deficiency",
"SBS31" = "SBS31 - Platinum chemotherapy",
"SBS32" = "SBS32 - Azathioprine exposure",
"SBS33" = "SBS33 - Unknown (Unknown)",
"SBS34" = "SBS34 - Unknown",
"SBS35" = "SBS35 - Platinum chemotherapy",
"SBS36" = "SBS36 - BER deficiency",
"SBS37" = "SBS37 - Unknown",
"SBS38" =
"SBS38 - Unknown (UV light exposure (indirect effect))",
"SBS39" = "SBS39 - Unknown",
"SBS40" = "SBS40 - Unknown",
"SBS41" = "SBS41 - Unknown",
"SBS42" = "SBS42 - Haloalkanes exposure",
"SBS43" = "SBS43 - Unknown (Possible sequencing artifact)",
"SBS44" = "SBS44 - MMR deficiency",
"SBS45" =
"SBS45 - 8-oxo-guanine introduced during sequencing",
"SBS46" =
"SBS46 - Sequencing artifact (early releases of TCGA)",
"SBS47" =
paste0("SBS47 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS48" =
paste0("SBS48 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS49" =
paste0("SBS49 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS50" =
paste0("SBS50 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS51" = "SBS51 - Unknown (Possible sequencing artifact)",
"SBS52" =
paste0("SBS52 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS53" =
paste0("SBS53 - Sequencing artifact ",
"(blacklisted cancer samples for poor quality)"),
"SBS54" = "SBS54 - Germline variants contamination",
"SBS55" = "SBS55 - Unknown (Possible sequencing artifact)",
"SBS56" = "SBS56 - Unknown (Possible sequencing artifact)",
"SBS57" = "SBS57 - Unknown (Possible sequencing artifact)",
"SBS58" = "SBS58 - Unknown (Possible sequencing artifact)",
"SBS59" = "SBS59 - Unknown (Possible sequencing artifact)",
"SBS60" = "SBS60 - Sequencing artifact",
"SBS84" = "SBS84 - AID activity",
"SBS85" = "SBS85 - AID activity",
"SBS86" = "SBS86 - Unkown (Unknown chemotherapy)",
"SBS87" = "SBS87 - Thiopurine chemotherapy",
"SBS88" = "SBS88 - Colibactin exposure",
"SBS89" = "SBS89 - Unknown",
"SBS90" = "SBS90 - Duocarmycin exposure",
"SBS91" = "SBS91 - Unknown",
"SBS92" = "SBS92 - Unknown (Tobacco smoking)",
"SBS93" = "SBS93 - Unknown",
"SBS94" = "SBS94 - Unknown"
)
dbs_aet <- list("DBS1" = "DBS1 - UV light exposure",
"DBS2" =
"DBS2 - Unknown (Tobacco smoking / Acetaldehyde exposure)",
"DBS3" = "DBS3 - POLE exonuclease domain mutation",
"DBS4" = "DBS4 - Unknown",
"DBS5" = "DBS5 - Platinum chemotherapy",
"DBS6" = "DBS6 - Unknown",
"DBS7" = "DBS7 - MMR deficiency",
"DBS8" = "DBS8 - Unknown",
"DBS9" = "DBS9 - Unknown",
"DBS10" = "DBS10 - MMR deficiency",
"DBS11" = "DBS11 - Unknown (APOBEC activity)"
)
indel_aet <- list("ID1" =
"ID1 - Slippage of nascent strand during DNA replication",
"ID2" =
paste0("ID2 - Slippage of template strand during ",
"DNA replication"),
"ID3" = "ID3 - Tobacco smoking",
"ID4" = "ID4 - Unknown",
"ID5" = "ID5 - Unknown",
"ID6" = "ID6 - HR deficiency",
"ID7" = "ID7 - MMR deficiency",
"ID8" =
"ID8 - Unknown (DSB repair by NHEJ / TOP2A mutation)",
"ID9" = "ID9 - Unknown",
"ID10" = "ID10 - Unknown",
"ID11" = "ID11 - Unknown",
"ID12" = "ID12 - Unknown",
"ID13" = "ID13 - UV light exposure",
"ID14" = "ID14 - Unknown",
"ID15" = "ID15 - Unknown",
"ID16" = "ID16 - Unknown",
"ID17" = "ID17 - TOP2A mutation",
"ID18" = "ID18 - Colibactin exposure"
)
colnames(signatures(cosmic_v3_sbs_sigs)) <-
sbs_aet[colnames(signatures(cosmic_v3_sbs_sigs))]
colnames(signatures(cosmic_v3_dbs_sigs)) <-
dbs_aet[colnames(signatures(cosmic_v3_dbs_sigs))]
colnames(signatures(cosmic_v3_indel_sigs)) <-
indel_aet[colnames(signatures(cosmic_v3_indel_sigs))]
cosmic_objects <- list("cosmic_v3_sbs_sigs" = cosmic_v3_sbs_sigs,
"cosmic_v3_dbs_sigs" = cosmic_v3_dbs_sigs,
"cosmic_v3_indel_sigs" = cosmic_v3_indel_sigs,
"cosmic_v2_sigs" = cosmic_v2_sigs)
# Update musica object list whenever a result or musica object is altered
output$annotation_musica_list <- renderUI({
#result_names <- list(names(vals$result_objects))
#if (is.null(vals$musica)) {
# tagList(
# selectInput("annotation_musica_list", "Select object",
# choices = list("result objects" =
# list(names(vals$result_objects))))
# )
#} else if (is.null(result_names[[1]])) {
tagList(
selectInput("annotation_musica_list", "Select object",
choices = list("musica object" = list("musica")))
)
#}
#else {
# tagList(
# selectInput("annotation_musica_list", "Select object",
# choices = list("musica object" = list("musica"),
# "result objects" =
# list(names(vals$result_objects))))
# )
#}
})
# Input to choose the annotation delimiter.
observeEvent(input$annotation_delimiter, {
if (input$annotation_delimiter == "custom") {
shinyjs::show(id = "CustomAnnotDelim")
} else {
shinyjs::hide(id = "CustomAnnotDelim")
}
})
# Read the annotation file, store it in vals$annotations, and display the
# contents as a data table.
output$annotations <- DT::renderDT({
file <- input$annotations_file
ext <- tools::file_ext(file$datapath)
req(file)
delim <- input$annotation_delimiter
if (delim == "custom") {
delim <- input$CustomAnnotDelim
}
vals$annotations <- read.delim(file$datapath,
header = input$annotation_header,
sep = delim,
as.is = TRUE)
vals$annotations
}, options = list(autoWidth = FALSE, scrollX = TRUE))
# Input to choose the column containing the sample names.
output$annotation_samples <- renderUI({
if (is.null(vals$annotations)) {
return(NULL)
}
tagList(
selectInput("annot_sample_column", "Sample Name Column",
choices = colnames(vals$annotations))
)
})
# Add annotations to the provided musica_object
add_annot <- function(musica_object) {
new_annot <- merge(samp_annot(musica_object),
vals$annotations, by.x = "Samples",
by.y = input$annot_sample_column,
all.x = TRUE)
for (a in names(new_annot)) {
samp_annot(musica_object, a) <-
new_annot[, a]
}
showNotification("Annotations have been added")
return(musica_object)
}
# Event that triggers add_annotation function.
observeEvent(input$add_annotation, {
# Add annotation to result object
#if (!is.null(get_result(input$annotation_musica_list))) {
# tryCatch({
# vals$result_objects[[input$annotation_musica_list]] <-
# add_annot(vals$result_objects[[input$annotation_musica_list]])
# }, error = function(cond) {
# shinyalert::shinyalert(title = "Error", text = cond$message)
# return()
# })
# Add annotation to musica object
if (!is.null(vals$musica)) {
tryCatch({
vals$musica <- add_annot(vals$musica)
}, error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
return()
})
} else {
print("Error: selected object does not exist")
}
})
####### Section for the Build Table Tab #######
# Input to select count table
output$discover_table <- renderUI({
tagList(
selectInput("select_discover_table", "Select Modality",
choices = names(
extract_count_tables(vals$musica))),
bsTooltip("select_discover_table",
"Modality to use for signature discovery.",
placement = "right", trigger = "hover", options = NULL)
)
})
# UI for inputs to combine tables.
output$combine_table <- renderUI({
if (length(names(extract_count_tables(vals$musica))) > 1) {
tagList(
box(width = 6,
helpText(paste0("Combine any 2 or more tables contained in your ",
"musica object. This is optional.")),
checkboxGroupInput("combine_tables", "Tables to Combine",
choices = names(extract_count_tables(vals$musica))),
textInput("combined_table_name", "Name of combined table"),
uiOutput("combine_warning"),
actionButton("Combine", "Build Combined Table"),
bsTooltip("combined_table_name",
"Combine tables into a single table that can be used for
discovery/prediction.",
placement = "bottom", trigger = "hover", options = NULL),
bsTooltip("Combine",
paste0("Combines tables into a single table that can ",
"be used for discovery/prediction."),
placement = "bottom", trigger = "hover", options = NULL),
bsTooltip("combine_tables",
"Tables to combine.",
placement = "left", trigger = "hover", options = NULL),
bsTooltip("combined_table_name",
"Name for the combined table.",
placement = "bottom", trigger = "hover", options = NULL)
)
)
}
})
#
observeEvent(input$Combine, {
if (input$combined_table_name == "" | length(input$combine_tables) < 2) {
output$combine_warning <- renderText({
validate(
need(input$combined_table_name != "",
"You must provide a name for the new result object."),
need(length(input$combine_tables) < 2,
"You must select two or more tables to combine.")
)
})
return()
}
shinybusy::show_spinner()
tryCatch({
combine_count_tables(vals$musica, input$combine_tables,
input$combined_table_name)
}, error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
shinybusy::hide_spinner()
})
shinybusy::hide_spinner()
showNotification("Table created.")
})
output$allow_table <- renderUI({
if (!is.null(vals$musica)) {
tagList(
actionButton("add_table", "Create Table"),
bsTooltip("add_table",
paste0("Create a table containig the mutationl count ",
"information of each sample."),
placement = "bottom", trigger = "hover",
options = NULL)
)
} else {
tagList(
helpText("You must first create or upload a musica object to generate
count tables.")
)
}
})
# Event listener for add table button.
observeEvent(input$add_table, {
table_name <- input$select_table
if (table_name == "SBS192 - Replication_Strand") {
table_name <- "SBS192_Rep"
}
if (table_name == "SBS192 - Transcript_Strand") {
table_name <- "SBS192_Trans"
}
if (table_name %in% names(extract_count_tables(vals$musica))) {
# Modal to confirm overwrite of existing table
showModal(modalDialog(
title = "Existing Table.",
"Do you want to overwrite the existing table?",
easyClose = TRUE,
footer = list(
actionButton("confirmOverwrite", "OK"),
modalButton("Cancel"))
))
} else{
add_tables(input, vals)
}
})
# Function used in server.R to add counts tables.
add_tables <- function(input, vals) {
table_name <- input$select_table
strand_type <- NULL
if (input$select_table != "Custom") {
# Check inputs for SBS192
if (input$select_table == "SBS192 - Transcript_Strand") {
annotate_transcript_strand(vals$musica, input$table_genome_list,
build_table = FALSE)
table_name <- "SBS192"
strand_type <- "Transcript_Strand"
}
if (input$select_table == "SBS192 - Replication_Strand") {
annotate_replication_strand(vals$musica, rep_range, build_table = FALSE)
table_name <- "SBS192"
strand_type <- "Replication_Strand"
}
tryCatch({
build_standard_table(vals$musica,
select_genome(input$table_genome_list),
modality = table_name,
strand_type = strand_type,
overwrite = TRUE)
shiny::showNotification("Table created.")
}, error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
}
)
return()
}
shinyalert::shinyalert(title = "Oops",
text = "Custom tables are not yet supported.")
}
# Confirm overwrite for existing table
observeEvent(input$confirmOverwrite, {
removeModal()
add_tables(input, vals)
})
####### Section for the Discover Signatures and Exposures Tab #######
# Event listener for discover_signatures.
observeEvent(input$discover_signatures, {
if (input$discover_result_name == "" |
input$discover_model_name == "" |
input$number_of_signatures == "" |
input$n_start == "" |
dim(extract_count_tables(vals$musica)[[
input$select_discover_table]]@count_table)[2] < 2 |
input$number_of_signatures < 2) {
output$discover_warning <- renderText({
validate(
need(input$discover_result_name != "",
"You must provide a result list name."),
need(input$discover_model_name != "",
"You must provide a model ID."),
need(input$number_of_signatures != "",
"You must specify the number of expected signatures."),
need(input$n_start != "",
"Please specify the number of random starts."),
need(input$number_of_signatures >= 2,
"Must specify 2 or more signatures."),
need(dim(extract_count_tables(vals$musica)[[
input$select_discover_table]]@count_table)[2] > 2,
"You must provide 2 or more samples")
)
})
return()
}
if (paste0(input$discover_result_name, "/", input$select_discover_table, "/", input$discover_model_name) %in% names(vals$res_names)) {
#if ("lda5" %in% names(vals$result_objects)) {
# Confirm overwrite of result object
showModal(modalDialog(
title = "This model ID already exists in the chosen result list entry.",
"Do you want to overwrite the existing result?",
easyClose = TRUE,
footer = list(
actionButton("confirm_result_overwrite", "OK"),
modalButton("Cancel"))
))
} else {
disc_sigs(input, vals)
showNotification(paste0("Disocvery, ",
input$discover_model_name,
", completed and saved to ",
input$discover_result_name, "."))
}
})
# Wrapper function for discover_signature
disc_sigs <- function(input, vals) {
name <- paste0(input$discover_result_name, "/", input$select_discover_table, "/", input$discover_model_name)
vals$musica <- discover_signatures(
vals$musica, modality = input$select_discover_table,
num_signatures = as.numeric(input$number_of_signatures),
algorithm = input$Method, result_name = input$discover_result_name,
model_id = input$discover_model_name,
#seed = input$Seed,
nstart = as.numeric(input$n_start), make_copy = TRUE)
#set_result(name, "test")
vals$res_names <- c(vals$res_names, name)
vals$res_names_full[[input$discover_result_name]][[input$select_discover_table]] <-
c(vals$res_names_full[[input$discover_result_name]][[input$select_discover_table]],
input$discover_model_name)
}
# Run discover_signatures if overwrite confirmed.
observeEvent(input$confirm_result_overwrite, {
removeModal()
disc_sigs(input, vals)
showNotification("Existing result overwritten.")
})
# Discover Musica Result Object
output$discover_result_name <- renderUI({
#name <- input$select_discover_table
tagList(
textInput("discover_result_name", "Name of result list entry to save result",
value = "result"),
bsTooltip("discover_result_name",
"Which result list entry the discovery results will be stored in.",
placement = "right", trigger = "hover", options = NULL)
)
})
output$discover_model_name <- renderUI({
#name <- input$select_discover_table
tagList(
textInput("discover_model_name", "Model ID for the result",
value = paste0(input$Method, input$number_of_signatures)),
bsTooltip("discover_model_name",
"An identifier for the discovery result.",
placement = "right", trigger = "hover", options = NULL)
)
})
# UI to select musica object.
#output$discover_musica_list <- renderUI({
# tagList(
# selectInput("discover_musica_list", h3("Select Musica Object"),
# choices = names(vals$result_objects))
# )
#})
# Select counts table for prediction.
output$predict_table <- renderUI({
tagList(
selectInput("predict_table", "Select Modality",
choices = names(extract_count_tables(vals$musica))),
bsTooltip("predict_table",
"Modality used for posterior prediction",
placement = "right", trigger = "hover", options = NULL)
)
})
# Event listener alters UI based on selected COSMIC table.
#observeEvent(input$predict_table, {
# if (input$predict_table == "SBS96") {
# shinyjs::show(id = "cosmic_SBS_sigs")
# shinyjs::hide(id = "cosmic_DBS_sigs")
# shinyjs::hide(id = "cosmic_INDEL_sigs")
# } else if (input$predict_table == "DBS78") {
# shinyjs::hide(id = "cosmic_SBS_sigs")
# shinyjs::show(id = "cosmic_DBS_sigs")
# shinyjs::hide(id = "cosmic_INDEL_sigs")
# } else {
# shinyjs::hide(id = "cosmic_SBS_sigs")
# shinyjs::hide(id = "cosmic_DBS_sigs")
# shinyjs::show(id = "cosmic_INDEL_sigs")
# }
#})
# UI to name Predict result object
output$predict_result_name <- renderUI({
#name <- names(extract_count_tables(vals$musica))[1]
tagList(
textInput("predict_result_name", "Name of result list entry to save result",
value = "result"),
bsTooltip("predict_result_name",
"Which result list entry the discovery results will be stored in.",
placement = "right", trigger = "hover", options = NULL)
)
})
output$predict_model_name <- renderUI({
tagList(
textInput("predict_model_name", "Model ID for the result",
value = paste0(input$Method, length(input$pred_sigs), "_exp_pred")),
bsTooltip("predict_model_name",
"An identifier for the prediction result.",
placement = "right", trigger = "hover", options = NULL)
)
})
# UI to select which result objects to predict.
output$predicted_result <- renderUI({
other <- vals$res_names
if (is.null(other)) {
tagList(
selectInput("predicted_result", "Result to Predict",
choices = list("Cosmic" = list(
"Cosmic V3 SBS Signatures" = "cosmic_v3_sbs_sigs",
"Cosmic V3 DBS Signatures" = "cosmic_v3_dbs_sigs",
"Cosmic V3 INDEL Signatures" = "cosmic_v3_indel_sigs",
"Cosmic V2 Signatures" = "cosmic_v2_sigs"
)),
selected = "cosmic_v3_sbs_sigs"),
bsTooltip("predicted_result",
"Result model object containing the signatures to predict.
Can use existing COSMIC signatures or signatures from a
previously generated result_model object.",
placement = "right", trigger = "hover", options = NULL)
) }
else {
tagList(
selectInput("predicted_result", "Result to Predict",
choices = list("Cosmic" = list(
"Cosmic V3 SBS Signatures" = "cosmic_v3_sbs_sigs",
"Cosmic V3 DBS Signatures" = "cosmic_v3_dbs_sigs",
"Cosmic V3 INDEL Signatures" = "cosmic_v3_indel_sigs",
"Cosmic V2 Signatures" = "cosmic_v2_sigs"),
"your signatures" = as.list(other)),
selected = "cosmic_v3_sbs_sigs"),
#bsTooltip("predicted_result",
# "Result model object containing the signatures to predict.
# Can use existing COSMIC signatures or signatures from a
# previously generated result_model object.",
# placement = "right", trigger = "hover", options = NULL)
)
}
})
# UI to select signatures to predict
observeEvent(input$predicted_result, {
output$predicted_signatures <- renderUI({
if (input$predicted_result %in% names(cosmic_objects)) {
vals$p_sigs <- colnames(signatures(
cosmic_objects[[input$predicted_result]]))
vals$p_res <- cosmic_objects[[input$predicted_result]]
}
else {
identifiers <- strsplit(input$predicted_result, "/")[[1]]
vals$p_sigs <- colnames(signatures(vals$musica, identifiers[1], identifiers[2], identifiers[3]))
#vals$p_sigs <- colnames(signatures(
# vals$result_objects[[input$predicted_result]]))
vals$p_res <- get_model(vals$musica, identifiers[1], identifiers[2], identifiers[3])
#vals$p_res <- vals$result_objects[[input$predicted_result]]
}
tagList(
shinyWidgets::dropdownButton(circle = FALSE, label = "Signatures",
div(style =
"max-height:80vh; overflow-y: scroll",
checkboxGroupInput("pred_sigs", "",
choices = vals$p_sigs, inline = FALSE,
selected = vals$p_sigs))),
bsTooltip("predicted_signatures",
"Signatures to predict.",
placement = "right", trigger = "hover", options = NULL),
bsTooltip("predicted_result",
"Result model object containing the signatures to predict.
Can use existing COSMIC signatures or signatures from a
previously generated result_model object.",
placement = "right", trigger = "hover", options = NULL)
)
})
})
# Event listener for Predict signatures
observeEvent(input$predict_sigs, {
if (input$predict_result_name == "" |
input$predict_model_name == "" |
length(input$pred_sigs) < 2) {
output$predict_warning <- renderText({
validate(
need(input$predict_result_name != "",
"You must provide a result list name."),
need(input$predict_model_name != "",
"You must provide a model ID."),
need(length(c(input$pred_sigs)) >= 2,
"You must select two or more signatures to predict.")
)
})
return()
}
if (paste0(input$predict_result_name, "/", input$predict_table,
"/", input$predict_model_name) %in% names(vals$res_names)) {
#if (input$predict_result_name %in% names(vals$result_objects)) {
showModal(modalDialog(
title = "This model ID already exists in the chosen result list entry.",
"Do you want to overwrite the existing result object?",
easyClose = TRUE,
footer = list(
actionButton("confirm_predict_overwrite", "OK"),
modalButton("Cancel"))
))
} else {
get_predict(input, vals)
showNotification(paste0("Prediction, ",
input$predict_model_name,
", completed and saved to ",
input$predict_result_name, "."))
}
})
# Event listener displays additional options for deconstructSigs algorithm.
#observeEvent(input$predict_algorithm, {
# if (input$predict_algorithm == "deconstructSigs") {
# shinyjs::show(id = "predict_genome_list")
# } else {
# shinyjs::hide(id = "predict_genome_list")
# }
#})
# Wrapper function for predict_exposures
get_predict <- function(inputs, vals) {
name <- paste0(input$predict_result_name, "/", input$predict_table, "/", input$predict_model_name)
vals$musica <- predict_exposure(
vals$musica,
modality = input$predict_table,
signature_res = vals$p_res,
algorithm = input$predict_algorithm,
result_name = input$predict_result_name,
model_id = input$predict_model_name,
signatures_to_use = input$pred_sigs,
make_copy = TRUE)
#set_result(name, "test")
vals$res_names <- c(vals$res_names, name)
vals$res_names_full[[input$predict_result_name]][[input$predict_table]] <-
c(vals$res_names_full[[input$predict_result_name]][[input$predict_table]],
input$predict_model_name)
}
# Event triggers predict_exposures when user confirms overwrite.
observeEvent(input$confirm_predict_overwrite, {
removeModal()
get_predict(input, vals)
showNotification("Existing result overwritten.")
})
####### Compare Tab ########
observeEvent(input$cosmic_button, {
if (input$cosmic_button == "cosmic") {
shinyjs::hide(id = "compare_result_b")
shinyjs::hide(id = "compare_model_b")
shinyjs::show(id = "compare_result_b_cosmic")
}
else if (input$cosmic_button == "model") {
shinyjs::show(id = "compare_result_b")
shinyjs::show(id = "compare_model_b")
shinyjs::hide(id = "compare_result_b_cosmic")
}
})
output$compare_result_a <- renderUI({
tagList(
selectInput("select_result_a", "Select result list name",
choices = c(names(vals$res_names_full))),
bsTooltip("select_result_a",
"A result list name",
placement = "right", trigger = "hover", options = NULL)
)
})
observeEvent(input$select_result_a, {
output$compare_modality_a <- renderUI({
tagList(
selectInput("select_modality_a", "Select modality",
choices = c(names(vals$res_names_full[[input$select_result_a]]))),
bsTooltip("select_modality_a",
"A modality",
placement = "right", trigger = "hover", options = NULL)
)
})
})
observeEvent(input$select_modality_a, {
output$compare_model_a <- renderUI({
tagList(
selectInput("select_model_a", "Select model ID",
choices = c("", vals$res_names_full[[input$select_result_a]][[input$select_modality_a]]),
selected = NULL),
bsTooltip("select_model_a",
"A model ID",
placement = "right", trigger = "hover", options = NULL)
)
})
})
observeEvent(input$cosmic_button, {
if (input$cosmic_button == "model") {
observeEvent(input$select_modality_a, {
output$compare_result_b <- renderUI({
tagList(
selectInput("select_result_b", "Select comparison result list name",
#choices = list("cosmic signatures" =
# as.list(names(cosmic_objects)),
# "your signatures" = as.list(
# names(vals$result_objects)))),
choices = c(names(vals$res_names_full)),
selected = input$select_result_a),
bsTooltip("select_result_b",
"Result list name for other model being compared",
placement = "right", trigger = "hover", options = NULL)
)
})
})
observeEvent(input$select_result_b, {
output$compare_model_b <- renderUI({
tagList(
selectInput("select_model_b", "Select model ID",
choices = c("", vals$res_names_full[[input$select_result_b]][[input$select_modality_a]]),
selected = NULL),
bsTooltip("select_model_a",
"A model ID",
placement = "right", trigger = "hover", options = NULL)
)
})
})
}
else{
output$compare_result_b_cosmic <- renderUI({
tagList(
selectInput("select_result_b_cosmic", "Select Cosmic",
choices = as.list(names(cosmic_objects))),
bsTooltip("select_result_b_cosmic",
"Cosmic database to compare to",
placement = "right", trigger = "hover", options = NULL)
)
})
}
})
# Event listener triggers comparison.
observeEvent(input$compare_results, {
if (is.null(input$select_result_a) | input$select_result_a == "" |
input$select_model_a == "" |
input$Threshold == "") {
output$compare_validate <- renderText({
validate(
need(input$select_result_a != "",
"Please select a result object to compare."),
need(input$select_model_a != "",
"Please select a model ID to compare."),
need(input$Threshold == "",
"Please provide a similarity threshold from 0 to 1.")
)
})
return()
}
# Retreive either cosmic or custom result objects.
#if (input$select_result_b %in% names(cosmic_objects)) {
# other <- cosmic_objects[[input$select_result_b]]
#} else {
# other <- isolate(get_result(input$select_result_b))
#}
# Attempt to compare signatures
tryCatch({
if (input$cosmic_button == "cosmic"){
if(input$select_result_b_cosmic == "cosmic_v2_sigs"){
isolate(vals$comparison <-
compare_cosmic_v2(vals$musica, model_id = input$select_model_a,
modality = input$select_modality_a,
result_name = input$select_result_a,
threshold = as.numeric(input$Threshold),
metric = input$compare_metric,
result_rename = paste0(input$select_model_a)))
b_name <- input$select_result_b_cosmic
}
else{
isolate(vals$comparison <-
compare_cosmic_v3(vals$musica, model_id = input$select_model_a,
sample_type = "genome",
modality = input$select_modality_a,
result_name = input$select_result_a,
threshold = as.numeric(input$Threshold),
metric = input$compare_metric,
result_rename = paste0(input$select_model_a)))
b_name <- input$select_result_b_cosmic
}
}
else{
isolate(vals$comparison <-
compare_results(vals$musica, model_id = input$select_model_a,
other_model_id = input$select_model_b,
modality = input$select_modality_a,
result_name = input$select_result_a,
other_result_name = input$select_result_b,
threshold = as.numeric(input$Threshold),
metric = input$compare_metric,
result_rename = paste0(input$select_model_a),
other_result_rename = paste0(input$select_model_b)))
b_name <- input$select_model_b
}
#isolate(vals$comparison <-
# compare_results(isolate(get_result(input$select_result_a)),
# other, threshold = as.numeric(input$Threshold),
# metric = input$compare_metric))
}, error = function(cond) {
shinyalert::shinyalert(title = "Error", text = cond$message)
})
colnames(vals$comparison) <- c(input$compare_metric,
paste0(input$select_model_a, "-Index"),
paste0(b_name, "-Index"),
paste0(input$select_model_a, "-Signature"),
paste0(b_name, "-Signature"))
# generate table containing comparison statistics.
if (!is.null(isolate(vals$comparison))) {
output$compare_table <- DT::renderDT({
isolate(vals$comparison)
}, options = list(autoWidth = FALSE, scrollX = TRUE))
output$download_comparison <- renderUI({
tagList(
downloadButton("download_compare", "Download"),
bsTooltip("download_compare",
"Download the comparison table",
placement = "bottom", trigger = "hover", options = NULL)
)
})
}
})
output$download_compare <- downloadHandler(
filename = function() {
paste0("Sig-Compare-", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(vals$comparison, file)
}
)
######## Differential Analysis Tab #########
output$diff_anal_result <- renderUI({
tagList(
selectInput("diff_anal_result", "Result list name",
choices = names(vals$res_names_full)),
bsTooltip("diff_anal_result", "Name of result list entry containing desiered result")
)
})
observeEvent(input$diff_anal_result, {
output$diff_anal_modality <- renderUI({
tagList(
selectInput("diff_anal_modality", "Modality",
choices = c(names(vals$res_names_full[[input$diff_anal_result]]))),
bsTooltip("diff_anal_modality", "Desired modality")
)
})
})
observeEvent(input$diff_anal_modality, {
output$diff_anal_model <- renderUI({
tagList(
selectInput("diff_anal_model", "Model ID",
choices = c("", vals$res_names_full[[input$diff_anal_result]][[input$diff_anal_modality]])),
bsTooltip("diff_anal_model", "Model ID of desired result")
)
})
})
# UI for Wilcoxon Rank Sum Test bucket list
observeEvent(input$diff_anal_annot, {
output$diff_anal_groups <- renderUI({
if (interactive()) {
tagList(
sortable::bucket_list(
header = "Groups",
orientation = "horizontal",
add_rank_list(
text = "Group 1",
labels = unique(samp_annot(vals$musica)[[input$diff_anal_annot]]),
input_id = "diff_group1"
),
add_rank_list(
text = "Group2",
input_id = "diff_group2"
)
)
)
}
})
})
# UI to select sample annotation.
output$diff_anal_annot <- renderUI({
tagList(
selectInput("diff_anal_annot", "Sample annotation",
choices = colnames(
samp_annot(vals$musica))[-1],
selected = 1),
bsTooltip("diff_anal_annot",
"Sample annotation used to run differential analysis.")
)
})
# Event handler controls Wilcoxon bucket list.
observeEvent(input$diff_method, {
method <- input$diff_method
if (method == "wilcox") {
shinyjs::show(id = "diff_anal_groups")
} else {
shinyjs::hide(id = "diff_anal_groups")
}
})
# Event handler for differential analysis.
observeEvent(input$run_diff_anal, {
shinyjs::hide("diff_error")
g1 <- input$diff_group1
g2 <- input$diff_group2
errors <- NULL
if (!is.null(g1) & !is.null(g2)) {
g_min <- min(length(g1), length(g2))
g1 <- g1[1:g_min]
g2 <- g2[1:g_min]
}
# Run differential analysis
tryCatch({
vals$diff <-
exposure_differential_analysis(vals$musica,
model_name = input$diff_anal_model,
annotation = input$diff_anal_annot,
modality = input$diff_anal_modality,
result_name = input$diff_anal_result,
method = input$diff_method,
group1 = g1,
group2 = g2)
output$diff_table <- DT::renderDT(
if (input$diff_method == "wilcox") {
vals$diff
} else {
if(colnames(vals$diff)[1] != "Signature"){
vals$diff %>% tibble::rownames_to_column(var = "Signature")
}
#vals$diff %>% tibble::rownames_to_column(var = "Signature")
},
options = list(autoWidth = FALSE, scrollX = TRUE)
)
}, error = function(cond) {
output$diff_table <- DT::renderDT({
NULL
})
})
output$diff_error <- renderText({
errors
})
})
# Download differential analysis results.
output$download_diff <- downloadHandler(
filename = function() {
paste0("Exp-Diff-", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(vals$diff, file)
}
)
####### Helper Functions #######
# Set a result object
#set_result <- function(x, y) {
# vals$result_objects[[x]] <- y
#}
#get_result <- function(name) {
# return(vals$result_objects[[name]])
#}
#example_load = reactive({
# req(input$file)
# vars <- extract_variants_from_vcf_file(system.file("extdata", "public_LUAD_TCGA-97-7938.vcf", package = "musicatk"))
# return(vars)
#})
###############################################################################
##################Visualization#################
#select box for signature
output$select_res1 <- renderUI({
tagList(
selectInput(
inputId = "selected_res1",
label = "Select result list name",
choices = c(names(vals$res_names_full)),
width = "50%"
),
bsTooltip(id = "selected_res1",
title =
"Select the result list entry that contains the desired signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
observeEvent(input$selected_res1, {
output$select_modality1 <- renderUI({
tagList(
selectInput(
inputId = "selected_modality1",
label = "Select modality",
#choices = c(names(vals$musica@result_list[[input$selected_res1]]@modality)),
choices = c(names(vals$res_names_full[[input$selected_res1]])),
width = "50%"
),
bsTooltip(id = "selected_modality1",
title =
"Select the modality of the desired signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
})
observeEvent(input$selected_modality1, {
output$select_model1 <- renderUI({
tagList(
selectInput(
inputId = "selected_model1",
label = "Select model ID",
choices = c(vals$res_names_full[[input$selected_res1]][[input$selected_modality1]]),
width = "50%"
),
bsTooltip(id = "selected_model1",
title =
"Select the model ID desired signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
})
#select box for exposure
output$select_res2 <- renderUI({
tagList(
selectInput(
inputId = "selected_res2",
label = "Select result list name",
choices = c(names(vals$res_names_full))
),
bsTooltip(id = "selected_res2",
title =
"Select the result list entry that contains the desired exposures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
observeEvent(input$selected_res2, {
output$select_modality2 <- renderUI({
tagList(
selectInput(
inputId = "selected_modality2",
label = "Select modality",
#choices = c(names(vals$musica@result_list[[input$selected_res1]]@modality)),
choices = c(names(vals$res_names_full[[input$selected_res2]])),
width = "50%"
),
bsTooltip(id = "selected_modality2",
title =
"Select the modality of the desired signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
})
observeEvent(input$selected_modality2, {
output$select_model2 <- renderUI({
tagList(
selectInput(
inputId = "selected_model2",
label = "Select model ID",
choices = c(vals$res_names_full[[input$selected_res2]][[input$selected_modality2]]),
width = "50%"
),
bsTooltip(id = "selected_model2",
title =
"Select the model ID of the signatures to visaulize.",
placement = "right", options = list(container = "body"))
)
})
})
#create text input for changing signature names
observeEvent(input$rename, {
n <- ncol(vals$musica@result_list[[input$selected_res1]]@modality[[input$selected_modality1]][[input$selected_model1]]@signatures)
#n <- ncol(signatures(vals$musica, input$selected_res1, input$selected_modality1, input$selected_model1))
#n <- ncol(vals$result_objects[[input$selected_res1]]@signatures)
for (i in 1:n) {
id <- paste0("sig", i)
if (input$rename) {
insertUI(
selector = "#signame",
ui = textInput(inputId = id, paste0("Signature", i))
)
}
else{
removeUI(selector = paste0("div:has(> #", id, ")"))
}
}
}, ignoreInit = TRUE)
#observeEvent(input$annotation1, {
# n <- ncol(vals$musica@result_list[[input$selected_res1]]@modality[[input$selected_modality1]][[input$selected_model1]]@signatures)
#n <- ncol(signatures(vals$musica, input$selected_res1, input$selected_modality1, input$selected_model1))
#n <- ncol(vals$result_objects[[input$selected_res1]]@signatures)
# for (i in 1:n) {
# id2 <- paste0("sig", i)
# if (input$annotation1) {
# insertUI(
# selector = "#annotations",
# ui = textInput(inputId = id2, paste0("Signature", i))
# )
# }
# else{
# removeUI(selector = paste0("div:has(> #", id2, ")"))
# }
# }
#}, ignoreInit = TRUE)
#save plotting options for signatures in a list
get_sig_option <- function(input) {
n <- ncol(vals$musica@result_list[[input$selected_res1]]@modality[[input$selected_modality1]][[input$selected_model1]]@signatures)
#n <- ncol(signatures(vals$musica, input$selected_res1, input$selected_modality1, input$selected_model1))
#n <- ncol(vals$result_objects[[input$selected_res1]]@signatures)
if (input$rename) {
ids <- vector()
for (i in 1:n) {
ids <- c(ids, input[[paste0("sig", i)]])
}
name_signatures(vals$musica, input$selected_model2, ids, input$selected_modality1, input$selected_res1)
#name_signatures(result = vals$result_objects[[input$selected_res1]], ids)
}
#if (input$annotation1) {
# ids2 <- vector()
# for (i in 1:n) {
# ids2 <- c(ids2, input[[paste0("sig", i)]])
# }
# #name_signatures(result = vals$result_objects[[input$selected_res1]], ids)
#}
#else{
# ids2 <- NULL
#}
#legend <- input$legend1
text_size <- input$text_size1
#facet_size <- input$facet_size
show_x_labels <- input$xlab1
show_y_labels <- input$ylab1
same_scale <- input$scale1
percent <- input$percent1
plotly <- input$plotly1
#annotation = ids2
options <- list(
#legend,
text_size,
#facet_size,
show_x_labels, show_y_labels, same_scale, percent, plotly)
return(options)
}
#Make signature plot
observeEvent(input$get_plot1, {
options <- get_sig_option(input)
#result <- vals$result_objects[[input$selected_res1]]
n <- ncol(vals$musica@result_list[[input$selected_res1]]@modality[[input$selected_modality1]][[input$selected_model1]]@signatures)
#n <- ncol(signatures(vals$musica, input$selected_res1, input$selected_modality1, input$selected_model1))
#n <- ncol(vals$result_objects[[input$selected_res1]]@signatures)
height <- paste0(as.character(n * 90), "px")
if (options[[6]]) {
#disable resizable
jqui_resizable("#sigplot_plotly", operation = "destroy")
jqui_resizable("#sigplot_plot", operation = "destroy")
#remove previous plot
removeUI(selector = "#sigplot_plot")
removeUI(selector = "#sigplot_plotly")
insertUI(
selector = "#plot_div1",
ui = plotlyOutput(outputId = "sigplot_plotly", height = height)
)
output$sigplot_plotly <- renderPlotly(
plot_signatures(
vals$musica,
input$selected_model1,
input$selected_modality1,
input$selected_res1,
#legend = options[[1]],
percent = options[[5]],
plotly = options[[6]],
text_size = options[[1]],
#facet_size = options[[3]],
show_x_labels = options[[2]],
show_y_labels = options[[3]],
#annotation = options[[7]],
same_scale = options[[4]]
)
)
#enable resizable
jqui_resizable("#sigplot_plotly")
}
else{
jqui_resizable("#sigplot_plotly", operation = "destroy")
jqui_resizable("#sigplot_plot", operation = "destroy")
removeUI(selector = "#sigplot_plotly")
removeUI(selector = "#sigplot_plot")
insertUI(
selector = "#plot_div1",
ui = plotOutput(outputId = "sigplot_plot", height = height)
)
output$sigplot_plot <- renderPlot(
plot_signatures(
vals$musica,
input$selected_model1,
input$selected_modality1,
input$selected_res1,
#legend = options[[1]],
percent = options[[5]],
plotly = options[[6]],
text_size = options[[1]],
#facet_size = options[[3]],
show_x_labels = options[[2]],
show_y_labels = options[[3]],
#annotation = options[[7]],
same_scale = options[[4]]
)
)
jqui_resizable("#sigplot_plot")
}
})
observeEvent(input$plot_type, {
#If box or violin selected, generate options for plotting points;
#group by and color by have two choices
if (input$plot_type %in% c("box", "violin") & vals$point_ind == 0) {
removeUI(selector = "#point_opt")
insertUI(
selector = "#points",
ui = tags$div(
id = "point_opt",
checkboxInput(inputId = "add_point", label = "Add Points",
value = TRUE),
numericInput(inputId = "point_size", label = "Point Size", value = 2),
bsTooltip(id = "add_point",
title =
"If checked, then points for individual sample exposures will be
plotted on top of the violin/box plots.",
placement = "right", options = list(container = "body")),
bsTooltip(id = "point_size",
title = paste0("Size of the points to be plotted on ",
"top of the violin/box plots."),
placement = "right", options = list(container = "body"))
)
)
removeUI(selector = "#group1")
insertUI(
selector = "#insert_group",
ui = tagList(
radioButtons(
inputId = "group1",
label = "Group By",
choices = list("Signature" = "signature",
"Annotation" = "annotation"),
inline = TRUE,
selected = "signature"
),
bsTooltip(id = "group1",
title =
paste0("Determines how to group samples into ",
"the subplots. If set to \"annotation\", ",
"then a sample annotation must be supplied ",
"via the annotation parameter."),
placement = "right",
options = list(container = "body"))
)
)
removeUI(selector = "#color")
insertUI(
selector = "#insert_color",
ui = tagList(
radioButtons(
inputId = "color",
label = "Color By",
choices = list("Signature" = "signature",
"Annotation" = "annotation"),
inline = TRUE,
selected = "signature"
),
bsTooltip(id = "color", title = "Determines how to color samples.",
placement = "right", options = list(container = "body"))
)
)
vals$point_ind <- 1
}
#if scatter is selected, generate point size option, remove group by option,
#color by has 3 choices
else if (input$plot_type == "scatter") {
removeUI(selector = "#point_opt")
removeUI(selector = "#group1")
insertUI(
selector = "#points",
ui = tags$div(
id = "point_opt",
numericInput(inputId = "point_size",
label = "Point Size", value = 0.7),
bsTooltip(id = "point_size",
title = "Size of the points on scatter plots.",
placement = "right", options = list(container = "body"))
)
)
removeUI(selector = "#color")
insertUI(
selector = "#insert_color",
ui = tagList(
radioButtons(
inputId = "color",
label = "Color By",
choices = list("None" = "none", "Signature" = "signatures",
"Annotation" = "annotation"),
inline = TRUE,
selected = "none"
),
bsTooltip(id = "color", title = "Determines how to color samples.",
placement = "right", options = list(container = "body"))
)
)
vals$point_ind <- 0
}
#if bar is selected, remove all points related options,
#group by has 3 choices, color by has 2 choices
else if (input$plot_type == "bar") {
removeUI(selector = "#point_opt")
removeUI(selector = "#group1")
insertUI(
selector = "#insert_group",
ui = tagList(
radioButtons(
inputId = "group1",
label = "Group By",
choices = list("None" = "none", "Signature" = "signature",
"Annotation" = "annotation"),
inline = TRUE,
selected = "none"
),
bsTooltip(id = "group1",
title =
paste0("Determines how to group samples into the ",
"subplots. If set to \"annotation\", then a ",
"sample annotation must be supplied via ",
"the annotation parameter."),
placement = "right", options = list(container = "body"))
)
)
removeUI(selector = "#color")
insertUI(
selector = "#insert_color",
ui = tagList(
radioButtons(
inputId = "color",
label = "Color By",
choices = list("Signature" = "signature",
"Annotation" = "annotation"),
inline = TRUE,
selected = "signature"
),
bsTooltip(id = "color", title = "Determines how to color samples.",
placement = "right", options = list(container = "body"))
)
)
vals$point_ind <- 0
}
else{
return(NULL)
}
})
addTooltip(session, id = "proportional",
title = "If checked, the exposures will be normalized to
between 0 and 1 by dividing by the total
number of counts for each sample.",
placement = "right", options = list(container = "body"))
addTooltip(session, id = "color",
title = "Determines how to color the bars or box/violins.
If set to \"annotation\", then a sample annotation must be
supplied via the annotation parameter",
placement = "right", options = list(container = "body"))
#if annotation is selected for group by, enable annotation option
observeEvent(input$group1, {
if (input$group1 == "annotation" & input$color != "annotation") {
if (ncol(samp_annot(vals$musica)) == 1) {
shinyalert::shinyalert(title = "Error",
text = paste0("Annotation not found. ",
"Please add annotation to the musica object."))
}
else{
vals$annot <-
as.list(colnames(samp_annot(
vals$musica))[-1])
names(vals$annot) <-
colnames(samp_annot(vals$musica))[-1]
insertUI(
selector = "#insert_annot",
ui = tagList(
selectInput(
inputId = "annotation",
label = "Annotation",
choices = vals$annot
),
bsTooltip(id = "annotation",
title = paste0("Sample annotation used to group the ",
"subplots or color the bars, boxes, or violins."),
placement = "right", options = list(container = "body"))
)
)
}
}
else{
if (input$color != "annotation") {
removeUI(selector = "div:has(>> #annotation)")
}
}
})
#if annotation is selected for color by, enable annotation option
observeEvent(input$color, {
if (input$color == "annotation" & input$group1 != "annotation") {
if (ncol(samp_annot(vals$musica)) == 1) {
shinyalert::shinyalert(title = "Error",
text = "Annotation not found.
Please add annotation to the musica object.")
}
else{
vals$annot <- as.list(colnames(samp_annot(
vals$musica))[-1])
names(vals$annot) <- colnames(samp_annot(
vals$musica))[-1]
insertUI(
selector = "#insert_annot",
ui = tagList(
selectInput(
inputId = "annotation",
label = "Annotation",
choices = vals$annot
),
bsTooltip(id = "annotation",
title = "Sample annotation used to group the subplots
or color the bars, boxes, or violins.",
placement = "right", options = list(container = "body"))
)
)
}
}
else{
if (input$group1 != "annotation") {
removeUI(selector = "div:has(>> #annotation)")
}
}
})
#If bar plot is sorted by signature exposure, generate a bucket_list
observeEvent(input$sort, {
if (input$sort == "signature") {
insertUI(
selector = "#sort_by_sig",
ui = tags$div(
id = "insert_sig",
bucket_list(
header = "Select signatures to sort",
group_name = "bucket",
orientation = "horizontal",
add_rank_list(
text = "Available Signatures:",
labels = as.list(colnames(
signatures(vals$musica, input$selected_res2, input$selected_modality2, input$selected_model2))),
#vals$result_objects[[input$selected_res2]]@signatures)),
input_id = "sig_from"
),
add_rank_list(
text = "Selected Signatures:",
labels = NULL,
input_id = "sig_to"
)
),
bsTooltip(id = "bucket",
title = "Drag signatures from top bucket to the bottom bucket.
Samples will be sorted in descending order by signatures.
If multiple signatures are supplied,
samples will be sorted by each signature sequentially",
placement = "right", options = list(container = "body"))
)
)
}
else{
removeUI(selector = "#insert_sig")
}
})
#generate the option to determine number of top samples to include in bar plot
#observeEvent(input$selected_res2, {
observeEvent(input$selected_model2, {
output$number <- renderUI(
tagList(
numericInput(inputId = "num_samp", label = "# of Top Samples",
value = dim(exposures(vals$musica, input$selected_res2,
input$selected_modality2, input$selected_model2))[2],
#value = dim(vals$result_objects[[
#input$selected_res2]]@exposures)[2],
min = 1,
max = dim(exposures(vals$musica, input$selected_res2,
input$selected_modality2, input$selected_model2))[2]),
#max = dim(vals$result_objects[[
#input$selected_res2]]@exposures)[2]),
bsTooltip(id = "num_samp",
title = "The top number of sorted samples to display.",
placement = "right", options = list(container = "body"))
)
)
})
#save plotting options for exposures in a list
get_exp_option <- function(input) {
plot_type <- input$plot_type
proportional <- input$proportional
group_by <- input$group1
color_by <- input$color
if (input$group1 == "annotation" | input$color == "annotation") {
annot <- input$annotation
}
else{
annot <- NULL
}
if (!is.numeric(input$num_samp)) {
num_samples <- NULL
}
else{
num_samples <- input$num_samp
}
sort_by <- input$sort
if (sort_by == "signature") {
sort_samples <- input$sig_to
}
else{
sort_samples <- sort_by
}
if (!is.numeric(input$theta)) {
threshold <- NULL
}
else{
threshold <- input$theta
}
same_scale <- input$scale2
label_x_axis <- input$xlab2
legend <- input$legend2
if (length(input$add_point) == 0) {
add_points <- FALSE
}
else{
add_points <- input$add_point
}
point_size <- input$point_size
plotly <- input$plotly2
options <- list(plot_type, proportional, group_by, color_by,
annot, num_samples, sort_samples, threshold,
same_scale, label_x_axis, legend, add_points,
point_size, plotly)
return(options)
}
#plot exposures
observeEvent(input$get_plot2, {
options <- get_exp_option(input)
#else{
# result <- vals$result_objects[[input$selected_res2]]
#}
if (options[[14]]) {
jqui_resizable("#exp_plotly", operation = "destroy")
jqui_resizable("#exp_plot", operation = "destroy")
removeUI(selector = "#exp_plotly")
removeUI(selector = "#exp_plot")
insertUI(
selector = "#plot_div2",
ui = plotlyOutput(outputId = "exp_plotly")
)
if (options[[1]] == "scatter") {
if (is.na(umap(vals$musica, input$selected_res2, input$selected_modality2, input$selected_model2)[1])) {
create_umap(vals$musica, input$selected_model2, input$selected_modality2, input$selected_res2)
#result <- vals$result_objects[[input$selected_res2]]
}
output$exp_plotly <- renderPlotly(
plot_umap(
vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2,
color_by = options[[4]],
proportional = options[[2]],
same_scale = options[[9]],
annotation = options[[5]],
plotly = options[[14]],
legend = options[[11]],
point_size = options[[13]]
)
)
}
else{
output$exp_plotly <- renderPlotly(
plot_exposures(
vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2,
plot_type = options[[1]],
proportional = options[[2]],
group_by = options[[3]],
color_by = options[[4]],
annotation = options[[5]],
num_samples = options[[6]],
sort_samples = options[[7]],
threshold = options[[8]],
same_scale = options[[9]],
label_x_axis = options[[10]],
legend = options[[11]],
add_points = options[[12]],
point_size = options[[13]],
plotly = options[[14]]
)
)
}
jqui_resizable("#exp_plotly")
}
else{
jqui_resizable("#exp_plotly", operation = "destroy")
jqui_resizable("#exp_plot", operation = "destroy")
removeUI(selector = "#exp_plot")
removeUI(selector = "#exp_plotly")
insertUI(
selector = "#plot_div2",
ui = plotOutput(outputId = "exp_plot")
)
if (options[[1]] == "scatter") {
if (length(umap(vals$musica, input$selected_res2, input$selected_modality2, input$selected_model2)) == 0) {
#create_umap(vals$result_objects[[input$selected_res3]])
create_umap(vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2)
#result <- vals$result_objects[[input$selected_res3]]
}
output$exp_plot <- renderPlot(
plot_umap(
vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2,
color_by = options[[4]],
proportional = options[[2]],
same_scale = options[[9]],
annotation = options[[5]],
plotly = options[[14]],
legend = options[[11]],
point_size = options[[13]]
)
)
}
else{
output$exp_plot <- renderPlot(
plot_exposures(
vals$musica,
model_name = input$selected_model2,
modality = input$selected_modality2,
result_name = input$selected_res2,
plot_type = options[[1]],
proportional = options[[2]],
group_by = options[[3]],
color_by = options[[4]],
annotation = options[[5]],
num_samples = options[[6]],
sort_samples = options[[7]],
threshold = options[[8]],
same_scale = options[[9]],
label_x_axis = options[[10]],
legend = options[[11]],
add_points = options[[12]],
point_size = options[[13]],
plotly = options[[14]]
)
)
}
jqui_resizable("#exp_plot")
}
})
################################################
####################Heatmap##############
output$select_res_heatmap <- renderUI({
tagList(
selectInput(
inputId = "select_res_heatmap",
label = "Select Result",
choices = c(names(vals$res_names_full))
)
)
})
observeEvent(input$select_res_heatmap, {
output$select_modality_heatmap <- renderUI({
tagList(
selectInput("select_modality_heatmap", "Modality",
choices = c(names(vals$res_names_full[[input$select_res_heatmap]]))),
bsTooltip("select_modality_heatmap", "Desired modality")
)
})
})
observeEvent(input$select_modality_heatmap, {
output$select_model_heatmap <- renderUI({
tagList(
selectInput("select_model_heatmap", "Model ID",
choices = c(vals$res_names_full[[input$select_res_heatmap]][[input$select_modality_heatmap]])),
bsTooltip("select_model_heatmap", "Model ID of desired result")
)
})
})
propor <- reactive({
props <- input$prop
return(props)
})
sel_col_names <- reactive({
cc <- input$col_names
return(cc)
})
sel_row_names <- reactive({
rr <- input$row_names
return(rr)
})
zscale <- reactive({
zscale <- input$scale
return(zscale)
})
#Subsetting my signatures
observeEvent(input$subset, {
if (input$subset == "signature") {
insertUI(
selector = "#sortbysigs",
ui = tags$div(
id = "insert_sig",
bucket_list(
header = "Select signatures to sort",
group_name = "bucket",
orientation = "horizontal",
add_rank_list(
text = "Available Signatures:",
labels = as.list(colnames(signatures(vals$musica,
input$select_res_heatmap,
input$select_modality_heatmap,
input$select_model_heatmap))),
#labels = as.list(colnames(
# vals$result_objects[[input$select_res_heatmap]]@signatures)),
input_id = "sig_from"
),
add_rank_list(
text = "Selected Signatures:",
labels = NULL,
input_id = "sort_sigs"
)
)
)
)
}
else if (input$subset == "all_signatures") {
removeUI(selector = "#insert_sig")
}
})
get_sigs <- function(input) {
req(input$subset)
if (input$subset == "signature") {
sig <- input$sort_sigs
}
else if (input$subset == "all_signatures") {
sig <- NULL
}
return(sig)
}
#Subsetting by tumors
observeEvent(input$subset_tum, {
if (input$subset_tum == "tumors") {
insertUI(
selector = "#sortbytum",
ui = tags$div(
id = "inserttum",
checkboxGroupInput(
"tum_val", "Available Samples:",
as.list(unique(samp_annot(vals$musica)$Tumor_Subtypes)))
#as.list(unique(vals$result_objects[[
# input$select_res_heatmap
# ]]@musica@sample_annotations$Tumor_Subtypes)))
)
)
}
else{
removeUI(selector = "#inserttum")
}
})
get_tums <- function(input) {
req(input$subset_tum)
if (input$subset_tum == "tumors") {
tums <- input$tum_val
}
else{
tums <- NULL
}
return(tums)
}
#Subsetting by annotation
observeEvent(input$subset_annot, {
if (input$subset_annot == TRUE) {
insertUI(
selector = "#sortbyannot",
ui = tags$div(
id = "#insert_annot",
checkboxGroupInput("annot_val", "Available annotations:",
#c(as.list(colnames(samp_annot(
# vals$result_objects[[input$select_res_heatmap
# ]]))))
c(as.list(colnames(samp_annot(vals$musica))))
)
))
}
else{
removeUI(selector = "#insert_annot")
}
})
#Add heatmap functionality
observeEvent(input$get_heatmap, {
sigs <- get_sigs(input)
tums <- get_tums(input)
output$heatmap <- renderPlot({
req(input$select_res_heatmap)
input$get_heatmap
isolate(plot_heatmap(vals$musica,
model_name = input$select_model_heatmap,
modality = input$select_modality_heatmap,
result_name = input$select_res_heatmap,
proportional = propor(),
show_row_names = sel_row_names(),
show_column_names = sel_col_names(),
scale = zscale(),
subset_signatures = c(sigs),
subset_tumor = c(tums),
annotation = input$annot_val,
column_title = paste0("Heatmap for ",
input$select_model_heatmap)))
})
})
##############Clustering################
#select box for clustering
output$select_res3 <- renderUI({
tagList(
selectInput(
inputId = "selected_res3",
label = "Select result list name",
choices = c(names(vals$res_names_full))
),
bsTooltip(id = "selected_res3",
title = "Select name of result list entry containing the
signatures to visualize.",
placement = "right", options = list(container = "body"))
)
})
observeEvent(input$selected_res3, {
output$select_modality3 <- renderUI({
tagList(
selectInput("selected_modality3", "Modality",
choices = c(names(vals$res_names_full[[input$selected_res3]]))),
bsTooltip("selected_modality3", "Desired modality")
)
})
})
observeEvent(input$selected_modality3, {
output$select_model3 <- renderUI({
tagList(
selectInput("selected_model3", "Model ID",
choices = c(vals$res_names_full[[input$selected_res3]][[input$selected_modality3]])),
bsTooltip("selected_model3", "Model ID of desired result")
)
})
})
#generate options for selecting number of clusters
observeEvent(input$selected_model3, {
default <- min(10, dim(exposures(vals$musica, input$selected_res3,
input$selected_modality3,
input$selected_model3))[2] - 1)
output$no_cluster1 <- renderUI(
tagList(
numericInput(inputId = "num_clust1", label = "Max Number of Clusters",
min = 2,
max = dim(exposures(vals$musica, input$selected_res3,
input$selected_modality3,
input$selected_model3))[2] - 1,
value = default)
#max = dim(vals$result_objects[[
# input$selected_res3]]@exposures)[2])
)
)
output$no_cluster2 <- renderUI(
tagList(
numericInput(inputId = "num_clust2", label = "Max Number of Clusters",
value = 2,
min = 2,
max = dim(exposures(vals$musica, input$selected_res3,
input$selected_modality3,
input$selected_model3))[2] - 1)
)
)
})
#make plot for exploratory analysis
observeEvent(input$explore, {
jqui_resizable("#explore_plot", operation = "destroy")
removeUI(selector = "#explore_plot")
insertUI(
selector = "#insert_explore_plot",
ui = plotOutput(outputId = "explore_plot")
)
method <- input$metric
clust.method <- input$algorithm1
n <- input$num_clust1
proportional <- input$proportional2
output$explore_plot <- renderPlot(
k_select(
#result = vals$result_objects[[input$selected_res3]],
vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3,
method = method,
clust.method = clust.method,
n = n,
proportional = proportional
)
)
jqui_resizable("#explore_plot")
})
#generate select box for dissimilarity matrix and options specific to
#certain algorithms
observeEvent(input$algorithm2, {
choices <- list(hkmeans =
c("Euclidean" = "euclidean", "Manhattan" = "manhattan",
"Canberra" = "canberra"),
clara = c("Euclidean" = "euclidean",
"Manhattan" = "manhattan", "Jaccard" = "jaccard"),
kmeans = c("Euclidean" = "euclidean",
"Manhattan" = "manhattan", "Jaccard" = "jaccard",
"Cosine" = "cosine", "Canberra" = "canberra"),
hclust = c("Euclidean" = "euclidean",
"Manhattan" = "manhattan", "Jaccard" = "jaccard",
"Cosine" = "cosine", "Canberra" = "canberra"),
pam = c("Euclidean" = "euclidean",
"Manhattan" = "manhattan", "Jaccard" = "jaccard",
"Cosine" = "cosine", "Canberra" = "canberra"))
output$diss <- renderUI(
selectInput(
inputId = "diss_method",
label = "Method for Dissimilarity Matrix",
choices = choices[[input$algorithm2]]
)
)
if (input$algorithm2 == "hclust") {
insertUI(
selector = "#hclust",
ui = selectInput(
inputId = "hclust_method",
label = "Hierarchical Clustering Method",
choices = c("ward.D" = "ward.D", "ward.D2" = "ward.D2",
"single" = "single", "complete" = "complete",
"average" = "average", "mcquitty" = "mcquitty",
"median" = "median", "centroid" = "centroid")
)
)
}
else{
removeUI(selector = "div:has(>> #hclust_method)")
}
if (input$algorithm2 == "clara") {
insertUI(
selector = "#clara",
ui = numericInput(inputId = "clara_num",
label = "No. of Samples for CLARA",
value = 5,
min = 1,
max = dim(exposures(vals$musica, input$selected_res3,
input$selected_modality3,
input$selected_model3))[2])
)
}
else{
removeUI(selector = "div:has(>> #clara_num)")
}
if (input$algorithm2 %in% c("kmeans", "hkmeans")) {
insertUI(
selector = "#iter",
ui = numericInput(inputId = "max_iter",
label = "Max No. of Iterations",
value = 10,
min = 1)
)
}
else{
removeUI(selector = "div:has(>> #max_iter)")
}
})
#create select box to allow users to color plot by annotation
observeEvent(input$group2, {
if (input$group2 == "annotation") {
vals$annot <- as.list(colnames(samp_annot(vals$musica))[-1])
names(vals$annot) <- colnames(samp_annot(vals$musica))[-1]
insertUI(
selector = "#insert_annot2",
ui = tagList(
selectInput(
inputId = "annotation2",
label = "Annotation",
choices = vals$annot
)
)
)
}
else{
removeUI(selector = "div:has(>> #annotation2)")
}
})
#perform clustering analysis
observeEvent(input$cluster_calc, {
#result <- vals$result_objects[[input$selected_res3]]
nclust <- input$num_clust2
proportional <- input$proportional3
method <- input$algorithm2
dis.method <- input$diss_method
if (!is.null(input$hclust_method)) {
hc.method <- input$hclust_method
}
else{
hc.method <- "ward.D"
}
if (!is.numeric(input$clara_num)) {
clara.samples <- 5
}
else{
clara.samples <- input$clara_num
}
if (!is.numeric(input$max_iter)) {
iter.max <- 10
}
else{
iter.max <- input$max_iter
}
vals$cluster <- cluster_exposure(vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3,
nclust = nclust,
proportional = proportional,
method = method,
dis.method = dis.method,
hc.method = hc.method,
clara.samples = clara.samples,
iter.max = iter.max)
insertUI(
selector = "#insert_cluster_table",
ui = tags$div(
DT::DTOutput("cluster_table"),
downloadButton("download_cluster", "Download")
)
)
#annot <- samp_annot(vals$result_objects[[input$selected_res3]])
annot <- samp_annot(vals$musica)
row.names(annot) <- annot$Samples
dat <- cbind(annot, vals$cluster)
output$cluster_table <- DT::renderDT(
DT::datatable(dat[-1])
)
output$download_cluster <- downloadHandler(
filename = function() {
paste0(input$selected_model3, "_cluster.txt")
},
content = function(file) {
write.table(dat[-1], file, sep = "\t", quote = FALSE)
}
)
})
#visualize clustering result
observeEvent(input$cluster_vis, {
#if (length(umap(vals$result_objects[[input$selected_res3]])) == 0) {
if (is.na(umap(vals$musica, input$selected_res3, input$selected_modality3, input$selected_model3)[1])) {
#create_umap(vals$result_objects[[input$selected_res3]])
create_umap(vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3)
#result <- vals$result_objects[[input$selected_res3]]
}
else{
#result <- vals$result_objects[[input$selected_res3]]
}
clusters <- vals$cluster
group <- input$group2
if (group == "annotation") {
annotation <- input$annotation2
}
else{
annotation <- NULL
}
plotly <- input$plotly3
if (plotly) {
jqui_resizable("#cluster_plot", operation = "destroy")
jqui_resizable("#cluster_plotly", operation = "destroy")
removeUI(selector = "#cluster_plot")
removeUI(selector = "#cluster_plotly")
insertUI(
selector = "#cluster_plot_div",
ui = plotlyOutput(outputId = "cluster_plotly")
)
output$cluster_plotly <- renderPlotly(
plot_cluster(vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3,
clusters = clusters,
group = group,
annotation = annotation,
plotly = plotly)
)
jqui_resizable("#cluster_plotly")
}
else{
jqui_resizable("#cluster_plot", operation = "destroy")
jqui_resizable("#cluster_plotly", operation = "destroy")
removeUI(selector = "#cluster_plot")
removeUI(selector = "#cluster_plotly")
insertUI(
selector = "#cluster_plot_div",
ui = plotOutput(outputId = "cluster_plot")
)
output$cluster_plot <- renderPlot(
plot_cluster(vals$musica,
model_name = input$selected_model3,
modality = input$selected_modality3,
result_name = input$selected_res3,
clusters = clusters,
group = group,
annotation = annotation,
plotly = plotly)
)
jqui_resizable("#cluster_plot")
}
})
########################################
########################################Download#############################
output$select_mus_obj_download <- renderUI({
tagList(
selectInput(
inputId = "select_mus_obj_download",
label = "Select Musica Object",
choices = "musica"
)
)
})
#output$select_res_download <- renderUI({
# tagList(
# selectInput(
# inputId = "select_res_download",
# label = "Select Musica Result Object",
# choices = c(names(vals$result_objects))
# )
# )
#})
#Adding the download feature
output$download_mus_obj <- downloadHandler(
filename = function() {
paste("musica_object", ".rds", sep = "")
},
content = function(file) {
saveRDS(vals$musica, file = file)
}
)
# output$download_res <- downloadHandler(
#filename = function() {
# paste("musica_results", ".rds", sep = "")
#},
#content = function(file) {
# saveRDS(vals$result_objects[[input$select_res_download]], file = file)
#}
#)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.