tcgaexplorer_UI <- function(id) {
ns <- NS(id)
tagList(
tabBox(
id = "tcgaexplorer", width = 12,
tabPanel(
"Home",
icon = icon("home", verify_fa=FALSE),
fluidRow(
box(
width = 12, status = "success",
messageBox(
width = 12,
uiOutput(ns("dataset"))
),
messageBox(
width = 12,
includeMarkdown(
system.file(
"extdata", "tcga_analysis.md", package = "signeR"
)
)
)
)
),
uiOutput(ns("signplots")),
fluidRow(
box(
title = "Data summary", width = 12, solidHeader = T,
collapsible = F, status = "primary",
column(
width = 9,
DT::dataTableOutput(ns("tcga_clinical_data")),
),
column(
width = 3,
uiOutput(ns("tcga_feature_class_table"))
)
)
),
fluidRow(
box(
width = 12,
collapsible = F, status = "primary",
fluidRow(
optionsBox(
width = 3,
column(
width = 12,
uiOutput(ns("feature_op")),
hr(),
selectInput(
inputId = ns("which_plot"), label = "Available Plots:",
choices = c(
"ExposureHeat", "ExposureBarplot", "ExposureBoxplot"
),
selected = "ExposureHeat", multiple = FALSE,
size = 3, selectize = FALSE
)
)
),
plotBox(
width = 9,
column(
width = 12,
withSpinner(
plotOutput(
ns("plot_chosen"),
width = "auto",
height = "400px"
),
color = "#0dc5c1"
)
)
)
)
)
)
),
clustering_UI(ns("clusteringmod")),
tabPanel(
"Covariate",
icon = icon("question", verify_fa=FALSE),
fluidRow(
box(
title = "Filtered data summary", width = 12, solidHeader = T,
collapsible = F, status = "primary",
messageBox(
title = "Warning:",
solidHeader = TRUE,
width = 12,
uiOutput(ns("filtered_value"))
),
p("
Please choose a feature of interest from the ones available for
TCGA samples."
),
column(
width = 9,
DT::dataTableOutput(ns("filtered_tcga_clinical_data")),
),
column(
width = 3,
uiOutput(ns("filtered_tcga_feature_class_table"))
)
)
),
fluidRow(
box(
title = p("Plots"),
width = 12, solidHeader = T,
collapsible = F, status = "info",
fluidRow(
box(
width = 12,
p(
"After you select a feature, you will be able to
select one button below to show a plot."
)
)
),
column(
width = 2,
fluidRow(
box(
width = 12,
uiOutput(ns("radio_buttons"))
)
)
),
column(
width = 10,
fluidRow(
box(
width = 12, solidHeader = T,
uiOutput(ns("plot_options")),
withSpinner(
plotOutput(ns("covariate_plot"), height = "450px"),
color = "#0dc5c1"
)
)
)
)
)
),
)
)
)
}
tcgaexplorer <- function(input,
output,
session,
analysis_type,
tcga_tumor,
clinical,
signatures) {
ns <- session$ns
get_similarities_tcga <- function() {
data <- tcga_similarities %>%
filter(
project == tcga_tumor()
) %>%
select(-project) %>%
column_to_rownames("sigs")
return(data)
}
get_tcga_data <- function() {
feature <- input$feature
filter_op <- input$filter_op
filter_value <- input$filter_value
feature_row <- input$tcga_clinical_data_rows_selected
data <- clinical()
if (!is.null(feature) & !is.null(feature_row)) {
print(paste0("filter data pela feature ", feature))
col <- names(data[feature_row + 1])
feature <- as.list(feature)
data <- clinical()
data <- data %>%
filter(
!!as.symbol(col) %in% feature
)
return(data)
} else if (!is.null(filter_value) & !is.null(feature_row)) {
col <- names(data[feature_row + 1])
print(
paste0(
"filter data pela feature ", col, " ", filter_op, " ", filter_value
)
)
data <- clinical()
data <- data %>%
filter(
get(filter_op)(!!as.symbol(col), filter_value)
)
}
return(data)
}
sigs_raw <- reactive({
req(signatures())
sigs <- signatures()
return(sigs)
})
sigs_obj <- reactive({
req(signatures())
sigs <- signatures()
feature <- input$feature
filter_op <- input$filter_op
filter_value <- input$filter_value
feature_row <- input$tcga_clinical_data_rows_selected
if (!is.null(feature) & !is.null(feature_row)) {
print(paste0("filter sig pela feature ", feature))
data <- clinical()
col <- names(data[feature_row + 1])
feature <- as.list(feature)
data <- clinical()
data <- data %>%
filter(
!!as.symbol(col) %in% feature
)
sigs$SignExposures <- Reorder_samples(
sigs$SignExposures,
ord = which(
sigs$SignExposures@samples %in% data$barcode
)
)
} else if (!is.null(filter_value) & !is.null(feature_row)) {
data <- get_tcga_data()
col <- names(data[feature_row + 1])
print(
paste0(
"filter sig pela feature ", col, " ", filter_op, " ", filter_value
)
)
sigs$SignExposures <- Reorder_samples(
sigs$SignExposures,
ord = which(
sigs$SignExposures@samples %in% data$barcode
)
)
}
return(sigs)
})
callModule(
clustering,
"clusteringmod",
reactive(sigs_obj())
)
tcga_clinical_data <- reactive({
req(tcga_tumor())
result <- clinical()
if (is.data.frame(result)) {
ff <- rownames(t(result))[-1]
df <- data.frame()
for (f in ff) {
fn <- f
s <- result %>%
select(1, f) %>%
gather("key", "value", 2) %>%
filter(!is.na(value)) %>%
nrow()
fq <- round(s / length(unique(result[[1]])) * 100, 3)
s_na <- result %>%
select(1, f) %>%
gather("key", "value", 2) %>%
filter(is.na(value)) %>%
nrow()
fq_na <- round(s_na / length(unique(result[[1]])) * 100, 3)
class <- ifelse(
is.character(result[[f]]), "categoric", "numeric"
)
data <- data.frame(
"feature" = fn, "class" = class, "count" = paste0(s, " (", fq, "%)"),
"missing" = paste0(s_na, " (", fq_na, "%)")
)
df <- rbind(df, data)
}
return(df)
} else {
return(NA)
}
})
filtered_tcga_clinical_data <- reactive({
req(tcga_tumor())
result <- get_tcga_data()
if (is.data.frame(result)) {
ff <- rownames(t(result))[-1]
df <- data.frame()
for (f in ff) {
fn <- f
s <- result %>%
select(1, f) %>%
gather("key", "value", 2) %>%
filter(!is.na(value)) %>%
nrow()
fq <- round(s / length(unique(result[[1]])) * 100, 3)
s_na <- result %>%
select(1, f) %>%
gather("key", "value", 2) %>%
filter(is.na(value)) %>%
nrow()
fq_na <- round(s_na / length(unique(result[[1]])) * 100, 3)
class <- ifelse(
is.character(result[[f]]), "categoric", "numeric"
)
data <- data.frame(
"feature" = fn, "class" = class, "count" = paste0(s, " (", fq, "%)"),
"missing" = paste0(s_na, " (", fq_na, "%)")
)
df <- rbind(df, data)
}
return(df)
} else {
return(NA)
}
})
feature_class <- reactive({
data <- clinical()
feature_row <- input$tcga_clinical_data_rows_selected
if (!is.null(feature_row)) {
col <- names(data[feature_row + 1])
t <- data %>%
select(col) %>%
rownames_to_column() %>%
select(-rowname) %>%
with(class(get(col)))
if (t == "character") {
fqq <- data %>%
select(col) %>%
arrange(col) %>%
with(unique(.))
sss <- data %>%
select(col) %>%
group_by(fnn = get(col)) %>%
filter(!is.na(fnn)) %>%
summarise(n = n()) %>%
mutate(freq = (n / sum(n)) * 100)
df <- data.frame("groups" = NA, "n" = NA, "frequency" = NA)
df %>%
add_row(
groups = sss$fnn,
n = sss$n,
frequency = paste0(round(sss$freq, 3), "%")
) %>%
filter(!is.na(groups))
} else if (t == "numeric") {
df <- data %>%
select(col) %>%
summarise(
min = min(get(col), na.rm = T),
max = max(get(col), na.rm = T),
mean = mean(get(col), na.rm = T),
sd = sd(get(col), na.rm = T)
)
}
} else {
return(NULL)
}
})
filtered_feature_class <- reactive({
data <- get_tcga_data()
feature_row <- input$filtered_tcga_clinical_data_rows_selected
if (!is.null(feature_row)) {
col <- names(data[feature_row + 1])
t <- data %>%
select(col) %>%
rownames_to_column() %>%
select(-rowname) %>%
with(class(get(col)))
if (t == "character") {
fqq <- data %>%
select(col) %>%
arrange(col) %>%
with(unique(.))
sss <- data %>%
select(col) %>%
group_by(fnn = get(col)) %>%
filter(!is.na(fnn)) %>%
summarise(n = n()) %>%
mutate(freq = (n / sum(n)) * 100)
df <- data.frame("groups" = NA, "n" = NA, "frequency" = NA)
df %>%
add_row(
groups = sss$fnn,
n = sss$n,
frequency = paste0(round(sss$freq, 3), "%")
) %>%
filter(!is.na(groups))
} else if (t == "numeric") {
df <- data %>%
select(col) %>%
summarise(
min = min(get(col), na.rm = T),
max = max(get(col), na.rm = T),
mean = mean(get(col), na.rm = T),
sd = sd(get(col), na.rm = T)
)
}
} else {
return(NULL)
}
})
output$tcga_clinical_data_selected <- renderPrint({
input$tcga_clinical_data_rows_selected
})
output$filtered_tcga_clinical_data_selected <- renderPrint({
input$filtered_tcga_clinical_data_rows_selected
})
output$tcga_feature_class_table <- renderTable({
feature_class()
})
output$filtered_tcga_feature_class_table <- renderTable({
filtered_feature_class()
})
observeEvent(input$tcga_clinical_data_rows_selected, {
feature_class()
})
observeEvent(input$filtered_tcga_clinical_data_rows_selected, {
filtered_feature_class()
get_plots_choices()
})
output$tcga_feature_class_table <- renderTable({
feature_class()
})
output$filtered_tcga_feature_class_table <- renderTable({
filtered_feature_class()
})
output$tcga_clinical_data <- DT::renderDataTable(
tcga_clinical_data(),
server = FALSE, selection = list(mode = "single")
)
output$filtered_tcga_clinical_data <- DT::renderDataTable(
filtered_tcga_clinical_data(),
server = FALSE, selection = list(mode = "single")
)
output$feature_op <- renderUI({
data <- clinical()
feature_row <- input$tcga_clinical_data_rows_selected
if (!is.null(feature_row)) {
col <- names(data[feature_row + 1])
t <- data %>%
select(col) %>%
rownames_to_column() %>%
select(-rowname) %>%
with(class(get(col)))
if (t == "character") {
fqq <- data %>%
select(col) %>%
arrange(col) %>%
with(unique(.))
pickerInput(
inputId = ns("feature"),
label = paste0("Options from ", col),
choices = fqq[[col]],
multiple = TRUE
)
} else {
df <- data %>%
select(col) %>%
summarise(
min = min(get(col), na.rm = T),
max = max(get(col), na.rm = T),
mean = mean(get(col), na.rm = T),
sd = sd(get(col), na.rm = T)
)
fluidRow(
width = 12,
column(
width = 6,
pickerInput(
inputId = ns("filter_op"),
label = "Filter type:",
choices = c(">", ">=", "<", "<="),
multiple = FALSE
)
),
column(
width = 6,
sliderInput(
ns("filter_value"),
"Value:", df$min, df$max, df$mean, 1.0
)
)
)
}
} else {
HTML("You can select a feature to filter the dataset.</br>")
}
})
output$signplots <- renderUI({
if (analysis_type() == "de novo"){
fluidRow(
box(
width = 6,
withSpinner(
plotOutput(
ns("signplot"),
width = "auto",
height = "400px"
),
color = "#0dc5c1"
)
),
box(
width = 6,
withSpinner(
plotOutput(
ns("signheatplot"),
width = "auto",
height = "400px"
),
color = "#0dc5c1"
)
)
)
} else {
fluidRow(
box(
width = 12,
withSpinner(
plotOutput(
ns("signplot"),
width = "auto",
height = "400px"
),
color = "#0dc5c1"
)
)
)
}
})
output$signplot <- renderPlot({
tcga_tumor()
# sigs <- sigs_obj()
sigs <- sigs_raw()
if (!is.null(sigs)) {
withProgress(
message = "Generating the signature barplot...",
detail = "This operation may take a while...",
value = 0,
{
SignPlot(sigs$SignExposures)
}
)
}
})
output$signheatplot <- renderPlot({
tcga_tumor()
# sigs <- sigs_obj()
sigs <- sigs_raw()
similarities <- get_similarities_tcga()
if (!is.null(sigs)) {
pheatmap(
t(similarities),
display_numbers = F,
angle_col = 45, cluster_rows = F, cluster_cols = F,
fontsize_row = 6
)
}
})
which_plot <- reactive({
req(input$which_plot)
if (is.null(input$which_plot)) {
return(NULL)
}
return(input$which_plot)
})
output$plot_chosen <- renderPlot({
tcga_tumor()
sigs <- sigs_obj()
if (!is.null(which_plot())) {
if (which_plot() == "ExposureBoxplot") {
withProgress(
message = "Generating the exposure boxplot...",
detail = "This operation may take a while...",
value = 0,
{
ExposureBoxplot(sigs$SignExposures)
}
)
} else if (which_plot() == "ExposureBarplot") {
withProgress(
message = "Generating the exposure barplot...",
detail = "This operation may take a while...",
value = 0,
{
ExposureBarplot(sigs$SignExposures)
}
)
} else if (which_plot() == "ExposureHeat") {
withProgress(
message = "Generating the exposure heatmap...",
detail = "This operation may take a while...",
value = 0,
{
ExposureHeat(sigs$SignExposures)
}
)
}
return(NULL)
}
})
diffexp_method <- reactive({
req(input$diffexp_method)
return(input$diffexp_method)
})
diffexp_quant <- reactive({
req(input$diffexp_quant)
return(input$diffexp_quant)
})
diffexp_cutoff <- reactive({
req(input$diffexp_cutoff)
return(input$diffexp_cutoff)
})
diffexp_padj <- reactive({
req(input$diffexp_padj)
return(input$diffexp_padj)
})
sclassif_method <- reactive({
req(input$sclassif_method)
return(input$sclassif_method)
})
sclassif_kfold <- reactive({
req(input$sclassif_kfold)
return(input$sclassif_kfold)
})
survival_method <- reactive({
req(input$survival_method)
return(input$survival_method)
})
diffexpplot <- function() {
output$covariate_plot <- renderPlot({
data <- get_tcga_data()
feature_row <- input$filtered_tcga_clinical_data_rows_selected
if (!is.null(feature_row)) {
col <- names(data[feature_row + 1])
labels <- data[[col]]
if (is.character(labels)) {
sigs <- sigs_obj()
if (is.null(sigs)) {
return(NULL)
}
if (!is.null(sigs)) {
difexp_method <- diffexp_method()
diffexp.quant <- diffexp_quant()
diffexp.cutoff <- diffexp_cutoff()
diffexp.padj <- diffexp_padj()
DiffExp(
sigs$SignExposures,
labels = labels,
quant = diffexp.quant, cutoff = diffexp.cutoff,
p.adj = diffexp.padj
)
}
}
}
return(NULL)
})
}
sampleclassplot <- function() {
output$covariate_plot <- renderPlot({
data <- get_tcga_data()
feature_row <- input$filtered_tcga_clinical_data_rows_selected
if (!is.null(feature_row)) {
col <- names(data[feature_row + 1])
labels <- data[[col]]
sclas_method <- sclassif_method()
kfold <- sclassif_kfold()
if (is.character(labels)) {
sigs <- sigs_obj()
if (is.null(sigs)) {
return(NULL)
}
if (!is.null(sigs)) {
if (kfold > 1) {
ExposureClassifyCV(
sigs$SignExposures,
labels = labels,
method = sclas_method,
fold = kfold
)
} else {
ExposureClassify(
sigs$SignExposures,
labels = labels,
method = sclas_method
)
}
}
}
}
return(NULL)
})
}
correlationplot <- function() {
output$covariate_plot <- renderPlot({
data <- get_tcga_data()
feature_row <- input$filtered_tcga_clinical_data_rows_selected
if (!is.null(feature_row)) {
col <- names(data[feature_row + 1])
feature <- data[[col]]
if (is.numeric(feature)) {
sigs <- sigs_obj()
if (is.null(sigs)) {
return(NULL)
}
if (!is.null(sigs)) {
ExposureCorrelation(
sigs$SignExposures,
feature = feature
)
}
}
}
return(NULL)
})
}
linearregressionplot <- function() {
output$covariate_plot <- renderPlot({
data <- get_tcga_data()
feature_row <- input$filtered_tcga_clinical_data_rows_selected
if (!is.null(feature_row)) {
col <- names(data[feature_row + 1])
feature <- data[[col]]
if (is.numeric(feature)) {
sigs <- sigs_obj()
if (is.null(sigs)) {
return(NULL)
}
if (!is.null(sigs)) {
ExposureGLM(
sigs$SignExposures,
feature = feature
)
}
}
}
return(NULL)
})
}
survivalplot <- function() {
output$covariate_plot <- renderPlot({
data <- get_tcga_data()
surv_method <- survival_method()
if ("time" %in% names(data) && "status" %in% names(data)) {
su <- as.matrix(data.frame(time = as.numeric(data$time), status = as.numeric(data$status)))
sigs <- sigs_obj()
if (is.null(sigs)) {
return(NULL)
}
if (!is.null(sigs)) {
ExposureSurvival(
Exposures = sigs$SignExposures, surv = su,
method = surv_method
)
}
}
return(NULL)
})
}
coxplot <- function() {
output$covariate_plot <- renderPlot({
data <- get_tcga_data()
if ("time" %in% names(data) && "status" %in% names(data)) {
su <- as.matrix(data.frame(time = as.numeric(data$time), status = as.numeric(data$status)))
sigs <- sigs_obj()
if (is.null(sigs)) {
return(NULL)
}
if (!is.null(sigs)) {
ExposureSurvModel(
Exposures = sigs$SignExposures, surv = su
)
}
}
return(NULL)
})
}
diffexpui <- function() {
req(input$plotid)
output$plot_options <- renderUI({
data <- get_tcga_data()
dropdownButton(
selectInput(
inputId = ns("diffexp_method"), label = "Method:",
choices = c("kruskal.test"),
selected = "kruskal.test", multiple = FALSE,
) %>% shinyInput_label_embed(
shiny::icon("info-circle", verify_fa=FALSE) %>%
bs_embed_tooltip(title = "Method")
),
selectInput(
inputId = ns("diffexp_padj"), label = "P-value adjust:",
choices = c("BH"),
selected = "BH", multiple = FALSE,
) %>% shinyInput_label_embed(
shiny::icon("info-circle", verify_fa=FALSE) %>%
bs_embed_tooltip(title = "padj")
),
numericInput(
ns("diffexp_quant"), "P-value quantile", 0.5,
min = 0, max = 1, step = 0.1
) %>% shinyInput_label_embed(
shiny::icon("info-circle", verify_fa=FALSE) %>%
bs_embed_tooltip(title = "quantile")
),
numericInput(
ns("diffexp_cutoff"), "P-value threshold", 0.5,
min = 0, max = 1, step = 0.1
) %>% shinyInput_label_embed(
shiny::icon("info-circle", verify_fa=FALSE) %>%
bs_embed_tooltip(title = "threshold")
),
circle = TRUE, status = "danger",
icon = icon("gear", verify_fa=FALSE), width = "200px",
tooltip = tooltipOptions(title = "Plot options")
)
})
}
sampleclassui <- function() {
req(input$plotid)
output$plot_options <- renderUI({
data <- get_tcga_data()
dropdownButton(
selectInput(
inputId = ns("sclassif_method"), label = "Method:",
choices = c(
"knn", "lvq", "logreg", "lda",
"lasso", "nb", "svm", "rf", "ab"
),
selected = "knn", multiple = FALSE
) %>% shinyInput_label_embed(
shiny::icon("info-circle", verify_fa=FALSE) %>%
bs_embed_tooltip(title = "Method")
),
numericInput(
ns("sclassif_kfold"), "K Fold", 1,
min = 1, step = 1
) %>% shinyInput_label_embed(
shiny::icon("info-circle", verify_fa=FALSE) %>%
bs_embed_tooltip(title = "threshold")
),
circle = TRUE, status = "danger",
icon = icon("gear", verify_fa=FALSE), width = "200px",
tooltip = tooltipOptions(title = "Plot options")
)
})
}
correlationui <- function() {
req(input$plotid)
output$plot_options <- renderUI({
NULL
})
}
linearregressionui <- function() {
req(input$plotid)
output$plot_options <- renderUI({
NULL
})
}
survivalui <- function() {
req(input$plotid)
output$plot_options <- renderUI({
data <- get_tcga_data()
dropdownButton(
selectInput(
inputId = ns("survival_method"), label = "Method:",
choices = c("logrank", "cox"),
selected = "logrank", multiple = FALSE,
) %>% shinyInput_label_embed(
shiny::icon("info-circle", verify_fa=FALSE) %>%
bs_embed_tooltip(title = "Method")
),
circle = TRUE, status = "danger",
icon = icon("gear", verify_fa=FALSE), width = "200px",
tooltip = tooltipOptions(title = "Plot options")
)
})
}
coxui <- function() {
req(input$plotid)
output$plot_options <- renderUI({
NULL
})
}
observeEvent(input$plotid, {
req(input$filtered_tcga_clinical_data_rows_selected)
if (input$plotid == "de") {
diffexpui()
diffexpplot()
} else if (input$plotid == "sc") {
sampleclassui()
sampleclassplot()
} else if (input$plotid == "cor") {
correlationui()
correlationplot()
} else if (input$plotid == "lr") {
linearregressionui()
linearregressionplot()
} else if (input$plotid == "sv") {
survivalui()
survivalplot()
} else if (input$plotid == "cx") {
coxui()
coxplot()
}
})
# strop spinner
output$covariate_plot <- renderPlot({
return(NULL)
})
output$dataset <- renderUI({
HTML(
"You are using the <span style='color:red'>complete</span>",
"<strong>", tcga_tumor(), "</strong> dataset for ",
"<strong>", analysis_type(), "</strong>", " analysis."
)
})
output$filtered_value <- renderUI({
feature <- input$feature
filter_op <- input$filter_op
filter_value <- input$filter_value
feature_row <- input$tcga_clinical_data_rows_selected
data <- get_tcga_data()
if (!is.null(feature_row) & !is.null(feature)) {
col <- names(data[feature_row + 1])
HTML(
"You have filtered the <em>", tcga_tumor(),
"</em> dataset for ",
"<strong>", analysis_type(), "</strong>", " analysis ",
" by <strong>", col,
"</strong> using the values: <span style='color:red'>",
paste(feature, collapse = ","),
"</span>."
)
} else if (!is.null(filter_value) & !is.null(feature_row)) {
col <- names(data[feature_row + 1])
HTML(
"You have filtered the <em>", tcga_tumor(),
"</em> dataset for ",
"<strong>", analysis_type(), "</strong>", " analysis ",
" by <strong>", col,
"</strong> using the values <span style='color:red'>",
filter_op, " then ", filter_value, "</span>."
)
} else {
HTML(
"You are using the <span style='color:red'>complete</span>",
"<strong>", tcga_tumor(), "</strong> dataset for ",
"<strong>", analysis_type(), "</strong>", " analysis."
)
}
})
get_plots_choices <- function() {
req(input$filtered_tcga_clinical_data_rows_selected)
feature_row <- input$filtered_tcga_clinical_data_rows_selected
data <- get_tcga_data()
col <- names(data[feature_row + 1])
t <- data %>%
select(col) %>%
rownames_to_column() %>%
select(-rowname) %>%
with(class(get(col)))
if (col == "time" || col == "status") {
return(c(
`<i class='km-img'></i>` = "sv",
`<i class='cox-img'></i>` = "cx"
))
} else if (t == "character") {
return(c(
`<i class='bx-img'></i>` = "de",
`<i class='sc-img'></i>` = "sc"
))
} else if (t == "numeric") {
return(c(
`<i class='cor-img'></i>` = "cor",
`<i class='lr-img'></i>` = "lr"
))
}
}
output$radio_buttons <- renderUI({
radioGroupButtons(
inputId = ns("plotid"),
label = NULL,
choices = get_plots_choices(),
selected = character(0),
direction = "vertical"
)
})
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.