R/explorer_module.R
In qinzhu/VisCello.celegans: A visualization tool for single cell data of C.elegans embrogenesis
Defines functions
explorer_server
explorer_ui
#' @export
explorer_ui <- function(id) {
ns <- NS(id)
uiOutput(ns("eui")) %>% withSpinner(type = 3, size = 3, color.background = "white")
}
#' @export
explorer_server <- function(input, output, session, sclist, useid, cmeta = NULL, showcols_basic = NULL, showcols_advanced = NULL, tabset = "ct"){
ev <- reactiveValues(list = NULL, sample=NULL, vis=NULL, cells = NULL, cell_source = NULL)
# Reactive variable storing all basic plot parameters
pvals <- reactiveValues()
output$eui <- renderUI({
ns <- session$ns
eui <- fluidRow(
column(4,
wellPanel(
class = "SidebarControl",
uiOutput(ns("input_sample_ui")),
uiOutput(ns("proj_type_ui")),
conditionalPanel("input.proj_type == 'PCA-2D'",
ns = ns,
fluidRow(
column(6, selectInput(ns("pca2d_v1"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC1")),
column(6, selectInput(ns("pca2d_v2"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC2"))
)
),
conditionalPanel("input.proj_type == 'PCA-3D'",
ns = ns,
fluidRow(
column(4, selectInput(ns("pca3d_v1"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC1")),
column(4, selectInput(ns("pca3d_v2"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC2")),
column(4, selectInput(ns("pca3d_v3"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC3"))
)
),
uiOutput(ns("proj_colorBy_ui")),
selectizeInput(ns("gene_list"), "Search gene:", choices = gene_tbl, multiple = T),
uiOutput(ns("plot_scalecolor_ui")),
uiOutput(ns("data_highlight"))
),
uiOutput(ns("selectCell_panel"))
),
column(8,
fluidRow(
column(8,
uiOutput(ns("lineage_tree_view")),
uiOutput(ns("left_tree_root_ui")),
uiOutput(ns("right_tree_root_ui")),
uiOutput(ns("top_tree_root_ui"))
),
column(4,
circleButton(ns("plot_config_reset"), icon = icon("undo"), size = "xs", status = "danger btn_rightAlign"),
shinyBS::bsTooltip(
ns("plot_config_reset"),
title = "Reset plot configuration",
options = list(container = "body")
),
uiOutput(ns("plot_configure_ui")),
dropdownButton2(inputId=ns("plot_download"),
fluidRow(
column(6, numericInput(ns("down_ploth"), "Height", min=1, value = 7, step=1)),
column(6, numericInput(ns("down_plotw"), "Width", min=1, value = 7, step=1))
),
fluidRow(
column(6, uiOutput(ns("explore_plotf_ui"))),
column(6, tags$br(), downloadButton(ns("download_explore_plot"), "Download", class = "btn-primary", style="width: 115px"))
),
circle = T, label ="Download Plot", tooltip=T, right = T,
icon = icon("download"), size = "xs", status="success", class = "btn_rightAlign"),
uiOutput(ns("g_limit_ui")),
uiOutput(ns("v_limit_ui")),
uiOutput(ns("tree_configure_ui"))
)
),
uiOutput(ns("plot_ui")) %>% withSpinner()
)
)
fui <- tagList(
wellPanel(
fluidRow(
column(3, uiOutput(ns("bp_sample_ui"))),
column(3, selectizeInput(ns("bp_gene"), "Search gene:", choices = c("No gene selected"="No gene selected", gene_tbl))),
column(3, uiOutput(ns("bp_colorBy_ui"))),
column(3, selectInput(ns("bp_log_transform_gene"), "Data scale", choices=list("Log2 normalized count"="log2", "Molecule (UMI) count" = "raw")))
),
uiOutput(ns("bp_include_ui")),
fluidRow(
column(9, tags$p("Hint: Select a gene to get its summarized expression across cell types/lineages.")),
column(3, actionLink(ns("bp_reset"), "Clear selected", class = "btn_rightAlign"))
)
),
fluidRow(
column(6),
column(6,
circleButton(ns("bp_plot_config_reset"), icon = icon("undo"), size = "xs", status = "danger btn_rightAlign"),
shinyBS::bsTooltip(
ns("bp_plot_config_reset"),
title = "Reset plot configuration",
options = list(container = "body")
),
uiOutput(ns("bp_plot_configure_ui")),
dropdownButton2(inputId=ns("bp_plot_download"),
fluidRow(
column(6, numericInput(ns("bp_down_ploth"), "Height", min=1, value = 5, step=1)),
column(6, numericInput(ns("bp_down_plotw"), "Width", min=1, value = 7, step=1))
),
fluidRow(
column(6, selectInput(ns("bp_plotf"), "Format", choices = list("png","pdf","eps","tiff"))),
column(6, tags$br(), downloadButton(ns("download_bp_plot"), "Download", class = "btn-primary", style="width: 115px"))
),
circle = T, label ="Download Plot", tooltip=T, right = T,
icon = icon("download"), size = "xs", status="success", class = "btn_rightAlign")
)
),
uiOutput(ns("bp_gene_plot_ui"))
)
if(tabset == "ct") {
hmap_ui <- uiOutput(ns("sm_hmap_ui"))
} else {
hmap_ui <- tagList(
tags$b("Expression "),
tags$select(id=ns("sm_type"),
class = "customDrop",
tags$option(value = "hmap", "Heatmap", selected=T),
tags$option(value = "radio", "Radio graph")
),
conditionalPanel(
"input.sm_type == 'hmap'",
ns = ns,
uiOutput(ns("sm_hmap_ui"))
),
conditionalPanel(
"input.sm_type == 'radio'",
ns = ns,
uiOutput(ns("sm_radio_ui"))
)
)
}
sui <- tagList(
wellPanel(
uiOutput(ns("sm_option")),
fluidRow(
column(9, tags$p("Hint: Select one or more genes to visualize its summarized expression. To view expression of all genes for a specific cell, select the cell and deselect all genes.")),
column(3, actionLink(ns("sm_reset"), "Clear selected", class = "btn_rightAlign"))
)
),
DT::dataTableOutput(ns("sm_tbl")) %>% withSpinner(),
downloadButton(ns("download_sm_tbl"), "Download table", class = "btn_rightAlign")
#hmap_ui
)
cui <- tagList(
DT::dataTableOutput(ns("ct_marker_tbl")),
downloadButton(ns("download_ct_marker"), "Download table", class = "btn_rightAlign")
)
# Marker imaging graph ui
mui <- fluidRow(
column(4,
wellPanel(
selectInput(ns("image_colorBy"), "Color by", choices = image_colorBy_choices),
fluidRow(
column(6, selectInput(ns("image_scale"), "Scale", choices=c("Linear" = "linear", "Log10"="log10"), selected = "linear")),
column(6, selectInput(ns("image_pal"), "Palette", choices=image_palettes))
),
numericInput(ns("image_ploth"), "Plot height", min=1, value = 7, step=1),
tags$br(),
tags$div(tags$strong("EPiC Movies: "), tags$a("http://epic.gs.washington.edu/", href="http://epic.gs.washington.edu/")),
tags$div(tags$strong("EPiC2 Movies: "), tags$a("http://epic.gs.washington.edu/Epic2/", href="http://epic.gs.washington.edu/Epic2/"))
),
fluidRow(
column(12, tags$p("Expression level summarized from following sources:"))
),
DT::dataTableOutput(ns("g_meta_table"))
),
column(8,
uiOutput(ns("image_graph_plot_ui")),
tags$br(),
tags$b("Lineage tree colored by expression of gene X as determined by imaging of a fluorescent reporter.")
)
)
lui <- tagList(
DT::dataTableOutput(ns("lin_marker_tbl")),
downloadButton(ns("download_lin_marker"), "Download table", class = "btn_rightAlign")
)
if(tabset == "lin") {
tabsetPanel(
id = ns("lin_tab"),
tabPanel(
value = "eui",
tags$b("Explorer"),
eui
),
tabPanel(
value = "fui",
tags$b("Expression by Cell Type/Lineage"),
fui
),
tabPanel(
value = "sui",
tags$b("Summarized Expression"),
sui
),
tabPanel(
value = "lui",
tags$b("Lineage Markers"),
tags$br(),
tags$b("Table below shows markers used for annotation. NOT new markers identified from the single cell data."),
lui
),
tabPanel(
value = "mui",
tags$b("Marker Imaging"),
tags$br(),
mui
)
)
} else if(tabset == "ct") {
tabsetPanel(
id = ns("ct_tab"),
tabPanel(
value = "eui",
tags$b("Explorer"),
eui
),
tabPanel(
value = "fui",
tags$b("Expression by Cell Type/Lineage"),
fui
),
tabPanel(
value = "sui",
tags$b("Summarized Expression"),
sui
),
tabPanel(
value = "cui",
tags$b("Cell Type Markers"),
tags$br(),
tags$b("Table below shows markers used for annotation. NOT new markers identified from the single cell data."),
cui
)
)
} else {
return()
}
})
output$input_sample_ui <- renderUI({
ns <- session$ns
sample_names <- names(ev$list)
if(tabset == "lin") sample_names <- c(elin_sets_basic, names(ev$list)[!names(ev$list) %in% names(elist)], "More options..." = "moreop")
selectInput(ns("input_sample"), tags$div("Choose cell subset:", pivot_help_UI(ns("choose_sample_info"), title = NULL, label = NULL, icn="question-circle", type = "link", tooltip = F, style = "padding-left:10px;")), choices=sample_names)
})
observeEvent(input$input_sample, {
if(tabset == "lin") {
sample_names <- names(ev$list)
if(input$input_sample == "lessop") {
sample_names <- c(elin_sets_basic, names(ev$list)[!names(ev$list) %in% names(elist)], "More options..." = "moreop")
updateSelectInput(session, "input_sample", choices = sample_names)
} else if(input$input_sample == "moreop") {
sample_names <- c(names(ev$list), "Less options..." = "lessop")
updateSelectInput(session, "input_sample", choices = sample_names)
}
}
})
output$proj_type_ui <- renderUI({
ns <- session$ns
req(ev$vis)
options <- names(ev$vis@proj)
if("PCA" %in% options) options <- c(options[!options == "PCA"], "PCA-2D", "PCA-3D")
tagList(
selectInput(ns("proj_type"), "Choose projection:", choices=options),
conditionalPanel("1==0", textInput(ns("proj_type_I"), NULL, value = ev$sample))
)
})
output$proj_colorBy_ui <- renderUI({
ns = session$ns
selectInput(ns("proj_colorBy"), "Color by", choices = c(showcols_basic, ev$meta_custom, "More options..."="moreop"))
})
observeEvent(input$proj_colorBy, {
if(input$proj_colorBy == "lessop") {
updateSelectInput(session, "proj_colorBy", "Color By", choices = c(showcols_basic, ev$meta_custom, "More options..."="moreop"))
} else if(input$proj_colorBy == "moreop") {
updateSelectInput(session, "proj_colorBy", "Color By", choices = c(showcols_advanced, ev$meta_custom, "Less options..."="lessop"))
} else if(input$proj_colorBy != "gene.expr") {
if(!is.null(input$gene_list)) {
updateSelectInput(session, "gene_list", selected = "")
}
}
})
output$plot_scalecolor_ui <- renderUI({
ns = session$ns
req(input$proj_colorBy, !input$proj_colorBy %in% c("moreop", "lessop"))
if(input$proj_colorBy == 'gene.expr') {
selectInput(ns("log_transform_gene"), "Data scale", choices=list("Log2 normalized count"="log2", "Molecule (UMI) count" = "raw"))
} else if(!input$proj_colorBy %in% ev$factor_cols){
if(input$proj_colorBy %in% pmeta_attr$meta_id && !is.null(pmeta_attr$dscale)) {
default_scale <- pmeta_attr$dscale[which(pmeta_attr$meta_id==input$proj_colorBy)]
} else {
default_scale <- NULL
}
selectInput(ns("log_transform_val"), "Data scale", choices=list("Log10"="log10", "Identity" = "identity"), selected = default_scale)
} else {
return()
}
})
output$lineage_tree_view <- renderUI({
ns <- session$ns
req(input$proj_colorBy)
#if(input$proj_colorBy %in% c("lineage", "gene.expr", "raw.embryo.time")) {
if(input$proj_colorBy %in% c("lineage", "gene.expr")) {
div(checkboxGroupButtons(
inputId = ns("tree_view"), label = NULL,
size = "xs", width = "100px",
choices = c("Lineage Tree"),
justified = TRUE, status = "info",
checkIcon = list(yes = icon("record", lib = "glyphicon"), no = icon("ban-circle", lib = "glyphicon"))
),style = "float:left;margin-top:5px;")
} else {
ev$tree_view <- F
return()
}
})
observe({
if(!is.null(input$tree_view)){
ev$tree_view <- T
} else {
ev$tree_view <- F
}
})
output$tree_configure_ui <- renderUI({
ns <- session$ns
req(ev$tree_view)
dropdownButton2(inputId=ns("tree_configure"),
fluidRow(
column(6, numericInput(ns("tree_time_cut"), "Birth time cut", min = 10, value = 300, step = 10)),
column(6, selectInput(ns("tree_label_style"), "Label style", choices = c("No label" = "none", "Text" = "text", "Label" = "label")))
),
fluidRow(
column(6, numericInput(ns("tree_label_cut"), "Label time cut", min = 10, value = 80, step = 10)),
column(6, numericInput(ns("tree_label_size"), "Label size", min = 1, value = 3, step = 1))
),
fluidRow(
column(6, numericInput(ns("tree_edge_size"), "Edge size", min = 0.1, value = 1, step = 0.1)),
column(6, numericInput(ns("tree_tip_size"), "Tip size", min = 0, value = 0, step = 1))
),
fluidRow(
column(6, checkboxInput(ns("tree_filter_na"), tags$b("Filter unmapped leaves"), value = F)),
column(6, numericInput(ns("tree_height"), "Tree height (scale)", min=1/10, max = 1, value = 1/4, step=.1))
),
conditionalPanel("1==0", textInput(ns("tree_colorBy_fake"), NULL, value = input$proj_colorBy)),
circle = T, label ="Configure Tree", tooltip=T, right = T,
icon = icon("grain", lib = "glyphicon"), size = "xs", status="info", class = "btn_rightAlign")
})
output$left_tree_root_ui <- renderUI({
req(ev$tree_view)
ns <- session$ns
choices <- as.list(c("No left tree", avail_nodes[1:101]))
names(choices) <- choices
tagList(
tags$p("L:", style="display:inline-block;float:left;margin-top:7px;margin-left:5px;"),
tags$select(id=ns("left_tree_root"),
class = "customDrop",
style = "display:inline-block;float:left;width:80px;margin-top:7px;margin-left:3px;",
shiny:::selectOptions(choices,selected = "ABa"))
)
})
output$right_tree_root_ui <- renderUI({
req(ev$tree_view)
ns <- session$ns
choices <- as.list(c("No right tree", avail_nodes[1:101]))
names(choices) <- choices
tagList(
tags$p("R:", style="display:inline-block;float:left;margin-top:7px;margin-left:5px;"),
tags$select(id=ns("right_tree_root"),
class = "customDrop",
style = "display:inline-block;float:left;width:80px;margin-top:7px;margin-left:3px;",
shiny:::selectOptions(choices,selected = "ABp"))
)
})
output$top_tree_root_ui <- renderUI({
req(ev$tree_view)
ns <- session$ns
choices <- as.list(c("No top tree", avail_nodes[1:101]))
names(choices) <- choices
tagList(
tags$p("T:", style="display:inline-block;float:left;margin-top:7px;margin-left:5px;"),
tags$select(id=ns("top_tree_root"),
class = "customDrop",
style = "display:inline-block;float:left;width:80px;margin-top:7px;margin-left:3px;",
shiny:::selectOptions(choices,selected = "P1"))
)
})
output$plot_configure_ui <- renderUI({
input$plot_config_reset
ns <- session$ns
dropdownButton2(inputId=ns("plot_configure"),
fluidRow(
column(6, numericInput(ns("marker_size"), "Point size", min = 0.1, value = 1, step = 0.1)),
column(6, numericInput(ns("text_size"), "Text size", min = 1, value = 3, step = 1))
),
fluidRow(
column(6, selectInput(ns("color_pal"), "Palette", choices=factor_color_opt())),
column(6, selectInput(ns("legend_type"), "Legend", choices=c("Color legend" = "l", "Onplot label" = "ol", "Onplot text" = "ot", "Legend + Label" = "lol", "Legend + Text" = "lot", "None" = "none"), selected = "ot"))
),
fluidRow(
column(6, numericInput(ns("show_ploth"), "Height (resize window for width)", min=1, value = 7, step=1)),
column(6, numericInput(ns("alpha_level"), "Transparency (for cells not selected)", min = 0, max = 1, value = 0.01, step = 0.01))
),
circle = T, label ="Configure Plot", tooltip=T, right = T,
icon = icon("cog"), size = "xs", status="primary", class = "btn_rightAlign")
})
observeEvent(input$proj_colorBy, {
req(!input$proj_colorBy %in% c("moreop", "lessop"))
req(ev$factor_cols)
if(input$proj_colorBy %in% pmeta_attr$meta_id && !is.null(pmeta_attr$dpal)) {
default_pal <- pmeta_attr$dpal[which(pmeta_attr$meta_id==input$proj_colorBy)]
} else {
default_pal <- NULL
}
if(input$proj_colorBy == 'gene.expr') {
updateSelectInput(session, "color_pal", "Palette", choices=numeric_palettes, selected=default_pal)
} else if(input$proj_colorBy %in% ev$factor_cols){
if(grepl("time.bin", input$proj_colorBy)) {
updateSelectInput(session, "color_pal", "Palette", choices=numeric_bin_color_opt(), selected=default_pal)
} else {
updateSelectInput(session, "color_pal", "Palette", choices=factor_color_opt(), selected=default_pal)
}
} else {
updateSelectInput(session, "color_pal", choices=numeric_palettes, selected=default_pal)
}
})
observe({
req(ev$cells)
isolate({
updateSelectInput(session, "selectCell_goal", selected=lapply(reactiveValuesToList(input), unclass)$selectCell_goal)
})
})
#updateSelectizeInput(session, "gene_list", "Search Gene:", choices = gene_tbl, selected = NULL, server=T)
output$plot_ui <- renderUI({
ns <- session$ns
req(input$proj_type)
if(!grepl("3D", input$proj_type, ignore.case = T)) {
req(pp1())
tagList(
plotOutput(ns("plot2d"), height = paste0(500/5.5 *input$show_ploth,"px"),
brush = brushOpts(
id = ns("plot2d_brush")
),
hover = hoverOpts(id = ns("plot2d_hover"), delay = 50)), #%>% withSpinner()
uiOutput(ns("plot2d_tooltip")),
tags$li("Hint: Mouse over points to see the detailed annotation. Drag on plots to select cells. Set plot aesthetics (legend etc.) using gear button in upper right.", style = "font-size:12px")
)
} else {
req(pp1_3d())
plotlyOutput(ns("plotly3d"), height = paste0(500/5.5 *input$show_ploth,"px"), width = "100%") #%>% withSpinner()
}
})
output$plot2d_tooltip <- renderUI({
ns <- session$ns
hover <- input$plot2d_hover
x <- nearPoints(pvals$proj, hover, xvar = pvals$plot_col[1], yvar = pvals$plot_col[2], maxpoints = 1)
# If tree view, show lineage
if(ev$tree_view && !nrow(x)){
x <- nearPoints(bind_rows(pvals$coords[2:4]), hover, xvar = "x", yvar = "y", maxpoints = 1)
show_col <- "label"
} else {
show_col <- pvals$proj_colorBy
}
req(nrow(x) > 0)
if(pvals$plot_class != "expression" || is.null(ev$gene_values) || show_col == "label") {
y <- as.character(x[[show_col]])
if(show_col == "label") tt <-"Lineage" else tt <- pvals$legend_title
tip <- paste0("<b>",tt, ": </b>", y, "<br/>")
} else {
y <- round(ev$gene_values[rownames(x),, drop=F],3)
tip <- paste0(sapply(1:ncol(y), function(i) paste0("<b>", colnames(y)[i], ": </b>", y[[i]], "<br/>")), collapse = "")
}
req(length(y) > 0)
style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.65); ",
"left:", hover$coords_css$x + 2, "px; top:", hover$coords_css$y + 2, "px;",
"margin:5px; padding:5px 5px 0px 5px;")
# actual tooltip created as wellPanel
wellPanel(
style = style,
p(HTML(tip))
)
})
output$data_highlight <- renderUI({
req(ev$vis, input$proj_colorBy, !grepl("3D", input$proj_type), !input$proj_colorBy %in% c("moreop", "lessop"))
#print(paste0("highlight:", input$proj_colorBy))
input$gene_list
input$log_transform_val
input$choose_cell_reset
ns <- session$ns
proj_colorBy_dh <- input$proj_colorBy # This is necessary!!! See explanation in the observer
ui1 <- NULL
if(input$proj_colorBy %in% ev$factor_cols) {
if(input$proj_colorBy %in% c("cell.type", "cell.subtype")) {
factors <- names(which(table(ev$meta[[input$proj_colorBy]]) >= 10))
} else {
factors <- as.character(levels(factor(ev$meta[[input$proj_colorBy]])))
}
names(factors) <- factors
tip <- shinyBS::bsTooltip(
ns("choose_cell_reset"),
title = "Reset option",
options = list(container = "body", delay = list(show=1000, hide=3000))
)
ui1 <- selectInput(ns("factor_compo"), tags$div("Choose cells:", tipify(actionLink(ns("choose_cell_reset"), label = NULL, icon = icon("remove-sign", lib = "glyphicon"), style = "padding-left:10px;"), title = "Reset option")), choices = factors, multiple = T)
} else if(input$proj_colorBy != "gene.expr") {
num_range <- range(ev$value)
num_range[1] <- floor_dec(num_range[1],2)
num_range[2] <- ceiling_dec(num_range[2],2)
ui1 <- sliderInput(ns("numeric_range"), label = "Select Range", min = num_range[1], max = num_range[2], value = num_range)
} else if(input$proj_colorBy == "gene.expr"){
curg <- input$gene_list
if(length(curg)){
options <- list(
"All cells" = "nulv"
)
if(length(curg) == 1) {
curg_opt <- "1g"
names(curg_opt) <- paste0("Express: ", curg)
} else {
curg_opt <- "mg"
names(curg_opt) <- paste0("Co-Express: ", paste(curg, collapse = ", "))
}
options <- c(options, curg_opt)
ui1 <- selectInput(ns("cell_expr_gene"), "Choose Cells:", choices = options, multiple = F)
}
}
return(tagList(
ui1,
conditionalPanel("1==0", ns = ns, textInput(ns("proj_colorBy_dh"), label = NULL, value = proj_colorBy_dh)) # This is necessary!!! See explanation in the observer
))
})
observe({
ev$list <- sclist[[useid]]
rval$list <- sclist[[useid]]
})
observe({
sample <- input$input_sample
req(sample %in% names(ev$list), cmeta$df)
isolate({
ev$sample <- sample
ev$vis <- ev$list[[sample]]
idx <- ev$vis@idx
cur_meta <- cmeta$df[ev$vis@idx,]
if(!is.null(ev$vis@pmeta) && nrow(ev$vis@pmeta) == nrow(cur_meta)) cur_meta <- cbind(cur_meta, ev$vis@pmeta)
ev$meta <- cur_meta
ev$factor_cols <- sapply(colnames(ev$meta), function(x) {
ifelse(!is.numeric(ev$meta[[x]]), x, NA)
})
ev$meta_custom <- colnames(ev$meta)[!colnames(ev$meta) %in% showcols_advanced]
})
})
observeEvent(input$gene_list, {
updateSelectInput(session, "proj_colorBy", selected = "gene.expr")
})
# Data dependent
observe({
input$plot_config_reset
req(input$input_sample, input$proj_type, input$proj_colorBy, !input$proj_colorBy %in% c('lessop', 'moreop'))
req(input$input_sample == input$proj_type_I) # Sync the two renderUIs
if(!grepl("3D", input$proj_type)) req(input$proj_colorBy_dh == input$proj_colorBy)
# Prevent rendering twice when switching between gene expression and other colorBy
if(input$proj_colorBy != "gene.expr" && !is.null(input$gene_list)) {
return()
}
plot_col <- if(grepl("3D", input$proj_type)) {paste0("V", 1:3)} else {paste0("V", 1:2)}
if(grepl("PCA", input$proj_type)) {
if(!grepl("3D", input$proj_type)) {
req(input$pca2d_v1)
plot_col <- c(input$pca2d_v1, input$pca2d_v2)
} else {
req(input$pca3d_v1, input$pca3d_v2, input$pca3d_v3)
plot_col <- c(input$pca3d_v1, input$pca3d_v2, input$pca3d_v3)
}
ptype = "PCA"
} else {
ptype = input$proj_type
}
req(ptype %in% names(ev$vis@proj))
proj <- ev$vis@proj[[ptype]]
req(nrow(proj) == nrow(ev$meta))
proj <- cbind(proj, ev$meta)
proj$alpha <- rep("f", length(nrow(proj)))
gene_values <- NULL
gene_exprlim <- NULL
factor_color <- NULL
trans <- NULL
limits <- NULL
factor_breaks <- waiver()
if(input$proj_colorBy %in% ev$factor_cols) {
plot_class = "factor"
if(grepl("time.bin", input$proj_colorBy)) {
req(input$color_pal %in% numeric_bin_color_opt())
factor_color <- get_numeric_bin_color(levels(proj[[input$proj_colorBy]]), palette = input$color_pal)
names(factor_color) <- levels(proj[[input$proj_colorBy]])
} else {
req(input$color_pal %in% factor_color_opt())
factor_color <- get_factor_color(unique(proj[[input$proj_colorBy]]), pal=input$color_pal, maxCol = 9)
if(input$proj_colorBy == "to.filter") { # special case
factor_color <- rev(factor_color)
}
names(factor_color) <- unique(proj[[input$proj_colorBy]])
}
factor_color[["unannotated"]] <- "lightgrey"
if(input$proj_colorBy %in% c("cell.type", "cell.subtype")) {
factor_breaks <- names(which(table(proj[[input$proj_colorBy]]) >= 10))
} else if(input$proj_colorBy %in% c("lineage")) {
factor_breaks <- names(which(table(proj[[input$proj_colorBy]]) >= 5)) # Lower?
} else {
factor_breaks <- names(factor_color)
}
factor_breaks <- factor_breaks[factor_breaks != "unannotated"]
if(!is.null(input$factor_compo)) {
proj$alpha <- ifelse(proj[[input$proj_colorBy]] %in% input$factor_compo, "f", "t")
}
} else {
req(input$color_pal)
if(input$proj_colorBy == "gene.expr"){
plot_class <- "expression"
if(length(input$gene_list) == 1) {
#req(!is.na(input$g_limit))
req(input$g_limit_sample == ev$sample)
req(input$g_limit_ds == input$log_transform_gene)
req(input$g_limit_gene == input$gene_list)
#print(paste0(input$gene_list, ": ", input$g_limit))
if(is.na(input$g_limit)) {
limits <- c(0,1)
} else {
limits <- c(0,input$g_limit)
}
}
if(!is.null(input$cell_expr_gene) && !is.null(ev$gene_values)) {
if(input$cell_expr_gene!="nulv") {
proj$alpha <- ifelse(rowSums(ev$gene_values > 0) == ncol(ev$gene_values), "f", "t")
}
}
} else {
plot_class <- "numeric"
# !!! IMPORTANT !!!
# This evaluates if renderUI for v_limit has been updated, to prevent the plot from rendering twice
# If not updated, previous v_limit UI's corresponding proj_colorBy will not be the same as current input$proj_colorBy, then reactive is aborted.
req(ev$value_sample == ev$sample,
input$proj_colorBy_vlim == input$proj_colorBy,
input$v_limit_ds == input$log_transform_val,
input$v_limit_sample == ev$sample)
req(input$v_limit)
proj[[input$proj_colorBy]] <- ev$value
limits<-c(min(proj[[input$proj_colorBy]]), input$v_limit)
if(!is.null(input$numeric_range)) proj$alpha <- ifelse(proj[[input$proj_colorBy]] >= input$numeric_range[1] & proj[[input$proj_colorBy]] <= input$numeric_range[2], "f", "t")
}
}
legend=F; onplotAnnot=NULL
if(!is.null(input$legend_type)) {
if(input$legend_type == "l") {
legend=T; onplotAnnot=NULL
} else if(input$legend_type == "lot") {
legend=T; onplotAnnot="text"
} else if(input$legend_type == "lol") {
legend=T; onplotAnnot="label"
} else if(input$legend_type == "ot"){
legend=F; onplotAnnot="text"
} else if(input$legend_type == "ol"){
legend=F; onplotAnnot="label"
}
}
ev$proj <- proj # Save an original copy for zoom in
pvals$proj <- proj
pvals$proj_colorBy <- input$proj_colorBy
pvals$legend_title <- pmeta_attr$meta_name[which(pmeta_attr$meta_id == pvals$proj_colorBy)]
pvals$plot_class <- plot_class
pvals$plot_col <- plot_col
pvals$factor_color <- factor_color
pvals$color_pal <- input$color_pal
pvals$marker_size <- input$marker_size
pvals$text_size <- input$text_size
pvals$factor_compo <- input$factor_compo
pvals$factor_breaks <- factor_breaks
pvals$alpha_level <-input$alpha_level
pvals$limits <- limits
pvals$legend = legend
pvals$onplotAnnot = onplotAnnot
pvals$gene_values <- ev$gene_values
pvals$log_transform_gene <- input$log_transform_gene
})
observe({
req(input$proj_colorBy, input$log_transform_val)
req(is.numeric(ev$meta[[input$proj_colorBy]]))
if(input$log_transform_val == "log10") {
ev$value <- log10(ev$meta[[input$proj_colorBy]] + 1) # +1 ok for pseudo? Be careful for small values! Don't allow log in future
ev$value_sample <- ev$sample # Use this to sync up reactivity
} else {
ev$value <- ev$meta[[input$proj_colorBy]]
ev$value_sample <- ev$sample
}
})
observe({
req(input$log_transform_gene)
if(is.null(input$gene_list)) {
ev$gene_values <- NULL
return()
}
if(length(input$gene_list) > 2) {
session$sendCustomMessage(type = "showalert", "Do not support more than 2 genes.")
return()
}
if(input$log_transform_gene == "log2") {
ev$gene_values <- t(as.matrix(eset@assayData$norm_exprs[input$gene_list,ev$vis@idx, drop=F]))
} else if(input$log_transform_gene == "raw") {
ev$gene_values <- t(as.matrix(exprs(eset)[input$gene_list,ev$vis@idx, drop=F]))
}
#sassign("ev", reactiveValuesToList(ev), env =.GlobalEnv)
})
pp_factor <- reactive({
plotProj(pvals$proj, dim_col = which(colnames(pvals$proj) %in% pvals$plot_col), group.by=pvals$proj_colorBy, pal=pvals$factor_color, size = pvals$marker_size, plot_title=NULL, legend.title = pvals$legend_title, na.col = "lightgrey", alpha=pvals$proj$alpha, alpha_level=pvals$alpha_level, legend=pvals$legend, onplotAnnot = pvals$onplotAnnot, onplotAnnotSize = pvals$text_size, legend.text.size = pvals$text_size*3, ncol=4, breaks = pvals$factor_breaks)
})
pp_numeric <- reactive({
plotProj(pvals$proj, dim_col = which(colnames(pvals$proj) %in% pvals$plot_col), group.by=pvals$proj_colorBy, pal=pvals$color_pal, size = pvals$marker_size, plot_title=NULL, legend_title = pvals$legend_title, na.col = "lightgrey", alpha=pvals$proj$alpha, alpha_level=pvals$alpha_level, legend=T, trans = "identity", limits = pvals$limits)
})
pp_gene <- reactive({
if(is.null(pvals$gene_values)) {
ggplot(pvals$proj, aes_string(pvals$plot_col[1],pvals$plot_col[2])) +
geom_point(color="lightgrey", size=pvals$marker_size)+
theme_bw() +
theme(plot.title = element_text(hjust = 0.5), legend.position = c("top"))+ guides(alpha=F)
} else {
visualize_gene_expression(pvals$gene_values, colnames(pvals$gene_values), pvals$proj[c(pvals$plot_col[1],pvals$plot_col[2])],
limits=pvals$limits,
marker_size = pvals$marker_size, ncol=1,
binary = ifelse(ncol(pvals$gene_values) == 1, F, T),
pal=pvals$color_pal,
na.col = "lightgrey",
legend_name = ifelse(pvals$log_transform_gene == "log2",
paste0(colnames(pvals$gene_values), " expression\n(log normalized)"),
paste0(colnames(pvals$gene_values), " expression\n(UMI count)")))
}
})
pp1 <- reactive({
req(length(pvals$plot_col) == 2, pvals$plot_class)
input$tree_view
assign("pvals", reactiveValuesToList(pvals),env=.GlobalEnv)
if(pvals$plot_class == "factor") {
p <- pp_factor()
} else if(pvals$plot_class == "numeric") {
p <- pp_numeric()
} else {
p <- pp_gene()
}
if(ev$tree_view) {
req(input$tree_colorBy_fake == input$proj_colorBy)
req(input$tree_edge_size)
share_col = "lineage"
if(input$tree_filter_na) {
tip_to_drop <- fortify(as.treedata(tree_tbl))%>% filter(isTip & is.na(lineage))
cur_tree<-tree_tbl %>% filter(!to %in% tip_to_drop$label)
} else {
cur_tree<-tree_tbl
}
show_lin <- names(which(table(pvals$proj$lineage) >= 5))
if(input$proj_colorBy == "lineage") {
colorBy = share_col
cur_tree$lineage[which(!cur_tree$lineage %in% show_lin)] <- NA
} else if(input$proj_colorBy == "gene.expr") {
colorBy <- "value"
cur_tree$value <- lin_sc_expr[colnames(pvals$gene_values),][match(cur_tree$to, colnames(lin_sc_expr))]
}
# else if(input$proj_colorBy == "raw.embryo.time") {
# cur_tree$raw.embryo.time <- cur_tree$br_time + min(80, cur_tree$lifetime/2) # Median time
# colorBy <- "raw.embryo.time"
# }
if(input$left_tree_root!="No left tree") {
left_tree <- make_lineage_ggtree(in_tree = cur_tree, root = input$left_tree_root, time.cut = input$tree_time_cut, color.annot = colorBy, branch.length='lifetime')
} else left_tree <- NULL
if(input$right_tree_root!="No right tree") {
right_tree <- make_lineage_ggtree(in_tree = cur_tree, root = input$right_tree_root, time.cut = input$tree_time_cut, color.annot = colorBy, branch.length='lifetime')
} else right_tree <- NULL
if(input$top_tree_root!="No top tree") {
top_tree <- make_lineage_ggtree(in_tree = cur_tree, root = input$top_tree_root, time.cut = input$tree_time_cut, color.annot = colorBy, branch.length='lifetime')
} else top_tree <- NULL
if(is.null(left_tree) && is.null(right_tree) && is.null(top_tree)) return(p + theme_void())
res <- make_tree_dimr(proj=pvals$proj, left_tree = left_tree, right_tree = right_tree, top_tree = top_tree,
colorBy = colorBy, tree.color = pvals$factor_color,
label.time.cut = input$tree_label_cut, label.size = input$tree_label_size,
edge.size = input$tree_edge_size, tip.size = input$tree_tip_size,
tree.h.scale = input$tree_height,
plot.link = NULL, shift.y.scale = 1/20,
label.type = input$tree_label_style,
return_coords = T)
isolate({
pvals$coords <- res$coords
})
p <- res$plot + theme_void()
}
return(p)
})
pp1_final <- reactive({
req(pp1())
if(ev$tree_view && length(ev$cells)){
share_col = "lineage"
proj=pvals$proj
colnames(proj)[c(1,2)] <- c("x","y")
area_selected <- ev$area
proj <- proj[, c("x","y", share_col)]
highlight_lin <- table(proj$lineage[rownames(proj) %in% ev$cells])
highlight_lin <- names(highlight_lin[highlight_lin >= 5])
proj_center <- proj %>% group_by_at(share_col) %>% summarize_at(c("x", "y"), median) %>%
filter(lineage %in% highlight_lin)
if(ev$cell_source=="plot selection" && !is.null(ev$area)) {
proj_center <- proj %>% filter(x>=ev$area$xmin & x<=ev$area$xmax & y>=ev$area$ymin & y<= ev$area$ymax) # Only highlight centers in selected region
}
use_col <- c("x","y",share_col)
link_col <- c()
if(input$left_tree_root!="No left tree") {link_col <- c(link_col, "d1")}
if(input$right_tree_root!="No right tree") {link_col <- c(link_col, "d2")}
if(input$top_tree_root!="No top tree") {link_col <- c(link_col, "d3")}
if(!length(link_col)) return(pp1())
df_bind <- lapply(pvals$coords[link_col], function(x){
x[,use_col]
})
dd_tree <- bind_rows(df_bind) %>% filter(lineage %in% highlight_lin)
dd_tree$x2 <- proj_center$x[match(dd_tree[[share_col]], proj_center[[share_col]])]
dd_tree$y2 <- proj_center$y[match(dd_tree[[share_col]], proj_center[[share_col]])]
p <- pp1() +
geom_segment(aes(x = x, y=y, xend = x2, yend =y2), data=dd_tree, color='grey', alpha = .5, size = .5)
} else {
p <- pp1()
}
return(p)
})
output$plot2d <- renderPlot({
req(pp1_final())
})
pp1_3d <- reactive({
req(pvals$proj, length(pvals$plot_col) == 3)
proj <- pvals$proj
ds <- pvals$plot_col
marker_size <- pvals$marker_size * 2
#assign("pvals", reactiveValuesToList(pvals), env = .GlobalEnv)
#alpha_manual <- c("f"=1,"t"=pvals$alpha_level)
if(pvals$plot_class == "factor") {
plotly::plot_ly(proj, x = as.formula(paste0("~", ds[1])), y = as.formula(paste0("~", ds[2])), z = as.formula(paste0("~", ds[3])),
text=proj[[pvals$proj_colorBy]],
hoverinfo="text",
marker = list(size = marker_size),
#opacity=alpha_manual[proj$alpha],
key = row.names(proj),
color = as.formula(paste0("~", pvals$proj_colorBy)), colors = pvals$factor_color) %>%
plotly::add_markers() %>%
layout(legend = list(orientation = 'h'))
} else if(pvals$plot_class == "numeric") {
rgb_scale_list<- numeric_rgb_range(col = get_numeric_color(pvals$color_pal), zgrey=F)
proj$show_value <- proj[[pvals$proj_colorBy]] # Show original value
if(!is.null(pvals$limits)) {
proj[[pvals$proj_colorBy]][proj[[pvals$proj_colorBy]] < pvals$limits[1]] <- pvals$limits[1]
proj[[pvals$proj_colorBy]][proj[[pvals$proj_colorBy]] > pvals$limits[2]] <- pvals$limits[2]
}
plotly::plot_ly(proj,
x = as.formula(paste0("~", ds[1])), y = as.formula(paste0("~", ds[2])), z = as.formula(paste0("~", ds[3])),
text=proj$show_value,
hoverinfo="text",
key = row.names(proj),
marker = list(size = marker_size,
color = as.formula(paste0("~", pvals$proj_colorBy)),
colorscale = rgb_scale_list)) %>%
plotly::add_markers(
#opacity=alpha_manual[proj$alpha]
) %>%
layout(legend = list(orientation = 'h'))
} else {
visualize_expression_plotly(expr= pvals$gene_values, projection = proj, ds=ds, gene_probes = colnames(pvals$gene_values), limits = pvals$limits, marker_size=marker_size, pal = pvals$color_pal)
}
})
output$plotly3d <- renderPlotly({
req(pp1_3d())
assign("pp1_3d", pp1_3d(), env = .GlobalEnv)
pp1_3d() %>% hide_legend()
})
output$explore_plotf_ui <- renderUI({
ns <- session$ns
req(input$proj_type)
if(!grepl("3D", input$proj_type)){
choices <- list("png" = "png", "pdf" = "pdf", "eps" = "eps", "tiff" = "tiff")
} else {
choices <- list( "html" = "html")
}
selectInput(ns("plotf"), "Format", choices = choices, selected = choices[[1]])
})
output$download_explore_plot <- downloadHandler(
filename = function(format = input$plotf) {
fn_ext<-switch(format,
png = '.png',
tiff = '.tiff',
eps = '.eps',
pdf = '.pdf',
html = '.html'
)
paste('Plot-', Sys.Date(), fn_ext, sep='')
},
content = function(con, format = input$plotf) {
req(input$down_plotw, input$down_ploth, format)
fn_dev<-switch(format,
png = 'png',
tiff = 'tiff',
eps = 'eps',
pdf = 'pdf',
html = 'html'
)
if(fn_dev!='html') {
req(pp1_final())
ggsave(con, plot = pp1_final(), device = fn_dev, width = input$down_plotw, height = input$down_ploth)
shut_device <- dev.list()[which(names(dev.list()) != "quartz_off_screen")]
if(length(shut_device)) dev.off(which = shut_device) # Make sure ggsave does not change graphic device
} else {
req(pp1_3d())
htmlwidgets::saveWidget(pp1_3d(), con)
}
}
)
output$download_bp_plot <- downloadHandler(
filename = function(format = input$bp_plotf) {
fn_ext<-switch(format,
png = '.png',
tiff = '.tiff',
eps = '.eps',
pdf = '.pdf'
)
paste('Plot-', Sys.Date(), fn_ext, sep='')
},
content = function(con, format = input$bp_plotf) {
req(input$bp_down_plotw, input$bp_down_ploth, format)
fn_dev<-switch(format,
png = 'png',
tiff = 'tiff',
eps = 'eps',
pdf = 'pdf'
)
if(fn_dev!='html') {
req(bp1())
ggsave(con, plot = bp1(), device = fn_dev, width = input$bp_down_plotw, height = input$bp_down_ploth)
shut_device <- dev.list()[which(names(dev.list()) != "quartz_off_screen")]
if(length(shut_device)) dev.off(which = shut_device) # Make sure ggsave does not change graphic device
}
}
)
output$download_data <- downloadHandler(
filename = function(format = input$selectCell_goal) {
fn_ext<-switch(format,
downcell = '.rds',
downmeta = '.csv'
)
paste('cedata-', ev$sample, format, "-", Sys.Date(), fn_ext, sep='')
},
content = function(con, format = input$selectCell_goal) {
req(format, length(ev$cells))
if(format == "downcell") {
cur_eset <- eset[,ev$cells]
tmp<-ev$meta %>% tibble::rownames_to_column("Cell")
rownames(tmp) <- tmp$Cell
pData(cur_eset) <- cbind(tmp[ev$cells,], pvals$proj[ev$cells, pvals$plot_col])
saveRDS(cur_eset, con, compress=F) # Not compress so that saving is faster
} else if(format == "downmeta") {
write.csv(cbind(ev$meta[ev$cells, ], pvals$proj[ev$cells, pvals$plot_col]), con)
}
}
)
# Cell Select
output$selectCell_panel <- renderUI({
req(length(ev$cells) > 0)
ns = session$ns
selected_samples <- ev$cells
ns <- session$ns
isolate({
if(!is.null(input$selectCell_meta_col)) {
meta_col_selected<-input$selectCell_meta_col
} else {
meta_col_selected<-NULL
}
# if(!is.null(input$selectCell_goal)) {
# goal_selected<-input$selectCell_goal
# } else {
# goal_selected<-NULL
# }
})
wellPanel(
class = "SidebarControl",
fluidRow(
column(12, selectInput(ns("selectCell_goal"), paste("Operation on", length(selected_samples), "cells"), choices = list(
"Zoom in to selected cells" = "zoom",
"Name selected cell subset" = "addmeta",
#"Compute new PCA/UMAP with selected cells" = "compdimr", # Don't allow in online version
"Download expression data (ExpressionSet format) of selected cells" = "downcell",
"Download meta data of selected cells" = "downmeta"
)))
),
conditionalPanel(
"input.selectCell_goal == 'addmeta'", ns=ns,
fluidRow(
column(6,
selectizeInput(ns("selectCell_meta_col"), "Meta class", choices = ev$meta_custom, options=list(create=T), selected = meta_col_selected),
shinyBS::bsTooltip(
ns("selectCell_meta_col"),
title = "Type name and press enter to add a new meta class, delete it use the button on the right",
placement="top",
options = list(container = "body")
)),
column(6,
tags$br(),actionButton(ns("MetaCol_delete"), "Delete class", class = "btn-danger btn_leftAlign")
)
),
fluidRow(
column(6, textInput(ns("selectCell_group_name"), "Name subset", placeholder="e.g., group 1")),
column(6, tags$br(),actionButton(ns("selectCell_add"), "Add group", class = "btn-info btn_leftAlign"))
)
),
conditionalPanel(
"input.selectCell_goal == 'zoom'", ns=ns,
fluidRow(
column(6,
textInput(ns("zoom_name"), "Sample name:", placeholder="optional")
),
column(6,
tags$br(),
actionButton(ns("zoom_in"), "Zoom in", class = "btn-primary btn_rightAlign")
)
),
tags$li("Provide a name to create a new visualization (sample)."),
tags$li("Zoom out by click topright reset button.")
),
conditionalPanel(
"input.selectCell_goal == 'downcell' || input.selectCell_goal == 'downmeta'", ns=ns,
fluidRow(
column(12,
downloadButton(ns("download_data"), "Download data", class = "btn-primary btn_rightAlign")
)
)
),
conditionalPanel(
"input.selectCell_goal == 'compdimr'", ns=ns,
fluidRow(
column(6,
selectInput(ns("compdimr_type"), "Compute:", choices = list("UMAP-2D" = "UMAP-2D", "UMAP-3D" = "UMAP-3D", "PCA" = "PCA"))
),
column(6,
textInput(ns("compdimr_name"), "Subset name:", placeholder="e.g., Late Neurons")
)
),
fluidRow(
column(6,
numericInput(ns("compdimr_mine"), "Umi >", value=1)
),
column(6,
numericInput(ns("compdimr_minc"), "in cells", value=10)
)
),
fluidRow(
column(6,
numericInput(ns("compdimr_disp"), "DispRatio", value=.5)
),
column(6,
numericInput(ns("compdimr_numpc"), "NumPC", value=50, min=2)
)
),
fluidRow(
column(6,
checkboxInput(ns("compdimr_batch"), tags$b("Correct batch"), F)
),
column(6, actionButton(ns("compdimr_run"), "Compute", class = "btn-info btn_rightAlign"))
)
)
)
})
observe({
req(input$plot2d_brush)
isolate({
area_selected<-input$plot2d_brush
plot_cols <- which(colnames(pvals$proj) %in% pvals$plot_col)
ev$cells <- rownames(pvals$proj)[which(pvals$proj[[plot_cols[1]]] >= area_selected$xmin & pvals$proj[[plot_cols[1]]] <= area_selected$xmax &
pvals$proj[[plot_cols[2]]] >= area_selected$ymin & pvals$proj[[plot_cols[2]]] <= area_selected$ymax)]
ev$cell_source <- "plot selection"
ev$area <- area_selected
})
})
observe({
req(input$proj_colorBy)
input$factor_compo
input$numeric_range
input$cell_expr_gene
if(input$proj_colorBy %in% ev$factor_cols) {
req(input$factor_compo)
ev$cells <- rownames(ev$meta)[ev$meta[[input$proj_colorBy]] %in% input$factor_compo]
} else if(input$proj_colorBy != "gene.expr") {
req(input$numeric_range)
vals <- ev$value
filter_std <- vals >= input$numeric_range[1] & vals <= input$numeric_range[2]
ev$cells <- rownames(ev$meta)[filter_std]
} else if(input$proj_colorBy == "gene.expr") {
if(is.null(ev$gene_values)) {
ev$cells <- NULL
return()
}
req(input$cell_expr_gene)
if(input$cell_expr_gene!="nulv") {
ev$cells <- names(which(rowSums(ev$gene_values > 0) == ncol(ev$gene_values)))
} else {
ev$cells <- NULL
}
}
ev$cell_source <- input$proj_colorBy
})
# Add by interactive mode
observeEvent(input$selectCell_add, {
if(nchar(input$selectCell_meta_col) < 1){
session$sendCustomMessage(type = "showalert", "Please specify a meta class or create one.")
return()
}
if(!is.na(as.numeric(input$selectCell_meta_col))) {
session$sendCustomMessage(type = "showalert", "Number name not allowed.")
return()
}
if(nchar(input$selectCell_group_name) < 1){
session$sendCustomMessage(type = "showalert", "Please specify a name for the cell subset.")
return()
}
if(length(ev$cells)) {
rval$mclass = input$selectCell_meta_col
rval$group_name = input$selectCell_group_name
rval$cells <- ev$cells
}
showNotification(paste("New meta class:", rval$group_name, "added"), type="message", duration=10)
updateSelectInput(session, "proj_colorBy", "Color by", selected = rval$mclass)
updateSelectInput(session, "selectCell_goal", selected = "addmeta")
updateSelectInput(session, "selectCell_meta_col", "Meta class", selected = rval$mclass)
})
observeEvent(input$MetaCol_delete, {
req(input$selectCell_meta_col, nchar(input$selectCell_meta_col) >= 1)
rval$mclass = input$selectCell_meta_col
rval$cells = NULL
rval$group_name = NULL
showNotification(paste("Meta class:", rval$mclass, "deleted"), type="message", duration=10)
})
callModule(pivot_help, "cellSelection", title = "Select and define cell groups:", size = "m", content = list(
tags$li("In interactive 2D plot, you can select cells by drag on the plot."),
tags$li("You can use the topright plotly menu to switch selection mode to lasso selection."),
tags$li("Once cells are selected, you can make a new meta class to add annotation to the selected cells."),
tags$li("First, in 'Meta class', type the new meta class name, press enter."),
tags$li("Then with the new class selected, enter a name for the selected cell group, press 'Add Group'."),
tags$li("You can now see the newly added meta class appear in 'Color By' menu."),
tags$li("You can download the newly annotated cds file, or just download the new metadata.")
))
callModule(pivot_help, "choose_sample_info", title = "Visualize cell subsets:", size = "m", content = list(
tags$li("'Sample's are cell subsets which enable global and zoom-in exploration of the data."),
tags$li("The tool contains sets of cell subsets that's generated by the developer and stored as part of the package."),
tags$li("Users can create their own cell subset by using the cell selection tool, and running a UMAP/PCA with selected cells."),
tags$li("You can delete user-created cell subsets with menu below:"),
tags$hr(),
uiOutput(session$ns("choose_sample_del_ui"))
))
output$choose_sample_del_ui <- renderUI({
ns <- session$ns
sample_names <- names(rval$list)
fluidRow(
column(8, selectInput(ns("del_sample"), "Choose cell subset", choices=sample_names)),
column(4, tags$br(),actionButton(ns("del_sample_btn"), "Delete", class = "btn-danger btn_leftAlign"))
)
})
observeEvent(input$del_sample_btn, {
req(input$del_sample)
ns <- session$ns
rval$list[[input$del_sample]] <- NULL
rval$ustats <- "del"
showNotification("Subset deleted.", type="message", duration=10)
})
output$g_limit_ui <- renderUI({
ns <- session$ns
input$plot_config_reset
req(input$gene_list)
if(length(input$gene_list) == 1) {
gvals <- ev$gene_values[,1]
glim <- round(quantile(gvals[gvals!=0], .975),1)
if(!is.na(glim) && glim < 2) glim = 2 # Minimal max-cut
dropdownButton2(inputId=ns("val_cutoff"),
width = "500px",
plotOutput(ns("gene_histogram_plot")),
fluidRow(
column(6, numericInput(ns("g_limit"),
label = "Expression Cutoff",
value = glim, min = 0)),
column(6, tags$p("Red line indicate max value for color scale. Default cutoff is set at 97.5th percentile."))
),
conditionalPanel("1==0", ns = ns, textInput(ns("g_limit_ds"), label = NULL, value = input$log_transform_gene)),
conditionalPanel("1==0", ns = ns, textInput(ns("g_limit_sample"), label = NULL, value = input$input_sample)),
conditionalPanel("1==0", ns = ns, textInput(ns("g_limit_gene"), label = NULL, value = input$gene_list)),
circle = T, label ="Expression histogram and color scale cutoff", tooltip=T, right = T,
icon = icon("chart-bar"), size = "xs", status="info", class = "btn_rightAlign")
} else {
return()
# tagList(
# conditionalPanel("1==0", ns = ns, textInput(ns("g_limit_sample"), label = NULL, value = input$input_sample)),
# conditionalPanel("1==0", ns = ns, numericInput(ns("g_limit"), label = NULL, value = NA))
# )
}
})
output$gene_histogram_plot <- renderPlot({
req(ev$gene_values)
gname <- colnames(ev$gene_values)
hist(ev$gene_values[,1], xlab=paste0(input$log_transform_gene, "expression"), main = paste0("Expression histogram of gene ", gname))
abline(v = input$g_limit, col=c("red"), lty=c(2), lwd=c(3))
})
output$v_limit_ui <- renderUI({
ns <- session$ns
input$plot_config_reset
req(!input$proj_colorBy %in% c(ev$factor_cols, 'gene.expr'))
v_limit <- round(quantile(ev$value, .975), 1)
dropdownButton2(inputId=ns("v_cutoff"),
width = "500px",
plotOutput(ns("value_histogram_plot")),
fluidRow(
column(6, numericInput(ns("v_limit"), label = "Cutoff", value = v_limit, min = 0)),
column(6, tags$p("Red line indicate max value for color scale. Default cutoff is set at 97.5th percentile."))
),
conditionalPanel("1==0", ns = ns, textInput(ns("proj_colorBy_vlim"), label = NULL, value = input$proj_colorBy)), # This is necessary!!! See explanation in the observer
conditionalPanel("1==0", ns = ns, textInput(ns("v_limit_ds"), label = NULL, value = input$log_transform_val)),
conditionalPanel("1==0", ns = ns, textInput(ns("v_limit_sample"), label = NULL, value = input$input_sample)),
circle = T, label ="Histogram and color scale cutoff", tooltip=T, right = T,
icon = icon("chart-bar"), size = "xs", status="info", class = "btn_rightAlign")
})
output$value_histogram_plot <- renderPlot({
req(pvals$plot_class == "numeric")
vals <- pvals$proj[[pvals$proj_colorBy]]
hist(vals, xlab=pvals$legend_title, main = paste0("Histogram of ", pvals$legend_title))
abline(v = input$v_limit, col=c("red"), lty=c(2), lwd=c(3))
})
observeEvent(input$zoom_in, {
req(ev$cells)
if(input$zoom_name == "") {
pvals$proj <- ev$proj[ev$cells,]
factor_breaks <- waiver()
if(pvals$proj_colorBy %in% ev$factor_cols) {
if(input$proj_colorBy %in% c("cell.type", "cell.subtype")) {
factor_breaks <- names(which(table(pvals$proj[[pvals$proj_colorBy]]) >= 10))
} else {
factor_breaks <- unique(pvals$proj[[pvals$proj_colorBy]])
}
factor_breaks <- factor_breaks[factor_breaks != "unannotated"]
}
pvals$factor_breaks <- factor_breaks
if(!is.null(ev$gene_values)) pvals$gene_values <- ev$gene_values[ev$cells,, drop=F]
return()
}
if(input$zoom_name %in% c("moreop", "lessop")) {
session$sendCustomMessage(type = "showalert", "Name not allowed.")
return()
}
if(!is.na(as.numeric(input$zoom_name))) {
session$sendCustomMessage(type = "showalert", "Number name not allowed.")
return()
}
if(input$zoom_name %in% c(names(sclist$clist), names(sclist$elist))) {
session$sendCustomMessage(type = "showalert", "Name already taken.")
return()
}
newvis <- new("Cello", idx = match(ev$cells, colnames(eset)))
newvis@proj[[input$proj_type]] <- pvals$proj[ev$cells, pvals$plot_col]
rval$list[[input$zoom_name]] <- newvis
rval$ustats <- "add"
updateSelectInput(session, "input_sample", selected = input$zoom_name)
})
# Don't put in online version
# observeEvent(input$compdimr_run, {
# req(ev$cells)
#
# error_I <- 0
# tryCatch({
# reticulate::import("umap")
# }, warning = function(w) {
# }, error = function(e) {
# error_I <<-1
# })
#
# if(error_I) {
# session$sendCustomMessage(type = "showalert", "UMAP not installed, please install umap to python environment first.")
# return()
# }
#
# if(is.null(input$compdimr_name) || input$compdimr_name == "") {
# session$sendCustomMessage(type = "showalert", "Enter a name first.")
# return()
# }
# if(input$compdimr_name %in% c("moreop", "lessop")) {
# session$sendCustomMessage(type = "showalert", "Name not allowed.")
# return()
# }
# if(!is.na(as.numeric(input$compdimr_name))) {
# session$sendCustomMessage(type = "showalert", "Number name not allowed.")
# return()
# }
# if(input$compdimr_name %in% c(names(sclist$clist), names(sclist$elist))) {
# session$sendCustomMessage(type = "showalert", "Name already taken.")
# return()
# }
# if(input$compdimr_batch) {
# resform <- "~as.factor(batch) + ~as.factor(batch) * raw.embryo.time"
# } else {
# resform <- NULL
# }
#
#
#
# withProgress(message = 'Processing...', {
# incProgress(1/2)
# set.seed(2018)
# #assign("ev1cells", ev$cells, env=.GlobalEnv)
# fd <- fData(eset[,ev$cells])[, c(1,2)]
# colnames(fd) <- c("id", "gene_short_name")
# cds_oidx <- newCellDataSet(cellData = exprs(eset[,ev$cells]), phenoData = new("AnnotatedDataFrame", data = pData(eset[,ev$cells])), featureData = new("AnnotatedDataFrame", data = fd))
# pData(cds_oidx) <- pData(eset[,ev$cells])
# cds_oidx <- filter_cds(cds=cds_oidx, min_detect=input$compdimr_mine, min_numc_expressed = input$compdimr_minc, min_disp_ratio=input$compdimr_disp)
# #assign("cds1", cds_oidx, env=.GlobalEnv)
# irlba_res <- compute_pca_cds(cds_oidx, num_dim =input$compdimr_numpc, scvis=NULL, use_order_gene = T, residualModelFormulaStr = resform, return_type="irlba")
# pca_proj <- as.data.frame(irlba_res$x)
# rownames(pca_proj) <- colnames(cds_oidx)
# newvis <- new("Cello", idx = match(ev$cells, colnames(eset)))
# newvis@proj[["PCA"]] <- pca_proj
# if(grepl("UMAP", input$compdimr_type)) {
# n_component = ifelse(grepl("2D", input$compdimr_type), 2, 3)
# newvis@proj[[paste0(input$compdimr_type, " [", input$compdimr_numpc, "PC]")]]<-compute_umap_pca(pca_proj, num_dim = input$compdimr_numpc, n_component=n_component)
# }
# rval$list[[input$compdimr_name]] <- newvis
# rval$ustats <- "add"
# })
# updateSelectInput(session, "input_sample", selected = input$compdimr_name)
# showNotification("Dimension reduction successfully computed.", type="message", duration=10)
# })
### Feature Plot ###
output$bp_gene_plot_ui <- renderUI({
req(input$bp_show_ploth)
ns <- session$ns
plotOutput(ns("bp_gene_plot"), height = paste0(500/5.5 *input$bp_show_ploth,"px")) %>% withSpinner()
})
#updateSelectizeInput(session, "bp_gene", "Search Gene:", choices = c("No gene selected", gene_tbl), selected = "No gene selected", server=T)
output$bp_sample_ui <- renderUI({
ns <- session$ns
sample_names <- names(ev$list)
isolate({
if(!is.null(input$input_sample)) {
selected <- input$input_sample
} else {
selected <- NULL
}
})
selectInput(ns("bp_sample"),"Choose cell subset", choices=sample_names, selected = selected)
})
# The follwoing observers control the syncing between explorer sample input and feature plot sample input
observe({
req(!is.null(input$input_sample))
updateSelectInput(session, "bp_sample", "Choose cell subset", selected = input$input_sample)
})
observe({
req(!is.null(input$bp_sample))
updateSelectInput(session, "input_sample", selected = input$bp_sample)
})
# The follwoing observers control the syncing between explorer gene input and feature plot gene input
observeEvent(input$gene_list, {
req(length(input$gene_list) == 1)
if(is.null(input$bp_gene) || input$gene_list != input$bp_gene) {
updateSelectInput(session, "bp_gene", selected = input$gene_list)
}
})
observeEvent(input$bp_gene, {
req(input$bp_gene, input$bp_gene != "No gene selected")
if(is.null(input$gene_list) || input$bp_gene != input$gene_list) {
updateSelectInput(session, "gene_list", selected = input$bp_gene)
}
})
output$bp_colorBy_ui <- renderUI({
ns <- session$ns
selectInput(ns("bp_colorBy"), "Color by:", choices = bp_colorBy_choices)
})
output$bp_include_ui <- renderUI({
ns <- session$ns
req(input$bp_colorBy)
input$bp_reset
factors <- names(which(table(ev$meta[[input$bp_colorBy]]) >= 10))
#factors <- factors[factors != "unannotated"]
tagList(
selectInput(ns("bp_include"), "Include:", choices = factors, selected=NULL, multiple = T, width = '100%'),
conditionalPanel("1==0", textInput(ns("bp_include_I"), NULL, value = ev$sample)) # indicator of rendering state of bp_include
)
})
output$bp_plot_configure_ui <- renderUI({
input$bp_plot_config_reset
ns <- session$ns
req(input$bp_colorBy)
if(input$bp_colorBy %in% pmeta_attr$meta_id && !is.null(pmeta_attr$dpal)) {
default_pal <- pmeta_attr$dpal[which(pmeta_attr$meta_id==input$bp_colorBy)]
} else {
default_pal <- NULL
}
if(input$bp_colorBy %in% ev$factor_cols){
if(grepl("time.bin", input$bp_colorBy)) {
sel <- selectInput(ns("bp_numericbin_pal"), "Palette", choices=numeric_bin_color_opt(), selected=default_pal)
} else {
sel <- selectInput(ns("bp_factor_pal"), "Palette", choices=factor_color_opt(), selected=default_pal)
}
} else {
return()
}
dropdownButton2(inputId=ns("bp_plot_configure"),
fluidRow(
column(6, numericInput(ns("bp_downsample"), "Downsample #", min=2, max = 10000, value=500)),
column(6, selectInput(ns("bp_plot_type"), "Plot Type", choices = list("Box plot" = "box", "Violin plot" = "violin", "Plot points" = "points")))
),
fluidRow(
column(6, numericInput(ns("bp_marker_size"), "Point Size", min = 0.1, value = 1, step = 0.1)),
column(6, numericInput(ns("bp_text_size"), "Text Size", min = 1, value = 15, step = 1))
),
fluidRow(
column(6, sel),
column(6, selectInput(ns("bp_legend_type"), "Legend", choices=c("Color Legend" = "l", "None" = "none"), selected = "none"))
),
fluidRow(
column(6, numericInput(ns("bp_xaxis_angle"), "X-axis Label Angle", value = 45, step=1)),
column(6, numericInput(ns("bp_show_ploth"), "Plot Height", min=1, value = 5, step=1))
),
circle = T, label ="Configure Plot", tooltip=T, right = T,
icon = icon("cog"), size = "xs", status="primary", class = "btn_rightAlign")
})
bp1 <- reactive({
req(input$bp_colorBy, length(input$bp_gene) == 1, input$bp_gene != "No gene selected", input$bp_gene %in% gene_tbl[[1]])
req(ev$sample == input$bp_sample, ev$sample == input$bp_include_I) # IMPORTANT, this controls the sync between sample choices in the explorer and the featurePlot, and prevent double rendering
cur_group <- ev$meta[[input$bp_colorBy]]
# Downsample cells from each cell type
if(length(input$bp_include) == 0) {
cur_factors <- names(which(table(ev$meta[[input$bp_colorBy]]) >= 10))
} else{
cur_factors <- input$bp_include
}
cur_idx <- unlist(lapply(cur_factors, function(g) {
cidx <- which(cur_group==g)
sample(cidx, min(length(cidx),input$bp_downsample))
}))
cur_meta <- ev$meta[cur_idx, input$bp_colorBy, drop=F]
if(grepl("time.bin", input$bp_colorBy)) {
req(input$bp_numericbin_pal)
factor_color <- get_numeric_bin_color(levels(ev$meta[[input$bp_colorBy]]), palette = input$bp_numericbin_pal)
names(factor_color) <- levels(ev$meta[[input$bp_colorBy]])
} else {
req(input$bp_factor_pal)
factor_color <- get_factor_color(unique(ev$meta[[input$bp_colorBy]]), pal=input$bp_factor_pal, maxCol = 9)
names(factor_color) <- unique(ev$meta[[input$bp_colorBy]])
}
factor_color[["unannotated"]] <- "lightgrey"
colorBy_name <- pmeta_attr$meta_name[which(pmeta_attr$meta_id == input$bp_colorBy)]
if(input$bp_log_transform_gene == "log2") {
df <- as.data.frame(as.matrix(eset@assayData$norm_exprs[input$bp_gene, ev$vis@idx[cur_idx]]))
} else {
df <- as.data.frame(as.matrix(exprs(eset)[input$bp_gene, ev$vis@idx[cur_idx]]))
}
feature_plot(df, input$bp_gene,
group.by = input$bp_colorBy,
meta = cur_meta,
pal = factor_color,
style = input$bp_plot_type, log_scale = F, legend.title = colorBy_name, legend.pos = "right",
text.size = input$bp_text_size, pointSize = input$bp_marker_size, legend = ifelse(input$bp_legend_type == "l", T, F),
breaks = unique(cur_group), axis.text.angle = input$bp_xaxis_angle,
order.by = ifelse(grepl("time",input$bp_colorBy, ignore.case = T), "none", "mean"),
ylab.label = ifelse(input$bp_log_transform_gene == "log2", "Expression (log2 normalized)", "Expression (UMI count)")
)
})
output$bp_gene_plot <- renderPlot({
req(bp1())
bp1()
})
############### Cell Type Marker Table #############
#################### Cell type marker table #################
#proxy = dataTableProxy('ct_marker_tbl')
shinyInput <- function(FUN, id, ...) {
as.character(FUN(id, ...))
}
output$ct_marker_tbl <- DT::renderDataTable({
ns <- session$ns
ct_show <- cell_type_markers
# ct_show$Marker.genes <- lapply(1:nrow(ct_show), function(i) {
# x <- as.character(ct_show$Marker.genes[i])
# genes<-trimws(unlist(strsplit(x, ",")), which = "both")
# #assign("ns1", ns, env=.GlobalEnv)
# btns <- paste(
# sapply(genes, function(g){
# shinyInput(actionLink, row = i, id = paste0(g,'_', i), label = g, icon = NULL, onclick = paste0("Shiny.onInputChange(\"", ns("ct_gene"), "\", this.id)"))
# }),
# collapse = ", ")
# return(btns)
# })
# #assign("ns1", session$ns, env=.GlobalEnv)
# ct_show$UMAP <- lapply(1:nrow(ct_show), function(i) {
# x <- as.character(ct_show$UMAP[i])
# shinyInput(actionLink, row = i, id = paste0(x,'_', i), label = x, icon = NULL, onclick = paste0("Shiny.onInputChange(\"", ns("ct_umap"), "\", this.id)"))
# })
names(ct_show) <- c("Cell Type", "UMAP", "Markers", "Notes")
DT::datatable(ct_show, selection = 'none',
rownames=F,
editable = F,
options = list(
searching=T,
scrollX = TRUE,
columnDefs = list(list(width = '20%', targets = list(0,1,2)))
)
) %>%
DT::formatStyle(columns = c(1),fontWeight = 'bold')
})
observeEvent(input$ct_gene, {
gene_row <- unlist(strsplit(as.character(input$ct_gene), "_", fixed = T))
if(length(gene_row) != 2) {
return()
}
gene <- gene_row[1]
row <- as.numeric(gene_row[2])
umap_id <- cell_type_markers$UMAP[row]
updateTabsetPanel(session, "ct_tab", selected = "eui")
updateSelectInput(session, "input_sample", selected = umap_id)
updateSelectizeInput(session, "proj_colorBy", selected = "gene.expr")
updateSelectInput(session, "gene_list", selected = gene)
})
observeEvent(input$ct_umap, {
umap_row <- unlist(strsplit(as.character(input$ct_umap), "_", fixed = T))
if(length(umap_row) != 2) {
return()
}
row <- as.numeric(umap_row[2])
umap_id <- cell_type_markers$UMAP[row]
updateTabsetPanel(session, "ct_tab", selected = "eui")
updateSelectInput(session, "input_sample", selected = umap_id)
})
output$download_ct_marker <- downloadHandler(
filename = function() {
'cell_type_markers.xlsx'
},
content = function(con) {
write.xlsx(cell_type_markers, file=con)
}
)
###### Lineage marker imaging graph ######
# Image gene expression graph plot
output$image_graph_plot_ui <- renderUI({
req(input$image_ploth)
ns <- session$ns
plotOutput(ns("image_graph_plot"), height = paste0(500/5.5 *input$image_ploth,"px")) %>% withSpinner()
})
output$image_graph_plot <- renderPlot({
req(input$image_colorBy, input$image_pal, input$image_scale)
t_cut <- 108
plotg <- input$image_colorBy
if(input$image_scale == "log10") {
g <- g_all
} else {
g <- g_agg
}
g<-g %>% activate("nodes") %>%
mutate(text.size = ifelse(time > t_cut, 0, 10/log10(time+1))) %>%
mutate(name = ifelse(time > t_cut, "", name)) %>%
filter(!(time > 200 & is.na(!!as.name(plotg))))
range(as.data.frame(g)$text.size)
plotGraph(g, color.by=plotg, pal=input$image_pal, label="name", type = "numeric",border.size=.3, legend.title = names(image_colorBy_choices)[which(image_colorBy_choices == input$image_colorBy)]) +
theme(
axis.ticks.x=element_blank(),
axis.text.x=element_blank(),
axis.ticks.y=element_blank(),
axis.text.y=element_blank(),
legend.margin=margin(15,0,0,0),
legend.box.margin=margin(-10,-10,-10,-10),
plot.margin = unit(c(.3,.5,.3,.3), "cm"))
})
output$g_meta_table <- DT::renderDataTable({
req(input$image_colorBy)
curg<- names(image_colorBy_choices)[which(image_colorBy_choices == input$image_colorBy)]
req(curg %in% names(g_meta_list))
DT::datatable(g_meta_list[[curg]], selection = 'none',
rownames=F,
options = list(
searching=F,
scrollX = TRUE,
paging = F
)
)
})
### Lineage marker table ###
output$lin_marker_tbl <- DT::renderDataTable({
ns <- session$ns
lin_show <- lineage_markers
# lin_show$Markers <- lapply(1:nrow(lin_show), function(i) {
# x <- as.character(lin_show$Markers[i])
# if(is.na(x) || x == "") return("")
# genes<-trimws(unlist(strsplit(x, ",")), which = "both")
# btns <- paste(
# sapply(genes, function(g){
# if(!g %in% gene_tbl[[1]]) return(g)
# shinyInput(actionLink, row = i, id = paste0(g,'_', i), label = g, icon = NULL, onclick = paste0("Shiny.onInputChange(\"", ns("lin_gene"), "\", this.id)"))
# }),
# collapse = ", ")
# return(btns)
# })
# lin_show$UMAP <- lapply(1:nrow(lin_show), function(i) {
# if(is.na(lin_show$UMAP[i]) || lin_show$UMAP[i] == "") return(NA)
# x <- as.character(lin_show$UMAP[i])
# shinyInput(actionLink, row = i, id = paste0(x,'_', i), label = x, icon = NULL, onclick = paste0("Shiny.onInputChange(\"", ns("lin_umap"), "\", this.id)"))
# })
DT::datatable(lin_show, selection = 'none',
rownames=F,
editable = F,
options = list(
searching=T,
scrollX = TRUE,
columnDefs = list(list(width = '20%', targets = list(0,1,2)))
)
) %>% DT::formatStyle(columns = c(1),fontWeight = 'bold')
})
observeEvent(input$lin_gene, {
gene_row <- unlist(strsplit(as.character(input$lin_gene), "_", fixed = T))
if(length(gene_row) != 2) {
return()
}
gene <- gene_row[1]
row <- as.numeric(gene_row[2])
umap_id <- lineage_markers$UMAP[row]
updateTabsetPanel(session, "lin_tab", selected = "eui")
updateSelectInput(session, "input_sample", selected = umap_id)
updateSelectizeInput(session, "proj_colorBy", selected = "gene.expr")
updateSelectInput(session, "gene_list", selected = gene)
})
observeEvent(input$lin_umap, {
umap_row <- unlist(strsplit(as.character(input$lin_umap), "_", fixed = T))
row <- as.numeric(umap_row[length(umap_row)])
umap_id <- lineage_markers$UMAP[row]
updateTabsetPanel(session, "lin_tab", selected = "eui")
updateSelectInput(session, "input_sample", selected = umap_id)
})
output$download_lin_marker <- downloadHandler(
filename = function() {
'lineage_markers.xlsx'
},
content = function(con) {
write.xlsx(lineage_markers, file=con)
}
)
# Summary gene expression table
sm <- reactiveValues(gene = NULL, tbl = NULL)
output$sm_option <- renderUI({
input$sm_reset
if(tabset == "ct") {
cb_choice <- data.table::data.table(cell.bin = levels(ct_tbl$cell.bin))
} else {
cb_choice <- data.table::data.table(lineage = levels(lin_tbl$lineage))
}
ns <- session$ns
fluidRow(
column(6, selectizeInput(ns("sm_gene"), "Search gene:", choices = gene_tbl, multiple = T, options = list(placeholder = 'No gene selected'), selected = "pha-4")),
column(6, pickerInput(ns("sm_cellbin"),"Search cell:", choices=cb_choice, options = pickerOptions(actionsBox = TRUE,liveSearch = TRUE, virtualScroll = T, width = '100%', dropdownAlignRight = TRUE, style = "btn-picker", noneSelectedText = "No cell selected"),multiple = T))
#column(6, selectizeInput(ns("sm_cellbin"), "Search cell:", choices = cb_choice, multiple = T))
)
})
observe({
if(tabset == "ct") {
cur_tbl <- ct_tbl
sm$col <- "cell.bin"
} else {
cur_tbl <- lin_tbl
sm$col <- "lineage"
}
if(is.null(input$sm_cellbin) || length(input$sm_cellbin) == 0) {
cbins <- levels(cur_tbl[[sm$col]])
} else {
cbins <- input$sm_cellbin
}
if(length(input$sm_gene)) {
tbl <- cur_tbl %>% dplyr::filter(gene %in% input$sm_gene)
sm$tbl <- tbl[tbl[[sm$col]] %in% cbins, ]
sm$gene <- input$sm_gene
} else {
sm$tbl <- cur_tbl[cur_tbl[[sm$col]] %in% cbins,]
sm$gene <- gene_tbl[[1]]
}
})
output$sm_tbl <- DT::renderDataTable({
req(sm$gene)
DT::datatable(sm$tbl, selection = 'none',
rownames=F,
options = list(
searching=F,
scrollX = TRUE
#columnDefs = list(list(width = '20%', targets = list(0,1,2)))
)
)
#%>%DT::formatStyle(columns = c(1),fontWeight = 'bold')
})
output$download_sm_tbl <- downloadHandler(
filename = function() {
'summarized_expression.xlsx'
},
content = function(con) {
req(sm$tbl)
write.xlsx(sm$tbl, file=con)
}
)
output$sm_hmap_ui <- renderUI({
req(sm$gene)
if(length(sm$gene) > 500) {
return(tags$p("Do not support more than 500 genes."))
}
if(length(sm$gene) < 2 && length(unique(sm$tbl[[sm$col]])) < 2) {
return()
#return(tags$p("Minimal number of cell/gene is 2."))
}
ns <- session$ns
tagList(
fluidRow(
column(12,
circleButton(ns("hmap_config_reset"), icon = icon("undo"), size = "xs", status = "danger btn_rightAlign"),
shinyBS::bsTooltip(
ns("hmap_config_reset"),
title = "Reset heatmap configuration",
options = list(container = "body")
),
uiOutput(ns("hmap_configure_ui"))
)
),
uiOutput(ns("sm_hmap_plot"))
)
})
output$hmap_configure_ui <- renderUI({
ns <- session$ns
input$hmap_config_reset
dropdownButton2(inputId=ns("hmap_configure"),
selectInput(ns("hmap_color_pal"), "Heatmap color", choices=heatmap_palettes),
numericInput(ns("hmap_ploth"), "Height (resize window for width)", min=3, value = 5, step=1),
checkboxInput(ns("hmap_cluster_row"), "Cluster gene", T),
checkboxInput(ns("hmap_cluster_col"), "Cluster cell", T),
circle = T, label ="Configure Heatmap", tooltip=T, right = T,
icon = icon("cog"), size = "xs", status="primary", class = "btn_rightAlign")
})
output$sm_hmap_plot <- renderUI({
req(input$hmap_ploth)
ns <- session$ns
plotOutput(ns("sm_hmap"), height = paste0(100 *input$hmap_ploth,"px"))
})
output$sm_hmap <- renderPlot({
req(sm$gene)
cluster_rows <- ifelse(length(sm$gene) == 1, F, input$hmap_cluster_row)
cluster_cols <- ifelse(length(unique(sm$tbl[[sm$col]])) == 1, F, input$hmap_cluster_col)
expr_tbl<-sm$tbl[, c("gene",sm$col, "adjusted.tpm.estimate"), drop=F]
colnames(expr_tbl) <- c("gene","cell","expression")
expr_tbl<-reshape2::dcast(expr_tbl, gene~cell, value.var = "expression")
rownames(expr_tbl) <- expr_tbl$gene
expr_tbl$gene <- NULL
pheatmap(expr_tbl, cluster_rows = cluster_rows, cluster_cols = cluster_cols, color = get_numeric_color(input$hmap_color_pal))
})
output$sm_radio_ui <- renderUI({
req(sm$gene)
if(length(sm$gene) > 1) {
return(tags$p("Only one gene can be plotted at a time."))
}
ns <- session$ns
tagList(
fluidRow(
column(12,
circleButton(ns("radio_config_reset"), icon = icon("undo"), size = "xs", status = "danger btn_rightAlign"),
shinyBS::bsTooltip(
ns("radio_config_reset"),
title = "Reset plot configuration",
options = list(container = "body")
),
uiOutput(ns("radio_configure_ui"))
)
),
uiOutput(ns("sm_radio_plot"))
)
})
output$radio_configure_ui <- renderUI({
ns <- session$ns
input$radio_config_reset
dropdownButton2(inputId=ns("radio_configure"),
selectInput(ns("radio_color_pal"), "Heatmap Color", choices=heatmap_palettes),
numericInput(ns("radio_ploth"), "Height (resize window for width)", min=3, value = 9, step=1),
circle = T, label ="Configure radio plot", tooltip=T, right = T,
icon = icon("cog"), size = "xs", status="primary", class = "btn_rightAlign")
})
output$sm_radio_plot <- renderUI({
req(input$radio_ploth)
ns <- session$ns
plotOutput(ns("sm_radio"), height = paste0(100 *input$radio_ploth,"px"))
})
output$sm_radio <- renderPlot({
req(sm$gene, length(sm$gene == 1))
expr_tbl<-sm$tbl[, c("gene",sm$col, "adjusted.tpm.estimate"), drop=F]
colnames(expr_tbl) <- c("gene","cell","expression")
#assign("expr_tbl", expr_tbl, env=.GlobalEnv)
match_expr<-sapply(elin_match, function(x){
e_val<-expr_tbl$expression[which(expr_tbl$cell == x)]
if(length(e_val)) {
return(e_val)
} else {
return(NA)
}
})
g <- g_all %>% activate("nodes") %>%
mutate(scExprTPM = match_expr)
plot_col <- "scExprTPM"
t_cut <- 108
g<-g %>% activate("nodes") %>%
mutate(text.size = ifelse(time > t_cut, 0, 10/log10(time+1))) %>%
mutate(name = ifelse(time > t_cut, "", name)) %>%
filter(!(time > 200 & is.na(!!as.name(plot_col))))
range(as.data.frame(g)$text.size)
plotGraph(g, color.by=plot_col, pal=input$radio_color_pal, label="name", type = "numeric",border.size=.3, legend.title = sm$gene) +
theme(
axis.ticks.x=element_blank(),
axis.text.x=element_blank(),
axis.ticks.y=element_blank(),
axis.text.y=element_blank(),
legend.margin=margin(15,0,0,0),
legend.box.margin=margin(-10,-10,-10,-10),
plot.margin = unit(c(.3,.5,.3,.3), "cm"))
})
rval <- reactiveValues(mclass = NULL, cells=NULL, group_name=NULL, ulist = list())
return(rval)
}
qinzhu/VisCello.celegans documentation built on Oct. 23, 2024, 2:03 a.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.
Defines functions explorer_server explorer_ui
#' @export
explorer_ui <- function(id) {
ns <- NS(id)
uiOutput(ns("eui")) %>% withSpinner(type = 3, size = 3, color.background = "white")
}
#' @export
explorer_server <- function(input, output, session, sclist, useid, cmeta = NULL, showcols_basic = NULL, showcols_advanced = NULL, tabset = "ct"){
ev <- reactiveValues(list = NULL, sample=NULL, vis=NULL, cells = NULL, cell_source = NULL)
# Reactive variable storing all basic plot parameters
pvals <- reactiveValues()
output$eui <- renderUI({
ns <- session$ns
eui <- fluidRow(
column(4,
wellPanel(
class = "SidebarControl",
uiOutput(ns("input_sample_ui")),
uiOutput(ns("proj_type_ui")),
conditionalPanel("input.proj_type == 'PCA-2D'",
ns = ns,
fluidRow(
column(6, selectInput(ns("pca2d_v1"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC1")),
column(6, selectInput(ns("pca2d_v2"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC2"))
)
),
conditionalPanel("input.proj_type == 'PCA-3D'",
ns = ns,
fluidRow(
column(4, selectInput(ns("pca3d_v1"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC1")),
column(4, selectInput(ns("pca3d_v2"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC2")),
column(4, selectInput(ns("pca3d_v3"), NULL, choices = paste0("PC",1:max_pc_show), selected = "PC3"))
)
),
uiOutput(ns("proj_colorBy_ui")),
selectizeInput(ns("gene_list"), "Search gene:", choices = gene_tbl, multiple = T),
uiOutput(ns("plot_scalecolor_ui")),
uiOutput(ns("data_highlight"))
),
uiOutput(ns("selectCell_panel"))
),
column(8,
fluidRow(
column(8,
uiOutput(ns("lineage_tree_view")),
uiOutput(ns("left_tree_root_ui")),
uiOutput(ns("right_tree_root_ui")),
uiOutput(ns("top_tree_root_ui"))
),
column(4,
circleButton(ns("plot_config_reset"), icon = icon("undo"), size = "xs", status = "danger btn_rightAlign"),
shinyBS::bsTooltip(
ns("plot_config_reset"),
title = "Reset plot configuration",
options = list(container = "body")
),
uiOutput(ns("plot_configure_ui")),
dropdownButton2(inputId=ns("plot_download"),
fluidRow(
column(6, numericInput(ns("down_ploth"), "Height", min=1, value = 7, step=1)),
column(6, numericInput(ns("down_plotw"), "Width", min=1, value = 7, step=1))
),
fluidRow(
column(6, uiOutput(ns("explore_plotf_ui"))),
column(6, tags$br(), downloadButton(ns("download_explore_plot"), "Download", class = "btn-primary", style="width: 115px"))
),
circle = T, label ="Download Plot", tooltip=T, right = T,
icon = icon("download"), size = "xs", status="success", class = "btn_rightAlign"),
uiOutput(ns("g_limit_ui")),
uiOutput(ns("v_limit_ui")),
uiOutput(ns("tree_configure_ui"))
)
),
uiOutput(ns("plot_ui")) %>% withSpinner()
)
)
fui <- tagList(
wellPanel(
fluidRow(
column(3, uiOutput(ns("bp_sample_ui"))),
column(3, selectizeInput(ns("bp_gene"), "Search gene:", choices = c("No gene selected"="No gene selected", gene_tbl))),
column(3, uiOutput(ns("bp_colorBy_ui"))),
column(3, selectInput(ns("bp_log_transform_gene"), "Data scale", choices=list("Log2 normalized count"="log2", "Molecule (UMI) count" = "raw")))
),
uiOutput(ns("bp_include_ui")),
fluidRow(
column(9, tags$p("Hint: Select a gene to get its summarized expression across cell types/lineages.")),
column(3, actionLink(ns("bp_reset"), "Clear selected", class = "btn_rightAlign"))
)
),
fluidRow(
column(6),
column(6,
circleButton(ns("bp_plot_config_reset"), icon = icon("undo"), size = "xs", status = "danger btn_rightAlign"),
shinyBS::bsTooltip(
ns("bp_plot_config_reset"),
title = "Reset plot configuration",
options = list(container = "body")
),
uiOutput(ns("bp_plot_configure_ui")),
dropdownButton2(inputId=ns("bp_plot_download"),
fluidRow(
column(6, numericInput(ns("bp_down_ploth"), "Height", min=1, value = 5, step=1)),
column(6, numericInput(ns("bp_down_plotw"), "Width", min=1, value = 7, step=1))
),
fluidRow(
column(6, selectInput(ns("bp_plotf"), "Format", choices = list("png","pdf","eps","tiff"))),
column(6, tags$br(), downloadButton(ns("download_bp_plot"), "Download", class = "btn-primary", style="width: 115px"))
),
circle = T, label ="Download Plot", tooltip=T, right = T,
icon = icon("download"), size = "xs", status="success", class = "btn_rightAlign")
)
),
uiOutput(ns("bp_gene_plot_ui"))
)
if(tabset == "ct") {
hmap_ui <- uiOutput(ns("sm_hmap_ui"))
} else {
hmap_ui <- tagList(
tags$b("Expression "),
tags$select(id=ns("sm_type"),
class = "customDrop",
tags$option(value = "hmap", "Heatmap", selected=T),
tags$option(value = "radio", "Radio graph")
),
conditionalPanel(
"input.sm_type == 'hmap'",
ns = ns,
uiOutput(ns("sm_hmap_ui"))
),
conditionalPanel(
"input.sm_type == 'radio'",
ns = ns,
uiOutput(ns("sm_radio_ui"))
)
)
}
sui <- tagList(
wellPanel(
uiOutput(ns("sm_option")),
fluidRow(
column(9, tags$p("Hint: Select one or more genes to visualize its summarized expression. To view expression of all genes for a specific cell, select the cell and deselect all genes.")),
column(3, actionLink(ns("sm_reset"), "Clear selected", class = "btn_rightAlign"))
)
),
DT::dataTableOutput(ns("sm_tbl")) %>% withSpinner(),
downloadButton(ns("download_sm_tbl"), "Download table", class = "btn_rightAlign")
#hmap_ui
)
cui <- tagList(
DT::dataTableOutput(ns("ct_marker_tbl")),
downloadButton(ns("download_ct_marker"), "Download table", class = "btn_rightAlign")
)
# Marker imaging graph ui
mui <- fluidRow(
column(4,
wellPanel(
selectInput(ns("image_colorBy"), "Color by", choices = image_colorBy_choices),
fluidRow(
column(6, selectInput(ns("image_scale"), "Scale", choices=c("Linear" = "linear", "Log10"="log10"), selected = "linear")),
column(6, selectInput(ns("image_pal"), "Palette", choices=image_palettes))
),
numericInput(ns("image_ploth"), "Plot height", min=1, value = 7, step=1),
tags$br(),
tags$div(tags$strong("EPiC Movies: "), tags$a("http://epic.gs.washington.edu/", href="http://epic.gs.washington.edu/")),
tags$div(tags$strong("EPiC2 Movies: "), tags$a("http://epic.gs.washington.edu/Epic2/", href="http://epic.gs.washington.edu/Epic2/"))
),
fluidRow(
column(12, tags$p("Expression level summarized from following sources:"))
),
DT::dataTableOutput(ns("g_meta_table"))
),
column(8,
uiOutput(ns("image_graph_plot_ui")),
tags$br(),
tags$b("Lineage tree colored by expression of gene X as determined by imaging of a fluorescent reporter.")
)
)
lui <- tagList(
DT::dataTableOutput(ns("lin_marker_tbl")),
downloadButton(ns("download_lin_marker"), "Download table", class = "btn_rightAlign")
)
if(tabset == "lin") {
tabsetPanel(
id = ns("lin_tab"),
tabPanel(
value = "eui",
tags$b("Explorer"),
eui
),
tabPanel(
value = "fui",
tags$b("Expression by Cell Type/Lineage"),
fui
),
tabPanel(
value = "sui",
tags$b("Summarized Expression"),
sui
),
tabPanel(
value = "lui",
tags$b("Lineage Markers"),
tags$br(),
tags$b("Table below shows markers used for annotation. NOT new markers identified from the single cell data."),
lui
),
tabPanel(
value = "mui",
tags$b("Marker Imaging"),
tags$br(),
mui
)
)
} else if(tabset == "ct") {
tabsetPanel(
id = ns("ct_tab"),
tabPanel(
value = "eui",
tags$b("Explorer"),
eui
),
tabPanel(
value = "fui",
tags$b("Expression by Cell Type/Lineage"),
fui
),
tabPanel(
value = "sui",
tags$b("Summarized Expression"),
sui
),
tabPanel(
value = "cui",
tags$b("Cell Type Markers"),
tags$br(),
tags$b("Table below shows markers used for annotation. NOT new markers identified from the single cell data."),
cui
)
)
} else {
return()
}
})
output$input_sample_ui <- renderUI({
ns <- session$ns
sample_names <- names(ev$list)
if(tabset == "lin") sample_names <- c(elin_sets_basic, names(ev$list)[!names(ev$list) %in% names(elist)], "More options..." = "moreop")
selectInput(ns("input_sample"), tags$div("Choose cell subset:", pivot_help_UI(ns("choose_sample_info"), title = NULL, label = NULL, icn="question-circle", type = "link", tooltip = F, style = "padding-left:10px;")), choices=sample_names)
})
observeEvent(input$input_sample, {
if(tabset == "lin") {
sample_names <- names(ev$list)
if(input$input_sample == "lessop") {
sample_names <- c(elin_sets_basic, names(ev$list)[!names(ev$list) %in% names(elist)], "More options..." = "moreop")
updateSelectInput(session, "input_sample", choices = sample_names)
} else if(input$input_sample == "moreop") {
sample_names <- c(names(ev$list), "Less options..." = "lessop")
updateSelectInput(session, "input_sample", choices = sample_names)
}
}
})
output$proj_type_ui <- renderUI({
ns <- session$ns
req(ev$vis)
options <- names(ev$vis@proj)
if("PCA" %in% options) options <- c(options[!options == "PCA"], "PCA-2D", "PCA-3D")
tagList(
selectInput(ns("proj_type"), "Choose projection:", choices=options),
conditionalPanel("1==0", textInput(ns("proj_type_I"), NULL, value = ev$sample))
)
})
output$proj_colorBy_ui <- renderUI({
ns = session$ns
selectInput(ns("proj_colorBy"), "Color by", choices = c(showcols_basic, ev$meta_custom, "More options..."="moreop"))
})
observeEvent(input$proj_colorBy, {
if(input$proj_colorBy == "lessop") {
updateSelectInput(session, "proj_colorBy", "Color By", choices = c(showcols_basic, ev$meta_custom, "More options..."="moreop"))
} else if(input$proj_colorBy == "moreop") {
updateSelectInput(session, "proj_colorBy", "Color By", choices = c(showcols_advanced, ev$meta_custom, "Less options..."="lessop"))
} else if(input$proj_colorBy != "gene.expr") {
if(!is.null(input$gene_list)) {
updateSelectInput(session, "gene_list", selected = "")
}
}
})
output$plot_scalecolor_ui <- renderUI({
ns = session$ns
req(input$proj_colorBy, !input$proj_colorBy %in% c("moreop", "lessop"))
if(input$proj_colorBy == 'gene.expr') {
selectInput(ns("log_transform_gene"), "Data scale", choices=list("Log2 normalized count"="log2", "Molecule (UMI) count" = "raw"))
} else if(!input$proj_colorBy %in% ev$factor_cols){
if(input$proj_colorBy %in% pmeta_attr$meta_id && !is.null(pmeta_attr$dscale)) {
default_scale <- pmeta_attr$dscale[which(pmeta_attr$meta_id==input$proj_colorBy)]
} else {
default_scale <- NULL
}
selectInput(ns("log_transform_val"), "Data scale", choices=list("Log10"="log10", "Identity" = "identity"), selected = default_scale)
} else {
return()
}
})
output$lineage_tree_view <- renderUI({
ns <- session$ns
req(input$proj_colorBy)
#if(input$proj_colorBy %in% c("lineage", "gene.expr", "raw.embryo.time")) {
if(input$proj_colorBy %in% c("lineage", "gene.expr")) {
div(checkboxGroupButtons(
inputId = ns("tree_view"), label = NULL,
size = "xs", width = "100px",
choices = c("Lineage Tree"),
justified = TRUE, status = "info",
checkIcon = list(yes = icon("record", lib = "glyphicon"), no = icon("ban-circle", lib = "glyphicon"))
),style = "float:left;margin-top:5px;")
} else {
ev$tree_view <- F
return()
}
})
observe({
if(!is.null(input$tree_view)){
ev$tree_view <- T
} else {
ev$tree_view <- F
}
})
output$tree_configure_ui <- renderUI({
ns <- session$ns
req(ev$tree_view)
dropdownButton2(inputId=ns("tree_configure"),
fluidRow(
column(6, numericInput(ns("tree_time_cut"), "Birth time cut", min = 10, value = 300, step = 10)),
column(6, selectInput(ns("tree_label_style"), "Label style", choices = c("No label" = "none", "Text" = "text", "Label" = "label")))
),
fluidRow(
column(6, numericInput(ns("tree_label_cut"), "Label time cut", min = 10, value = 80, step = 10)),
column(6, numericInput(ns("tree_label_size"), "Label size", min = 1, value = 3, step = 1))
),
fluidRow(
column(6, numericInput(ns("tree_edge_size"), "Edge size", min = 0.1, value = 1, step = 0.1)),
column(6, numericInput(ns("tree_tip_size"), "Tip size", min = 0, value = 0, step = 1))
),
fluidRow(
column(6, checkboxInput(ns("tree_filter_na"), tags$b("Filter unmapped leaves"), value = F)),
column(6, numericInput(ns("tree_height"), "Tree height (scale)", min=1/10, max = 1, value = 1/4, step=.1))
),
conditionalPanel("1==0", textInput(ns("tree_colorBy_fake"), NULL, value = input$proj_colorBy)),
circle = T, label ="Configure Tree", tooltip=T, right = T,
icon = icon("grain", lib = "glyphicon"), size = "xs", status="info", class = "btn_rightAlign")
})
output$left_tree_root_ui <- renderUI({
req(ev$tree_view)
ns <- session$ns
choices <- as.list(c("No left tree", avail_nodes[1:101]))
names(choices) <- choices
tagList(
tags$p("L:", style="display:inline-block;float:left;margin-top:7px;margin-left:5px;"),
tags$select(id=ns("left_tree_root"),
class = "customDrop",
style = "display:inline-block;float:left;width:80px;margin-top:7px;margin-left:3px;",
shiny:::selectOptions(choices,selected = "ABa"))
)
})
output$right_tree_root_ui <- renderUI({
req(ev$tree_view)
ns <- session$ns
choices <- as.list(c("No right tree", avail_nodes[1:101]))
names(choices) <- choices
tagList(
tags$p("R:", style="display:inline-block;float:left;margin-top:7px;margin-left:5px;"),
tags$select(id=ns("right_tree_root"),
class = "customDrop",
style = "display:inline-block;float:left;width:80px;margin-top:7px;margin-left:3px;",
shiny:::selectOptions(choices,selected = "ABp"))
)
})
output$top_tree_root_ui <- renderUI({
req(ev$tree_view)
ns <- session$ns
choices <- as.list(c("No top tree", avail_nodes[1:101]))
names(choices) <- choices
tagList(
tags$p("T:", style="display:inline-block;float:left;margin-top:7px;margin-left:5px;"),
tags$select(id=ns("top_tree_root"),
class = "customDrop",
style = "display:inline-block;float:left;width:80px;margin-top:7px;margin-left:3px;",
shiny:::selectOptions(choices,selected = "P1"))
)
})
output$plot_configure_ui <- renderUI({
input$plot_config_reset
ns <- session$ns
dropdownButton2(inputId=ns("plot_configure"),
fluidRow(
column(6, numericInput(ns("marker_size"), "Point size", min = 0.1, value = 1, step = 0.1)),
column(6, numericInput(ns("text_size"), "Text size", min = 1, value = 3, step = 1))
),
fluidRow(
column(6, selectInput(ns("color_pal"), "Palette", choices=factor_color_opt())),
column(6, selectInput(ns("legend_type"), "Legend", choices=c("Color legend" = "l", "Onplot label" = "ol", "Onplot text" = "ot", "Legend + Label" = "lol", "Legend + Text" = "lot", "None" = "none"), selected = "ot"))
),
fluidRow(
column(6, numericInput(ns("show_ploth"), "Height (resize window for width)", min=1, value = 7, step=1)),
column(6, numericInput(ns("alpha_level"), "Transparency (for cells not selected)", min = 0, max = 1, value = 0.01, step = 0.01))
),
circle = T, label ="Configure Plot", tooltip=T, right = T,
icon = icon("cog"), size = "xs", status="primary", class = "btn_rightAlign")
})
observeEvent(input$proj_colorBy, {
req(!input$proj_colorBy %in% c("moreop", "lessop"))
req(ev$factor_cols)
if(input$proj_colorBy %in% pmeta_attr$meta_id && !is.null(pmeta_attr$dpal)) {
default_pal <- pmeta_attr$dpal[which(pmeta_attr$meta_id==input$proj_colorBy)]
} else {
default_pal <- NULL
}
if(input$proj_colorBy == 'gene.expr') {
updateSelectInput(session, "color_pal", "Palette", choices=numeric_palettes, selected=default_pal)
} else if(input$proj_colorBy %in% ev$factor_cols){
if(grepl("time.bin", input$proj_colorBy)) {
updateSelectInput(session, "color_pal", "Palette", choices=numeric_bin_color_opt(), selected=default_pal)
} else {
updateSelectInput(session, "color_pal", "Palette", choices=factor_color_opt(), selected=default_pal)
}
} else {
updateSelectInput(session, "color_pal", choices=numeric_palettes, selected=default_pal)
}
})
observe({
req(ev$cells)
isolate({
updateSelectInput(session, "selectCell_goal", selected=lapply(reactiveValuesToList(input), unclass)$selectCell_goal)
})
})
#updateSelectizeInput(session, "gene_list", "Search Gene:", choices = gene_tbl, selected = NULL, server=T)
output$plot_ui <- renderUI({
ns <- session$ns
req(input$proj_type)
if(!grepl("3D", input$proj_type, ignore.case = T)) {
req(pp1())
tagList(
plotOutput(ns("plot2d"), height = paste0(500/5.5 *input$show_ploth,"px"),
brush = brushOpts(
id = ns("plot2d_brush")
),
hover = hoverOpts(id = ns("plot2d_hover"), delay = 50)), #%>% withSpinner()
uiOutput(ns("plot2d_tooltip")),
tags$li("Hint: Mouse over points to see the detailed annotation. Drag on plots to select cells. Set plot aesthetics (legend etc.) using gear button in upper right.", style = "font-size:12px")
)
} else {
req(pp1_3d())
plotlyOutput(ns("plotly3d"), height = paste0(500/5.5 *input$show_ploth,"px"), width = "100%") #%>% withSpinner()
}
})
output$plot2d_tooltip <- renderUI({
ns <- session$ns
hover <- input$plot2d_hover
x <- nearPoints(pvals$proj, hover, xvar = pvals$plot_col[1], yvar = pvals$plot_col[2], maxpoints = 1)
# If tree view, show lineage
if(ev$tree_view && !nrow(x)){
x <- nearPoints(bind_rows(pvals$coords[2:4]), hover, xvar = "x", yvar = "y", maxpoints = 1)
show_col <- "label"
} else {
show_col <- pvals$proj_colorBy
}
req(nrow(x) > 0)
if(pvals$plot_class != "expression" || is.null(ev$gene_values) || show_col == "label") {
y <- as.character(x[[show_col]])
if(show_col == "label") tt <-"Lineage" else tt <- pvals$legend_title
tip <- paste0("<b>",tt, ": </b>", y, "<br/>")
} else {
y <- round(ev$gene_values[rownames(x),, drop=F],3)
tip <- paste0(sapply(1:ncol(y), function(i) paste0("<b>", colnames(y)[i], ": </b>", y[[i]], "<br/>")), collapse = "")
}
req(length(y) > 0)
style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.65); ",
"left:", hover$coords_css$x + 2, "px; top:", hover$coords_css$y + 2, "px;",
"margin:5px; padding:5px 5px 0px 5px;")
# actual tooltip created as wellPanel
wellPanel(
style = style,
p(HTML(tip))
)
})
output$data_highlight <- renderUI({
req(ev$vis, input$proj_colorBy, !grepl("3D", input$proj_type), !input$proj_colorBy %in% c("moreop", "lessop"))
#print(paste0("highlight:", input$proj_colorBy))
input$gene_list
input$log_transform_val
input$choose_cell_reset
ns <- session$ns
proj_colorBy_dh <- input$proj_colorBy # This is necessary!!! See explanation in the observer
ui1 <- NULL
if(input$proj_colorBy %in% ev$factor_cols) {
if(input$proj_colorBy %in% c("cell.type", "cell.subtype")) {
factors <- names(which(table(ev$meta[[input$proj_colorBy]]) >= 10))
} else {
factors <- as.character(levels(factor(ev$meta[[input$proj_colorBy]])))
}
names(factors) <- factors
tip <- shinyBS::bsTooltip(
ns("choose_cell_reset"),
title = "Reset option",
options = list(container = "body", delay = list(show=1000, hide=3000))
)
ui1 <- selectInput(ns("factor_compo"), tags$div("Choose cells:", tipify(actionLink(ns("choose_cell_reset"), label = NULL, icon = icon("remove-sign", lib = "glyphicon"), style = "padding-left:10px;"), title = "Reset option")), choices = factors, multiple = T)
} else if(input$proj_colorBy != "gene.expr") {
num_range <- range(ev$value)
num_range[1] <- floor_dec(num_range[1],2)
num_range[2] <- ceiling_dec(num_range[2],2)
ui1 <- sliderInput(ns("numeric_range"), label = "Select Range", min = num_range[1], max = num_range[2], value = num_range)
} else if(input$proj_colorBy == "gene.expr"){
curg <- input$gene_list
if(length(curg)){
options <- list(
"All cells" = "nulv"
)
if(length(curg) == 1) {
curg_opt <- "1g"
names(curg_opt) <- paste0("Express: ", curg)
} else {
curg_opt <- "mg"
names(curg_opt) <- paste0("Co-Express: ", paste(curg, collapse = ", "))
}
options <- c(options, curg_opt)
ui1 <- selectInput(ns("cell_expr_gene"), "Choose Cells:", choices = options, multiple = F)
}
}
return(tagList(
ui1,
conditionalPanel("1==0", ns = ns, textInput(ns("proj_colorBy_dh"), label = NULL, value = proj_colorBy_dh)) # This is necessary!!! See explanation in the observer
))
})
observe({
ev$list <- sclist[[useid]]
rval$list <- sclist[[useid]]
})
observe({
sample <- input$input_sample
req(sample %in% names(ev$list), cmeta$df)
isolate({
ev$sample <- sample
ev$vis <- ev$list[[sample]]
idx <- ev$vis@idx
cur_meta <- cmeta$df[ev$vis@idx,]
if(!is.null(ev$vis@pmeta) && nrow(ev$vis@pmeta) == nrow(cur_meta)) cur_meta <- cbind(cur_meta, ev$vis@pmeta)
ev$meta <- cur_meta
ev$factor_cols <- sapply(colnames(ev$meta), function(x) {
ifelse(!is.numeric(ev$meta[[x]]), x, NA)
})
ev$meta_custom <- colnames(ev$meta)[!colnames(ev$meta) %in% showcols_advanced]
})
})
observeEvent(input$gene_list, {
updateSelectInput(session, "proj_colorBy", selected = "gene.expr")
})
# Data dependent
observe({
input$plot_config_reset
req(input$input_sample, input$proj_type, input$proj_colorBy, !input$proj_colorBy %in% c('lessop', 'moreop'))
req(input$input_sample == input$proj_type_I) # Sync the two renderUIs
if(!grepl("3D", input$proj_type)) req(input$proj_colorBy_dh == input$proj_colorBy)
# Prevent rendering twice when switching between gene expression and other colorBy
if(input$proj_colorBy != "gene.expr" && !is.null(input$gene_list)) {
return()
}
plot_col <- if(grepl("3D", input$proj_type)) {paste0("V", 1:3)} else {paste0("V", 1:2)}
if(grepl("PCA", input$proj_type)) {
if(!grepl("3D", input$proj_type)) {
req(input$pca2d_v1)
plot_col <- c(input$pca2d_v1, input$pca2d_v2)
} else {
req(input$pca3d_v1, input$pca3d_v2, input$pca3d_v3)
plot_col <- c(input$pca3d_v1, input$pca3d_v2, input$pca3d_v3)
}
ptype = "PCA"
} else {
ptype = input$proj_type
}
req(ptype %in% names(ev$vis@proj))
proj <- ev$vis@proj[[ptype]]
req(nrow(proj) == nrow(ev$meta))
proj <- cbind(proj, ev$meta)
proj$alpha <- rep("f", length(nrow(proj)))
gene_values <- NULL
gene_exprlim <- NULL
factor_color <- NULL
trans <- NULL
limits <- NULL
factor_breaks <- waiver()
if(input$proj_colorBy %in% ev$factor_cols) {
plot_class = "factor"
if(grepl("time.bin", input$proj_colorBy)) {
req(input$color_pal %in% numeric_bin_color_opt())
factor_color <- get_numeric_bin_color(levels(proj[[input$proj_colorBy]]), palette = input$color_pal)
names(factor_color) <- levels(proj[[input$proj_colorBy]])
} else {
req(input$color_pal %in% factor_color_opt())
factor_color <- get_factor_color(unique(proj[[input$proj_colorBy]]), pal=input$color_pal, maxCol = 9)
if(input$proj_colorBy == "to.filter") { # special case
factor_color <- rev(factor_color)
}
names(factor_color) <- unique(proj[[input$proj_colorBy]])
}
factor_color[["unannotated"]] <- "lightgrey"
if(input$proj_colorBy %in% c("cell.type", "cell.subtype")) {
factor_breaks <- names(which(table(proj[[input$proj_colorBy]]) >= 10))
} else if(input$proj_colorBy %in% c("lineage")) {
factor_breaks <- names(which(table(proj[[input$proj_colorBy]]) >= 5)) # Lower?
} else {
factor_breaks <- names(factor_color)
}
factor_breaks <- factor_breaks[factor_breaks != "unannotated"]
if(!is.null(input$factor_compo)) {
proj$alpha <- ifelse(proj[[input$proj_colorBy]] %in% input$factor_compo, "f", "t")
}
} else {
req(input$color_pal)
if(input$proj_colorBy == "gene.expr"){
plot_class <- "expression"
if(length(input$gene_list) == 1) {
#req(!is.na(input$g_limit))
req(input$g_limit_sample == ev$sample)
req(input$g_limit_ds == input$log_transform_gene)
req(input$g_limit_gene == input$gene_list)
#print(paste0(input$gene_list, ": ", input$g_limit))
if(is.na(input$g_limit)) {
limits <- c(0,1)
} else {
limits <- c(0,input$g_limit)
}
}
if(!is.null(input$cell_expr_gene) && !is.null(ev$gene_values)) {
if(input$cell_expr_gene!="nulv") {
proj$alpha <- ifelse(rowSums(ev$gene_values > 0) == ncol(ev$gene_values), "f", "t")
}
}
} else {
plot_class <- "numeric"
# !!! IMPORTANT !!!
# This evaluates if renderUI for v_limit has been updated, to prevent the plot from rendering twice
# If not updated, previous v_limit UI's corresponding proj_colorBy will not be the same as current input$proj_colorBy, then reactive is aborted.
req(ev$value_sample == ev$sample,
input$proj_colorBy_vlim == input$proj_colorBy,
input$v_limit_ds == input$log_transform_val,
input$v_limit_sample == ev$sample)
req(input$v_limit)
proj[[input$proj_colorBy]] <- ev$value
limits<-c(min(proj[[input$proj_colorBy]]), input$v_limit)
if(!is.null(input$numeric_range)) proj$alpha <- ifelse(proj[[input$proj_colorBy]] >= input$numeric_range[1] & proj[[input$proj_colorBy]] <= input$numeric_range[2], "f", "t")
}
}
legend=F; onplotAnnot=NULL
if(!is.null(input$legend_type)) {
if(input$legend_type == "l") {
legend=T; onplotAnnot=NULL
} else if(input$legend_type == "lot") {
legend=T; onplotAnnot="text"
} else if(input$legend_type == "lol") {
legend=T; onplotAnnot="label"
} else if(input$legend_type == "ot"){
legend=F; onplotAnnot="text"
} else if(input$legend_type == "ol"){
legend=F; onplotAnnot="label"
}
}
ev$proj <- proj # Save an original copy for zoom in
pvals$proj <- proj
pvals$proj_colorBy <- input$proj_colorBy
pvals$legend_title <- pmeta_attr$meta_name[which(pmeta_attr$meta_id == pvals$proj_colorBy)]
pvals$plot_class <- plot_class
pvals$plot_col <- plot_col
pvals$factor_color <- factor_color
pvals$color_pal <- input$color_pal
pvals$marker_size <- input$marker_size
pvals$text_size <- input$text_size
pvals$factor_compo <- input$factor_compo
pvals$factor_breaks <- factor_breaks
pvals$alpha_level <-input$alpha_level
pvals$limits <- limits
pvals$legend = legend
pvals$onplotAnnot = onplotAnnot
pvals$gene_values <- ev$gene_values
pvals$log_transform_gene <- input$log_transform_gene
})
observe({
req(input$proj_colorBy, input$log_transform_val)
req(is.numeric(ev$meta[[input$proj_colorBy]]))
if(input$log_transform_val == "log10") {
ev$value <- log10(ev$meta[[input$proj_colorBy]] + 1) # +1 ok for pseudo? Be careful for small values! Don't allow log in future
ev$value_sample <- ev$sample # Use this to sync up reactivity
} else {
ev$value <- ev$meta[[input$proj_colorBy]]
ev$value_sample <- ev$sample
}
})
observe({
req(input$log_transform_gene)
if(is.null(input$gene_list)) {
ev$gene_values <- NULL
return()
}
if(length(input$gene_list) > 2) {
session$sendCustomMessage(type = "showalert", "Do not support more than 2 genes.")
return()
}
if(input$log_transform_gene == "log2") {
ev$gene_values <- t(as.matrix(eset@assayData$norm_exprs[input$gene_list,ev$vis@idx, drop=F]))
} else if(input$log_transform_gene == "raw") {
ev$gene_values <- t(as.matrix(exprs(eset)[input$gene_list,ev$vis@idx, drop=F]))
}
#sassign("ev", reactiveValuesToList(ev), env =.GlobalEnv)
})
pp_factor <- reactive({
plotProj(pvals$proj, dim_col = which(colnames(pvals$proj) %in% pvals$plot_col), group.by=pvals$proj_colorBy, pal=pvals$factor_color, size = pvals$marker_size, plot_title=NULL, legend.title = pvals$legend_title, na.col = "lightgrey", alpha=pvals$proj$alpha, alpha_level=pvals$alpha_level, legend=pvals$legend, onplotAnnot = pvals$onplotAnnot, onplotAnnotSize = pvals$text_size, legend.text.size = pvals$text_size*3, ncol=4, breaks = pvals$factor_breaks)
})
pp_numeric <- reactive({
plotProj(pvals$proj, dim_col = which(colnames(pvals$proj) %in% pvals$plot_col), group.by=pvals$proj_colorBy, pal=pvals$color_pal, size = pvals$marker_size, plot_title=NULL, legend_title = pvals$legend_title, na.col = "lightgrey", alpha=pvals$proj$alpha, alpha_level=pvals$alpha_level, legend=T, trans = "identity", limits = pvals$limits)
})
pp_gene <- reactive({
if(is.null(pvals$gene_values)) {
ggplot(pvals$proj, aes_string(pvals$plot_col[1],pvals$plot_col[2])) +
geom_point(color="lightgrey", size=pvals$marker_size)+
theme_bw() +
theme(plot.title = element_text(hjust = 0.5), legend.position = c("top"))+ guides(alpha=F)
} else {
visualize_gene_expression(pvals$gene_values, colnames(pvals$gene_values), pvals$proj[c(pvals$plot_col[1],pvals$plot_col[2])],
limits=pvals$limits,
marker_size = pvals$marker_size, ncol=1,
binary = ifelse(ncol(pvals$gene_values) == 1, F, T),
pal=pvals$color_pal,
na.col = "lightgrey",
legend_name = ifelse(pvals$log_transform_gene == "log2",
paste0(colnames(pvals$gene_values), " expression\n(log normalized)"),
paste0(colnames(pvals$gene_values), " expression\n(UMI count)")))
}
})
pp1 <- reactive({
req(length(pvals$plot_col) == 2, pvals$plot_class)
input$tree_view
assign("pvals", reactiveValuesToList(pvals),env=.GlobalEnv)
if(pvals$plot_class == "factor") {
p <- pp_factor()
} else if(pvals$plot_class == "numeric") {
p <- pp_numeric()
} else {
p <- pp_gene()
}
if(ev$tree_view) {
req(input$tree_colorBy_fake == input$proj_colorBy)
req(input$tree_edge_size)
share_col = "lineage"
if(input$tree_filter_na) {
tip_to_drop <- fortify(as.treedata(tree_tbl))%>% filter(isTip & is.na(lineage))
cur_tree<-tree_tbl %>% filter(!to %in% tip_to_drop$label)
} else {
cur_tree<-tree_tbl
}
show_lin <- names(which(table(pvals$proj$lineage) >= 5))
if(input$proj_colorBy == "lineage") {
colorBy = share_col
cur_tree$lineage[which(!cur_tree$lineage %in% show_lin)] <- NA
} else if(input$proj_colorBy == "gene.expr") {
colorBy <- "value"
cur_tree$value <- lin_sc_expr[colnames(pvals$gene_values),][match(cur_tree$to, colnames(lin_sc_expr))]
}
# else if(input$proj_colorBy == "raw.embryo.time") {
# cur_tree$raw.embryo.time <- cur_tree$br_time + min(80, cur_tree$lifetime/2) # Median time
# colorBy <- "raw.embryo.time"
# }
if(input$left_tree_root!="No left tree") {
left_tree <- make_lineage_ggtree(in_tree = cur_tree, root = input$left_tree_root, time.cut = input$tree_time_cut, color.annot = colorBy, branch.length='lifetime')
} else left_tree <- NULL
if(input$right_tree_root!="No right tree") {
right_tree <- make_lineage_ggtree(in_tree = cur_tree, root = input$right_tree_root, time.cut = input$tree_time_cut, color.annot = colorBy, branch.length='lifetime')
} else right_tree <- NULL
if(input$top_tree_root!="No top tree") {
top_tree <- make_lineage_ggtree(in_tree = cur_tree, root = input$top_tree_root, time.cut = input$tree_time_cut, color.annot = colorBy, branch.length='lifetime')
} else top_tree <- NULL
if(is.null(left_tree) && is.null(right_tree) && is.null(top_tree)) return(p + theme_void())
res <- make_tree_dimr(proj=pvals$proj, left_tree = left_tree, right_tree = right_tree, top_tree = top_tree,
colorBy = colorBy, tree.color = pvals$factor_color,
label.time.cut = input$tree_label_cut, label.size = input$tree_label_size,
edge.size = input$tree_edge_size, tip.size = input$tree_tip_size,
tree.h.scale = input$tree_height,
plot.link = NULL, shift.y.scale = 1/20,
label.type = input$tree_label_style,
return_coords = T)
isolate({
pvals$coords <- res$coords
})
p <- res$plot + theme_void()
}
return(p)
})
pp1_final <- reactive({
req(pp1())
if(ev$tree_view && length(ev$cells)){
share_col = "lineage"
proj=pvals$proj
colnames(proj)[c(1,2)] <- c("x","y")
area_selected <- ev$area
proj <- proj[, c("x","y", share_col)]
highlight_lin <- table(proj$lineage[rownames(proj) %in% ev$cells])
highlight_lin <- names(highlight_lin[highlight_lin >= 5])
proj_center <- proj %>% group_by_at(share_col) %>% summarize_at(c("x", "y"), median) %>%
filter(lineage %in% highlight_lin)
if(ev$cell_source=="plot selection" && !is.null(ev$area)) {
proj_center <- proj %>% filter(x>=ev$area$xmin & x<=ev$area$xmax & y>=ev$area$ymin & y<= ev$area$ymax) # Only highlight centers in selected region
}
use_col <- c("x","y",share_col)
link_col <- c()
if(input$left_tree_root!="No left tree") {link_col <- c(link_col, "d1")}
if(input$right_tree_root!="No right tree") {link_col <- c(link_col, "d2")}
if(input$top_tree_root!="No top tree") {link_col <- c(link_col, "d3")}
if(!length(link_col)) return(pp1())
df_bind <- lapply(pvals$coords[link_col], function(x){
x[,use_col]
})
dd_tree <- bind_rows(df_bind) %>% filter(lineage %in% highlight_lin)
dd_tree$x2 <- proj_center$x[match(dd_tree[[share_col]], proj_center[[share_col]])]
dd_tree$y2 <- proj_center$y[match(dd_tree[[share_col]], proj_center[[share_col]])]
p <- pp1() +
geom_segment(aes(x = x, y=y, xend = x2, yend =y2), data=dd_tree, color='grey', alpha = .5, size = .5)
} else {
p <- pp1()
}
return(p)
})
output$plot2d <- renderPlot({
req(pp1_final())
})
pp1_3d <- reactive({
req(pvals$proj, length(pvals$plot_col) == 3)
proj <- pvals$proj
ds <- pvals$plot_col
marker_size <- pvals$marker_size * 2
#assign("pvals", reactiveValuesToList(pvals), env = .GlobalEnv)
#alpha_manual <- c("f"=1,"t"=pvals$alpha_level)
if(pvals$plot_class == "factor") {
plotly::plot_ly(proj, x = as.formula(paste0("~", ds[1])), y = as.formula(paste0("~", ds[2])), z = as.formula(paste0("~", ds[3])),
text=proj[[pvals$proj_colorBy]],
hoverinfo="text",
marker = list(size = marker_size),
#opacity=alpha_manual[proj$alpha],
key = row.names(proj),
color = as.formula(paste0("~", pvals$proj_colorBy)), colors = pvals$factor_color) %>%
plotly::add_markers() %>%
layout(legend = list(orientation = 'h'))
} else if(pvals$plot_class == "numeric") {
rgb_scale_list<- numeric_rgb_range(col = get_numeric_color(pvals$color_pal), zgrey=F)
proj$show_value <- proj[[pvals$proj_colorBy]] # Show original value
if(!is.null(pvals$limits)) {
proj[[pvals$proj_colorBy]][proj[[pvals$proj_colorBy]] < pvals$limits[1]] <- pvals$limits[1]
proj[[pvals$proj_colorBy]][proj[[pvals$proj_colorBy]] > pvals$limits[2]] <- pvals$limits[2]
}
plotly::plot_ly(proj,
x = as.formula(paste0("~", ds[1])), y = as.formula(paste0("~", ds[2])), z = as.formula(paste0("~", ds[3])),
text=proj$show_value,
hoverinfo="text",
key = row.names(proj),
marker = list(size = marker_size,
color = as.formula(paste0("~", pvals$proj_colorBy)),
colorscale = rgb_scale_list)) %>%
plotly::add_markers(
#opacity=alpha_manual[proj$alpha]
) %>%
layout(legend = list(orientation = 'h'))
} else {
visualize_expression_plotly(expr= pvals$gene_values, projection = proj, ds=ds, gene_probes = colnames(pvals$gene_values), limits = pvals$limits, marker_size=marker_size, pal = pvals$color_pal)
}
})
output$plotly3d <- renderPlotly({
req(pp1_3d())
assign("pp1_3d", pp1_3d(), env = .GlobalEnv)
pp1_3d() %>% hide_legend()
})
output$explore_plotf_ui <- renderUI({
ns <- session$ns
req(input$proj_type)
if(!grepl("3D", input$proj_type)){
choices <- list("png" = "png", "pdf" = "pdf", "eps" = "eps", "tiff" = "tiff")
} else {
choices <- list( "html" = "html")
}
selectInput(ns("plotf"), "Format", choices = choices, selected = choices[[1]])
})
output$download_explore_plot <- downloadHandler(
filename = function(format = input$plotf) {
fn_ext<-switch(format,
png = '.png',
tiff = '.tiff',
eps = '.eps',
pdf = '.pdf',
html = '.html'
)
paste('Plot-', Sys.Date(), fn_ext, sep='')
},
content = function(con, format = input$plotf) {
req(input$down_plotw, input$down_ploth, format)
fn_dev<-switch(format,
png = 'png',
tiff = 'tiff',
eps = 'eps',
pdf = 'pdf',
html = 'html'
)
if(fn_dev!='html') {
req(pp1_final())
ggsave(con, plot = pp1_final(), device = fn_dev, width = input$down_plotw, height = input$down_ploth)
shut_device <- dev.list()[which(names(dev.list()) != "quartz_off_screen")]
if(length(shut_device)) dev.off(which = shut_device) # Make sure ggsave does not change graphic device
} else {
req(pp1_3d())
htmlwidgets::saveWidget(pp1_3d(), con)
}
}
)
output$download_bp_plot <- downloadHandler(
filename = function(format = input$bp_plotf) {
fn_ext<-switch(format,
png = '.png',
tiff = '.tiff',
eps = '.eps',
pdf = '.pdf'
)
paste('Plot-', Sys.Date(), fn_ext, sep='')
},
content = function(con, format = input$bp_plotf) {
req(input$bp_down_plotw, input$bp_down_ploth, format)
fn_dev<-switch(format,
png = 'png',
tiff = 'tiff',
eps = 'eps',
pdf = 'pdf'
)
if(fn_dev!='html') {
req(bp1())
ggsave(con, plot = bp1(), device = fn_dev, width = input$bp_down_plotw, height = input$bp_down_ploth)
shut_device <- dev.list()[which(names(dev.list()) != "quartz_off_screen")]
if(length(shut_device)) dev.off(which = shut_device) # Make sure ggsave does not change graphic device
}
}
)
output$download_data <- downloadHandler(
filename = function(format = input$selectCell_goal) {
fn_ext<-switch(format,
downcell = '.rds',
downmeta = '.csv'
)
paste('cedata-', ev$sample, format, "-", Sys.Date(), fn_ext, sep='')
},
content = function(con, format = input$selectCell_goal) {
req(format, length(ev$cells))
if(format == "downcell") {
cur_eset <- eset[,ev$cells]
tmp<-ev$meta %>% tibble::rownames_to_column("Cell")
rownames(tmp) <- tmp$Cell
pData(cur_eset) <- cbind(tmp[ev$cells,], pvals$proj[ev$cells, pvals$plot_col])
saveRDS(cur_eset, con, compress=F) # Not compress so that saving is faster
} else if(format == "downmeta") {
write.csv(cbind(ev$meta[ev$cells, ], pvals$proj[ev$cells, pvals$plot_col]), con)
}
}
)
# Cell Select
output$selectCell_panel <- renderUI({
req(length(ev$cells) > 0)
ns = session$ns
selected_samples <- ev$cells
ns <- session$ns
isolate({
if(!is.null(input$selectCell_meta_col)) {
meta_col_selected<-input$selectCell_meta_col
} else {
meta_col_selected<-NULL
}
# if(!is.null(input$selectCell_goal)) {
# goal_selected<-input$selectCell_goal
# } else {
# goal_selected<-NULL
# }
})
wellPanel(
class = "SidebarControl",
fluidRow(
column(12, selectInput(ns("selectCell_goal"), paste("Operation on", length(selected_samples), "cells"), choices = list(
"Zoom in to selected cells" = "zoom",
"Name selected cell subset" = "addmeta",
#"Compute new PCA/UMAP with selected cells" = "compdimr", # Don't allow in online version
"Download expression data (ExpressionSet format) of selected cells" = "downcell",
"Download meta data of selected cells" = "downmeta"
)))
),
conditionalPanel(
"input.selectCell_goal == 'addmeta'", ns=ns,
fluidRow(
column(6,
selectizeInput(ns("selectCell_meta_col"), "Meta class", choices = ev$meta_custom, options=list(create=T), selected = meta_col_selected),
shinyBS::bsTooltip(
ns("selectCell_meta_col"),
title = "Type name and press enter to add a new meta class, delete it use the button on the right",
placement="top",
options = list(container = "body")
)),
column(6,
tags$br(),actionButton(ns("MetaCol_delete"), "Delete class", class = "btn-danger btn_leftAlign")
)
),
fluidRow(
column(6, textInput(ns("selectCell_group_name"), "Name subset", placeholder="e.g., group 1")),
column(6, tags$br(),actionButton(ns("selectCell_add"), "Add group", class = "btn-info btn_leftAlign"))
)
),
conditionalPanel(
"input.selectCell_goal == 'zoom'", ns=ns,
fluidRow(
column(6,
textInput(ns("zoom_name"), "Sample name:", placeholder="optional")
),
column(6,
tags$br(),
actionButton(ns("zoom_in"), "Zoom in", class = "btn-primary btn_rightAlign")
)
),
tags$li("Provide a name to create a new visualization (sample)."),
tags$li("Zoom out by click topright reset button.")
),
conditionalPanel(
"input.selectCell_goal == 'downcell' || input.selectCell_goal == 'downmeta'", ns=ns,
fluidRow(
column(12,
downloadButton(ns("download_data"), "Download data", class = "btn-primary btn_rightAlign")
)
)
),
conditionalPanel(
"input.selectCell_goal == 'compdimr'", ns=ns,
fluidRow(
column(6,
selectInput(ns("compdimr_type"), "Compute:", choices = list("UMAP-2D" = "UMAP-2D", "UMAP-3D" = "UMAP-3D", "PCA" = "PCA"))
),
column(6,
textInput(ns("compdimr_name"), "Subset name:", placeholder="e.g., Late Neurons")
)
),
fluidRow(
column(6,
numericInput(ns("compdimr_mine"), "Umi >", value=1)
),
column(6,
numericInput(ns("compdimr_minc"), "in cells", value=10)
)
),
fluidRow(
column(6,
numericInput(ns("compdimr_disp"), "DispRatio", value=.5)
),
column(6,
numericInput(ns("compdimr_numpc"), "NumPC", value=50, min=2)
)
),
fluidRow(
column(6,
checkboxInput(ns("compdimr_batch"), tags$b("Correct batch"), F)
),
column(6, actionButton(ns("compdimr_run"), "Compute", class = "btn-info btn_rightAlign"))
)
)
)
})
observe({
req(input$plot2d_brush)
isolate({
area_selected<-input$plot2d_brush
plot_cols <- which(colnames(pvals$proj) %in% pvals$plot_col)
ev$cells <- rownames(pvals$proj)[which(pvals$proj[[plot_cols[1]]] >= area_selected$xmin & pvals$proj[[plot_cols[1]]] <= area_selected$xmax &
pvals$proj[[plot_cols[2]]] >= area_selected$ymin & pvals$proj[[plot_cols[2]]] <= area_selected$ymax)]
ev$cell_source <- "plot selection"
ev$area <- area_selected
})
})
observe({
req(input$proj_colorBy)
input$factor_compo
input$numeric_range
input$cell_expr_gene
if(input$proj_colorBy %in% ev$factor_cols) {
req(input$factor_compo)
ev$cells <- rownames(ev$meta)[ev$meta[[input$proj_colorBy]] %in% input$factor_compo]
} else if(input$proj_colorBy != "gene.expr") {
req(input$numeric_range)
vals <- ev$value
filter_std <- vals >= input$numeric_range[1] & vals <= input$numeric_range[2]
ev$cells <- rownames(ev$meta)[filter_std]
} else if(input$proj_colorBy == "gene.expr") {
if(is.null(ev$gene_values)) {
ev$cells <- NULL
return()
}
req(input$cell_expr_gene)
if(input$cell_expr_gene!="nulv") {
ev$cells <- names(which(rowSums(ev$gene_values > 0) == ncol(ev$gene_values)))
} else {
ev$cells <- NULL
}
}
ev$cell_source <- input$proj_colorBy
})
# Add by interactive mode
observeEvent(input$selectCell_add, {
if(nchar(input$selectCell_meta_col) < 1){
session$sendCustomMessage(type = "showalert", "Please specify a meta class or create one.")
return()
}
if(!is.na(as.numeric(input$selectCell_meta_col))) {
session$sendCustomMessage(type = "showalert", "Number name not allowed.")
return()
}
if(nchar(input$selectCell_group_name) < 1){
session$sendCustomMessage(type = "showalert", "Please specify a name for the cell subset.")
return()
}
if(length(ev$cells)) {
rval$mclass = input$selectCell_meta_col
rval$group_name = input$selectCell_group_name
rval$cells <- ev$cells
}
showNotification(paste("New meta class:", rval$group_name, "added"), type="message", duration=10)
updateSelectInput(session, "proj_colorBy", "Color by", selected = rval$mclass)
updateSelectInput(session, "selectCell_goal", selected = "addmeta")
updateSelectInput(session, "selectCell_meta_col", "Meta class", selected = rval$mclass)
})
observeEvent(input$MetaCol_delete, {
req(input$selectCell_meta_col, nchar(input$selectCell_meta_col) >= 1)
rval$mclass = input$selectCell_meta_col
rval$cells = NULL
rval$group_name = NULL
showNotification(paste("Meta class:", rval$mclass, "deleted"), type="message", duration=10)
})
callModule(pivot_help, "cellSelection", title = "Select and define cell groups:", size = "m", content = list(
tags$li("In interactive 2D plot, you can select cells by drag on the plot."),
tags$li("You can use the topright plotly menu to switch selection mode to lasso selection."),
tags$li("Once cells are selected, you can make a new meta class to add annotation to the selected cells."),
tags$li("First, in 'Meta class', type the new meta class name, press enter."),
tags$li("Then with the new class selected, enter a name for the selected cell group, press 'Add Group'."),
tags$li("You can now see the newly added meta class appear in 'Color By' menu."),
tags$li("You can download the newly annotated cds file, or just download the new metadata.")
))
callModule(pivot_help, "choose_sample_info", title = "Visualize cell subsets:", size = "m", content = list(
tags$li("'Sample's are cell subsets which enable global and zoom-in exploration of the data."),
tags$li("The tool contains sets of cell subsets that's generated by the developer and stored as part of the package."),
tags$li("Users can create their own cell subset by using the cell selection tool, and running a UMAP/PCA with selected cells."),
tags$li("You can delete user-created cell subsets with menu below:"),
tags$hr(),
uiOutput(session$ns("choose_sample_del_ui"))
))
output$choose_sample_del_ui <- renderUI({
ns <- session$ns
sample_names <- names(rval$list)
fluidRow(
column(8, selectInput(ns("del_sample"), "Choose cell subset", choices=sample_names)),
column(4, tags$br(),actionButton(ns("del_sample_btn"), "Delete", class = "btn-danger btn_leftAlign"))
)
})
observeEvent(input$del_sample_btn, {
req(input$del_sample)
ns <- session$ns
rval$list[[input$del_sample]] <- NULL
rval$ustats <- "del"
showNotification("Subset deleted.", type="message", duration=10)
})
output$g_limit_ui <- renderUI({
ns <- session$ns
input$plot_config_reset
req(input$gene_list)
if(length(input$gene_list) == 1) {
gvals <- ev$gene_values[,1]
glim <- round(quantile(gvals[gvals!=0], .975),1)
if(!is.na(glim) && glim < 2) glim = 2 # Minimal max-cut
dropdownButton2(inputId=ns("val_cutoff"),
width = "500px",
plotOutput(ns("gene_histogram_plot")),
fluidRow(
column(6, numericInput(ns("g_limit"),
label = "Expression Cutoff",
value = glim, min = 0)),
column(6, tags$p("Red line indicate max value for color scale. Default cutoff is set at 97.5th percentile."))
),
conditionalPanel("1==0", ns = ns, textInput(ns("g_limit_ds"), label = NULL, value = input$log_transform_gene)),
conditionalPanel("1==0", ns = ns, textInput(ns("g_limit_sample"), label = NULL, value = input$input_sample)),
conditionalPanel("1==0", ns = ns, textInput(ns("g_limit_gene"), label = NULL, value = input$gene_list)),
circle = T, label ="Expression histogram and color scale cutoff", tooltip=T, right = T,
icon = icon("chart-bar"), size = "xs", status="info", class = "btn_rightAlign")
} else {
return()
# tagList(
# conditionalPanel("1==0", ns = ns, textInput(ns("g_limit_sample"), label = NULL, value = input$input_sample)),
# conditionalPanel("1==0", ns = ns, numericInput(ns("g_limit"), label = NULL, value = NA))
# )
}
})
output$gene_histogram_plot <- renderPlot({
req(ev$gene_values)
gname <- colnames(ev$gene_values)
hist(ev$gene_values[,1], xlab=paste0(input$log_transform_gene, "expression"), main = paste0("Expression histogram of gene ", gname))
abline(v = input$g_limit, col=c("red"), lty=c(2), lwd=c(3))
})
output$v_limit_ui <- renderUI({
ns <- session$ns
input$plot_config_reset
req(!input$proj_colorBy %in% c(ev$factor_cols, 'gene.expr'))
v_limit <- round(quantile(ev$value, .975), 1)
dropdownButton2(inputId=ns("v_cutoff"),
width = "500px",
plotOutput(ns("value_histogram_plot")),
fluidRow(
column(6, numericInput(ns("v_limit"), label = "Cutoff", value = v_limit, min = 0)),
column(6, tags$p("Red line indicate max value for color scale. Default cutoff is set at 97.5th percentile."))
),
conditionalPanel("1==0", ns = ns, textInput(ns("proj_colorBy_vlim"), label = NULL, value = input$proj_colorBy)), # This is necessary!!! See explanation in the observer
conditionalPanel("1==0", ns = ns, textInput(ns("v_limit_ds"), label = NULL, value = input$log_transform_val)),
conditionalPanel("1==0", ns = ns, textInput(ns("v_limit_sample"), label = NULL, value = input$input_sample)),
circle = T, label ="Histogram and color scale cutoff", tooltip=T, right = T,
icon = icon("chart-bar"), size = "xs", status="info", class = "btn_rightAlign")
})
output$value_histogram_plot <- renderPlot({
req(pvals$plot_class == "numeric")
vals <- pvals$proj[[pvals$proj_colorBy]]
hist(vals, xlab=pvals$legend_title, main = paste0("Histogram of ", pvals$legend_title))
abline(v = input$v_limit, col=c("red"), lty=c(2), lwd=c(3))
})
observeEvent(input$zoom_in, {
req(ev$cells)
if(input$zoom_name == "") {
pvals$proj <- ev$proj[ev$cells,]
factor_breaks <- waiver()
if(pvals$proj_colorBy %in% ev$factor_cols) {
if(input$proj_colorBy %in% c("cell.type", "cell.subtype")) {
factor_breaks <- names(which(table(pvals$proj[[pvals$proj_colorBy]]) >= 10))
} else {
factor_breaks <- unique(pvals$proj[[pvals$proj_colorBy]])
}
factor_breaks <- factor_breaks[factor_breaks != "unannotated"]
}
pvals$factor_breaks <- factor_breaks
if(!is.null(ev$gene_values)) pvals$gene_values <- ev$gene_values[ev$cells,, drop=F]
return()
}
if(input$zoom_name %in% c("moreop", "lessop")) {
session$sendCustomMessage(type = "showalert", "Name not allowed.")
return()
}
if(!is.na(as.numeric(input$zoom_name))) {
session$sendCustomMessage(type = "showalert", "Number name not allowed.")
return()
}
if(input$zoom_name %in% c(names(sclist$clist), names(sclist$elist))) {
session$sendCustomMessage(type = "showalert", "Name already taken.")
return()
}
newvis <- new("Cello", idx = match(ev$cells, colnames(eset)))
newvis@proj[[input$proj_type]] <- pvals$proj[ev$cells, pvals$plot_col]
rval$list[[input$zoom_name]] <- newvis
rval$ustats <- "add"
updateSelectInput(session, "input_sample", selected = input$zoom_name)
})
# Don't put in online version
# observeEvent(input$compdimr_run, {
# req(ev$cells)
#
# error_I <- 0
# tryCatch({
# reticulate::import("umap")
# }, warning = function(w) {
# }, error = function(e) {
# error_I <<-1
# })
#
# if(error_I) {
# session$sendCustomMessage(type = "showalert", "UMAP not installed, please install umap to python environment first.")
# return()
# }
#
# if(is.null(input$compdimr_name) || input$compdimr_name == "") {
# session$sendCustomMessage(type = "showalert", "Enter a name first.")
# return()
# }
# if(input$compdimr_name %in% c("moreop", "lessop")) {
# session$sendCustomMessage(type = "showalert", "Name not allowed.")
# return()
# }
# if(!is.na(as.numeric(input$compdimr_name))) {
# session$sendCustomMessage(type = "showalert", "Number name not allowed.")
# return()
# }
# if(input$compdimr_name %in% c(names(sclist$clist), names(sclist$elist))) {
# session$sendCustomMessage(type = "showalert", "Name already taken.")
# return()
# }
# if(input$compdimr_batch) {
# resform <- "~as.factor(batch) + ~as.factor(batch) * raw.embryo.time"
# } else {
# resform <- NULL
# }
#
#
#
# withProgress(message = 'Processing...', {
# incProgress(1/2)
# set.seed(2018)
# #assign("ev1cells", ev$cells, env=.GlobalEnv)
# fd <- fData(eset[,ev$cells])[, c(1,2)]
# colnames(fd) <- c("id", "gene_short_name")
# cds_oidx <- newCellDataSet(cellData = exprs(eset[,ev$cells]), phenoData = new("AnnotatedDataFrame", data = pData(eset[,ev$cells])), featureData = new("AnnotatedDataFrame", data = fd))
# pData(cds_oidx) <- pData(eset[,ev$cells])
# cds_oidx <- filter_cds(cds=cds_oidx, min_detect=input$compdimr_mine, min_numc_expressed = input$compdimr_minc, min_disp_ratio=input$compdimr_disp)
# #assign("cds1", cds_oidx, env=.GlobalEnv)
# irlba_res <- compute_pca_cds(cds_oidx, num_dim =input$compdimr_numpc, scvis=NULL, use_order_gene = T, residualModelFormulaStr = resform, return_type="irlba")
# pca_proj <- as.data.frame(irlba_res$x)
# rownames(pca_proj) <- colnames(cds_oidx)
# newvis <- new("Cello", idx = match(ev$cells, colnames(eset)))
# newvis@proj[["PCA"]] <- pca_proj
# if(grepl("UMAP", input$compdimr_type)) {
# n_component = ifelse(grepl("2D", input$compdimr_type), 2, 3)
# newvis@proj[[paste0(input$compdimr_type, " [", input$compdimr_numpc, "PC]")]]<-compute_umap_pca(pca_proj, num_dim = input$compdimr_numpc, n_component=n_component)
# }
# rval$list[[input$compdimr_name]] <- newvis
# rval$ustats <- "add"
# })
# updateSelectInput(session, "input_sample", selected = input$compdimr_name)
# showNotification("Dimension reduction successfully computed.", type="message", duration=10)
# })
### Feature Plot ###
output$bp_gene_plot_ui <- renderUI({
req(input$bp_show_ploth)
ns <- session$ns
plotOutput(ns("bp_gene_plot"), height = paste0(500/5.5 *input$bp_show_ploth,"px")) %>% withSpinner()
})
#updateSelectizeInput(session, "bp_gene", "Search Gene:", choices = c("No gene selected", gene_tbl), selected = "No gene selected", server=T)
output$bp_sample_ui <- renderUI({
ns <- session$ns
sample_names <- names(ev$list)
isolate({
if(!is.null(input$input_sample)) {
selected <- input$input_sample
} else {
selected <- NULL
}
})
selectInput(ns("bp_sample"),"Choose cell subset", choices=sample_names, selected = selected)
})
# The follwoing observers control the syncing between explorer sample input and feature plot sample input
observe({
req(!is.null(input$input_sample))
updateSelectInput(session, "bp_sample", "Choose cell subset", selected = input$input_sample)
})
observe({
req(!is.null(input$bp_sample))
updateSelectInput(session, "input_sample", selected = input$bp_sample)
})
# The follwoing observers control the syncing between explorer gene input and feature plot gene input
observeEvent(input$gene_list, {
req(length(input$gene_list) == 1)
if(is.null(input$bp_gene) || input$gene_list != input$bp_gene) {
updateSelectInput(session, "bp_gene", selected = input$gene_list)
}
})
observeEvent(input$bp_gene, {
req(input$bp_gene, input$bp_gene != "No gene selected")
if(is.null(input$gene_list) || input$bp_gene != input$gene_list) {
updateSelectInput(session, "gene_list", selected = input$bp_gene)
}
})
output$bp_colorBy_ui <- renderUI({
ns <- session$ns
selectInput(ns("bp_colorBy"), "Color by:", choices = bp_colorBy_choices)
})
output$bp_include_ui <- renderUI({
ns <- session$ns
req(input$bp_colorBy)
input$bp_reset
factors <- names(which(table(ev$meta[[input$bp_colorBy]]) >= 10))
#factors <- factors[factors != "unannotated"]
tagList(
selectInput(ns("bp_include"), "Include:", choices = factors, selected=NULL, multiple = T, width = '100%'),
conditionalPanel("1==0", textInput(ns("bp_include_I"), NULL, value = ev$sample)) # indicator of rendering state of bp_include
)
})
output$bp_plot_configure_ui <- renderUI({
input$bp_plot_config_reset
ns <- session$ns
req(input$bp_colorBy)
if(input$bp_colorBy %in% pmeta_attr$meta_id && !is.null(pmeta_attr$dpal)) {
default_pal <- pmeta_attr$dpal[which(pmeta_attr$meta_id==input$bp_colorBy)]
} else {
default_pal <- NULL
}
if(input$bp_colorBy %in% ev$factor_cols){
if(grepl("time.bin", input$bp_colorBy)) {
sel <- selectInput(ns("bp_numericbin_pal"), "Palette", choices=numeric_bin_color_opt(), selected=default_pal)
} else {
sel <- selectInput(ns("bp_factor_pal"), "Palette", choices=factor_color_opt(), selected=default_pal)
}
} else {
return()
}
dropdownButton2(inputId=ns("bp_plot_configure"),
fluidRow(
column(6, numericInput(ns("bp_downsample"), "Downsample #", min=2, max = 10000, value=500)),
column(6, selectInput(ns("bp_plot_type"), "Plot Type", choices = list("Box plot" = "box", "Violin plot" = "violin", "Plot points" = "points")))
),
fluidRow(
column(6, numericInput(ns("bp_marker_size"), "Point Size", min = 0.1, value = 1, step = 0.1)),
column(6, numericInput(ns("bp_text_size"), "Text Size", min = 1, value = 15, step = 1))
),
fluidRow(
column(6, sel),
column(6, selectInput(ns("bp_legend_type"), "Legend", choices=c("Color Legend" = "l", "None" = "none"), selected = "none"))
),
fluidRow(
column(6, numericInput(ns("bp_xaxis_angle"), "X-axis Label Angle", value = 45, step=1)),
column(6, numericInput(ns("bp_show_ploth"), "Plot Height", min=1, value = 5, step=1))
),
circle = T, label ="Configure Plot", tooltip=T, right = T,
icon = icon("cog"), size = "xs", status="primary", class = "btn_rightAlign")
})
bp1 <- reactive({
req(input$bp_colorBy, length(input$bp_gene) == 1, input$bp_gene != "No gene selected", input$bp_gene %in% gene_tbl[[1]])
req(ev$sample == input$bp_sample, ev$sample == input$bp_include_I) # IMPORTANT, this controls the sync between sample choices in the explorer and the featurePlot, and prevent double rendering
cur_group <- ev$meta[[input$bp_colorBy]]
# Downsample cells from each cell type
if(length(input$bp_include) == 0) {
cur_factors <- names(which(table(ev$meta[[input$bp_colorBy]]) >= 10))
} else{
cur_factors <- input$bp_include
}
cur_idx <- unlist(lapply(cur_factors, function(g) {
cidx <- which(cur_group==g)
sample(cidx, min(length(cidx),input$bp_downsample))
}))
cur_meta <- ev$meta[cur_idx, input$bp_colorBy, drop=F]
if(grepl("time.bin", input$bp_colorBy)) {
req(input$bp_numericbin_pal)
factor_color <- get_numeric_bin_color(levels(ev$meta[[input$bp_colorBy]]), palette = input$bp_numericbin_pal)
names(factor_color) <- levels(ev$meta[[input$bp_colorBy]])
} else {
req(input$bp_factor_pal)
factor_color <- get_factor_color(unique(ev$meta[[input$bp_colorBy]]), pal=input$bp_factor_pal, maxCol = 9)
names(factor_color) <- unique(ev$meta[[input$bp_colorBy]])
}
factor_color[["unannotated"]] <- "lightgrey"
colorBy_name <- pmeta_attr$meta_name[which(pmeta_attr$meta_id == input$bp_colorBy)]
if(input$bp_log_transform_gene == "log2") {
df <- as.data.frame(as.matrix(eset@assayData$norm_exprs[input$bp_gene, ev$vis@idx[cur_idx]]))
} else {
df <- as.data.frame(as.matrix(exprs(eset)[input$bp_gene, ev$vis@idx[cur_idx]]))
}
feature_plot(df, input$bp_gene,
group.by = input$bp_colorBy,
meta = cur_meta,
pal = factor_color,
style = input$bp_plot_type, log_scale = F, legend.title = colorBy_name, legend.pos = "right",
text.size = input$bp_text_size, pointSize = input$bp_marker_size, legend = ifelse(input$bp_legend_type == "l", T, F),
breaks = unique(cur_group), axis.text.angle = input$bp_xaxis_angle,
order.by = ifelse(grepl("time",input$bp_colorBy, ignore.case = T), "none", "mean"),
ylab.label = ifelse(input$bp_log_transform_gene == "log2", "Expression (log2 normalized)", "Expression (UMI count)")
)
})
output$bp_gene_plot <- renderPlot({
req(bp1())
bp1()
})
############### Cell Type Marker Table #############
#################### Cell type marker table #################
#proxy = dataTableProxy('ct_marker_tbl')
shinyInput <- function(FUN, id, ...) {
as.character(FUN(id, ...))
}
output$ct_marker_tbl <- DT::renderDataTable({
ns <- session$ns
ct_show <- cell_type_markers
# ct_show$Marker.genes <- lapply(1:nrow(ct_show), function(i) {
# x <- as.character(ct_show$Marker.genes[i])
# genes<-trimws(unlist(strsplit(x, ",")), which = "both")
# #assign("ns1", ns, env=.GlobalEnv)
# btns <- paste(
# sapply(genes, function(g){
# shinyInput(actionLink, row = i, id = paste0(g,'_', i), label = g, icon = NULL, onclick = paste0("Shiny.onInputChange(\"", ns("ct_gene"), "\", this.id)"))
# }),
# collapse = ", ")
# return(btns)
# })
# #assign("ns1", session$ns, env=.GlobalEnv)
# ct_show$UMAP <- lapply(1:nrow(ct_show), function(i) {
# x <- as.character(ct_show$UMAP[i])
# shinyInput(actionLink, row = i, id = paste0(x,'_', i), label = x, icon = NULL, onclick = paste0("Shiny.onInputChange(\"", ns("ct_umap"), "\", this.id)"))
# })
names(ct_show) <- c("Cell Type", "UMAP", "Markers", "Notes")
DT::datatable(ct_show, selection = 'none',
rownames=F,
editable = F,
options = list(
searching=T,
scrollX = TRUE,
columnDefs = list(list(width = '20%', targets = list(0,1,2)))
)
) %>%
DT::formatStyle(columns = c(1),fontWeight = 'bold')
})
observeEvent(input$ct_gene, {
gene_row <- unlist(strsplit(as.character(input$ct_gene), "_", fixed = T))
if(length(gene_row) != 2) {
return()
}
gene <- gene_row[1]
row <- as.numeric(gene_row[2])
umap_id <- cell_type_markers$UMAP[row]
updateTabsetPanel(session, "ct_tab", selected = "eui")
updateSelectInput(session, "input_sample", selected = umap_id)
updateSelectizeInput(session, "proj_colorBy", selected = "gene.expr")
updateSelectInput(session, "gene_list", selected = gene)
})
observeEvent(input$ct_umap, {
umap_row <- unlist(strsplit(as.character(input$ct_umap), "_", fixed = T))
if(length(umap_row) != 2) {
return()
}
row <- as.numeric(umap_row[2])
umap_id <- cell_type_markers$UMAP[row]
updateTabsetPanel(session, "ct_tab", selected = "eui")
updateSelectInput(session, "input_sample", selected = umap_id)
})
output$download_ct_marker <- downloadHandler(
filename = function() {
'cell_type_markers.xlsx'
},
content = function(con) {
write.xlsx(cell_type_markers, file=con)
}
)
###### Lineage marker imaging graph ######
# Image gene expression graph plot
output$image_graph_plot_ui <- renderUI({
req(input$image_ploth)
ns <- session$ns
plotOutput(ns("image_graph_plot"), height = paste0(500/5.5 *input$image_ploth,"px")) %>% withSpinner()
})
output$image_graph_plot <- renderPlot({
req(input$image_colorBy, input$image_pal, input$image_scale)
t_cut <- 108
plotg <- input$image_colorBy
if(input$image_scale == "log10") {
g <- g_all
} else {
g <- g_agg
}
g<-g %>% activate("nodes") %>%
mutate(text.size = ifelse(time > t_cut, 0, 10/log10(time+1))) %>%
mutate(name = ifelse(time > t_cut, "", name)) %>%
filter(!(time > 200 & is.na(!!as.name(plotg))))
range(as.data.frame(g)$text.size)
plotGraph(g, color.by=plotg, pal=input$image_pal, label="name", type = "numeric",border.size=.3, legend.title = names(image_colorBy_choices)[which(image_colorBy_choices == input$image_colorBy)]) +
theme(
axis.ticks.x=element_blank(),
axis.text.x=element_blank(),
axis.ticks.y=element_blank(),
axis.text.y=element_blank(),
legend.margin=margin(15,0,0,0),
legend.box.margin=margin(-10,-10,-10,-10),
plot.margin = unit(c(.3,.5,.3,.3), "cm"))
})
output$g_meta_table <- DT::renderDataTable({
req(input$image_colorBy)
curg<- names(image_colorBy_choices)[which(image_colorBy_choices == input$image_colorBy)]
req(curg %in% names(g_meta_list))
DT::datatable(g_meta_list[[curg]], selection = 'none',
rownames=F,
options = list(
searching=F,
scrollX = TRUE,
paging = F
)
)
})
### Lineage marker table ###
output$lin_marker_tbl <- DT::renderDataTable({
ns <- session$ns
lin_show <- lineage_markers
# lin_show$Markers <- lapply(1:nrow(lin_show), function(i) {
# x <- as.character(lin_show$Markers[i])
# if(is.na(x) || x == "") return("")
# genes<-trimws(unlist(strsplit(x, ",")), which = "both")
# btns <- paste(
# sapply(genes, function(g){
# if(!g %in% gene_tbl[[1]]) return(g)
# shinyInput(actionLink, row = i, id = paste0(g,'_', i), label = g, icon = NULL, onclick = paste0("Shiny.onInputChange(\"", ns("lin_gene"), "\", this.id)"))
# }),
# collapse = ", ")
# return(btns)
# })
# lin_show$UMAP <- lapply(1:nrow(lin_show), function(i) {
# if(is.na(lin_show$UMAP[i]) || lin_show$UMAP[i] == "") return(NA)
# x <- as.character(lin_show$UMAP[i])
# shinyInput(actionLink, row = i, id = paste0(x,'_', i), label = x, icon = NULL, onclick = paste0("Shiny.onInputChange(\"", ns("lin_umap"), "\", this.id)"))
# })
DT::datatable(lin_show, selection = 'none',
rownames=F,
editable = F,
options = list(
searching=T,
scrollX = TRUE,
columnDefs = list(list(width = '20%', targets = list(0,1,2)))
)
) %>% DT::formatStyle(columns = c(1),fontWeight = 'bold')
})
observeEvent(input$lin_gene, {
gene_row <- unlist(strsplit(as.character(input$lin_gene), "_", fixed = T))
if(length(gene_row) != 2) {
return()
}
gene <- gene_row[1]
row <- as.numeric(gene_row[2])
umap_id <- lineage_markers$UMAP[row]
updateTabsetPanel(session, "lin_tab", selected = "eui")
updateSelectInput(session, "input_sample", selected = umap_id)
updateSelectizeInput(session, "proj_colorBy", selected = "gene.expr")
updateSelectInput(session, "gene_list", selected = gene)
})
observeEvent(input$lin_umap, {
umap_row <- unlist(strsplit(as.character(input$lin_umap), "_", fixed = T))
row <- as.numeric(umap_row[length(umap_row)])
umap_id <- lineage_markers$UMAP[row]
updateTabsetPanel(session, "lin_tab", selected = "eui")
updateSelectInput(session, "input_sample", selected = umap_id)
})
output$download_lin_marker <- downloadHandler(
filename = function() {
'lineage_markers.xlsx'
},
content = function(con) {
write.xlsx(lineage_markers, file=con)
}
)
# Summary gene expression table
sm <- reactiveValues(gene = NULL, tbl = NULL)
output$sm_option <- renderUI({
input$sm_reset
if(tabset == "ct") {
cb_choice <- data.table::data.table(cell.bin = levels(ct_tbl$cell.bin))
} else {
cb_choice <- data.table::data.table(lineage = levels(lin_tbl$lineage))
}
ns <- session$ns
fluidRow(
column(6, selectizeInput(ns("sm_gene"), "Search gene:", choices = gene_tbl, multiple = T, options = list(placeholder = 'No gene selected'), selected = "pha-4")),
column(6, pickerInput(ns("sm_cellbin"),"Search cell:", choices=cb_choice, options = pickerOptions(actionsBox = TRUE,liveSearch = TRUE, virtualScroll = T, width = '100%', dropdownAlignRight = TRUE, style = "btn-picker", noneSelectedText = "No cell selected"),multiple = T))
#column(6, selectizeInput(ns("sm_cellbin"), "Search cell:", choices = cb_choice, multiple = T))
)
})
observe({
if(tabset == "ct") {
cur_tbl <- ct_tbl
sm$col <- "cell.bin"
} else {
cur_tbl <- lin_tbl
sm$col <- "lineage"
}
if(is.null(input$sm_cellbin) || length(input$sm_cellbin) == 0) {
cbins <- levels(cur_tbl[[sm$col]])
} else {
cbins <- input$sm_cellbin
}
if(length(input$sm_gene)) {
tbl <- cur_tbl %>% dplyr::filter(gene %in% input$sm_gene)
sm$tbl <- tbl[tbl[[sm$col]] %in% cbins, ]
sm$gene <- input$sm_gene
} else {
sm$tbl <- cur_tbl[cur_tbl[[sm$col]] %in% cbins,]
sm$gene <- gene_tbl[[1]]
}
})
output$sm_tbl <- DT::renderDataTable({
req(sm$gene)
DT::datatable(sm$tbl, selection = 'none',
rownames=F,
options = list(
searching=F,
scrollX = TRUE
#columnDefs = list(list(width = '20%', targets = list(0,1,2)))
)
)
#%>%DT::formatStyle(columns = c(1),fontWeight = 'bold')
})
output$download_sm_tbl <- downloadHandler(
filename = function() {
'summarized_expression.xlsx'
},
content = function(con) {
req(sm$tbl)
write.xlsx(sm$tbl, file=con)
}
)
output$sm_hmap_ui <- renderUI({
req(sm$gene)
if(length(sm$gene) > 500) {
return(tags$p("Do not support more than 500 genes."))
}
if(length(sm$gene) < 2 && length(unique(sm$tbl[[sm$col]])) < 2) {
return()
#return(tags$p("Minimal number of cell/gene is 2."))
}
ns <- session$ns
tagList(
fluidRow(
column(12,
circleButton(ns("hmap_config_reset"), icon = icon("undo"), size = "xs", status = "danger btn_rightAlign"),
shinyBS::bsTooltip(
ns("hmap_config_reset"),
title = "Reset heatmap configuration",
options = list(container = "body")
),
uiOutput(ns("hmap_configure_ui"))
)
),
uiOutput(ns("sm_hmap_plot"))
)
})
output$hmap_configure_ui <- renderUI({
ns <- session$ns
input$hmap_config_reset
dropdownButton2(inputId=ns("hmap_configure"),
selectInput(ns("hmap_color_pal"), "Heatmap color", choices=heatmap_palettes),
numericInput(ns("hmap_ploth"), "Height (resize window for width)", min=3, value = 5, step=1),
checkboxInput(ns("hmap_cluster_row"), "Cluster gene", T),
checkboxInput(ns("hmap_cluster_col"), "Cluster cell", T),
circle = T, label ="Configure Heatmap", tooltip=T, right = T,
icon = icon("cog"), size = "xs", status="primary", class = "btn_rightAlign")
})
output$sm_hmap_plot <- renderUI({
req(input$hmap_ploth)
ns <- session$ns
plotOutput(ns("sm_hmap"), height = paste0(100 *input$hmap_ploth,"px"))
})
output$sm_hmap <- renderPlot({
req(sm$gene)
cluster_rows <- ifelse(length(sm$gene) == 1, F, input$hmap_cluster_row)
cluster_cols <- ifelse(length(unique(sm$tbl[[sm$col]])) == 1, F, input$hmap_cluster_col)
expr_tbl<-sm$tbl[, c("gene",sm$col, "adjusted.tpm.estimate"), drop=F]
colnames(expr_tbl) <- c("gene","cell","expression")
expr_tbl<-reshape2::dcast(expr_tbl, gene~cell, value.var = "expression")
rownames(expr_tbl) <- expr_tbl$gene
expr_tbl$gene <- NULL
pheatmap(expr_tbl, cluster_rows = cluster_rows, cluster_cols = cluster_cols, color = get_numeric_color(input$hmap_color_pal))
})
output$sm_radio_ui <- renderUI({
req(sm$gene)
if(length(sm$gene) > 1) {
return(tags$p("Only one gene can be plotted at a time."))
}
ns <- session$ns
tagList(
fluidRow(
column(12,
circleButton(ns("radio_config_reset"), icon = icon("undo"), size = "xs", status = "danger btn_rightAlign"),
shinyBS::bsTooltip(
ns("radio_config_reset"),
title = "Reset plot configuration",
options = list(container = "body")
),
uiOutput(ns("radio_configure_ui"))
)
),
uiOutput(ns("sm_radio_plot"))
)
})
output$radio_configure_ui <- renderUI({
ns <- session$ns
input$radio_config_reset
dropdownButton2(inputId=ns("radio_configure"),
selectInput(ns("radio_color_pal"), "Heatmap Color", choices=heatmap_palettes),
numericInput(ns("radio_ploth"), "Height (resize window for width)", min=3, value = 9, step=1),
circle = T, label ="Configure radio plot", tooltip=T, right = T,
icon = icon("cog"), size = "xs", status="primary", class = "btn_rightAlign")
})
output$sm_radio_plot <- renderUI({
req(input$radio_ploth)
ns <- session$ns
plotOutput(ns("sm_radio"), height = paste0(100 *input$radio_ploth,"px"))
})
output$sm_radio <- renderPlot({
req(sm$gene, length(sm$gene == 1))
expr_tbl<-sm$tbl[, c("gene",sm$col, "adjusted.tpm.estimate"), drop=F]
colnames(expr_tbl) <- c("gene","cell","expression")
#assign("expr_tbl", expr_tbl, env=.GlobalEnv)
match_expr<-sapply(elin_match, function(x){
e_val<-expr_tbl$expression[which(expr_tbl$cell == x)]
if(length(e_val)) {
return(e_val)
} else {
return(NA)
}
})
g <- g_all %>% activate("nodes") %>%
mutate(scExprTPM = match_expr)
plot_col <- "scExprTPM"
t_cut <- 108
g<-g %>% activate("nodes") %>%
mutate(text.size = ifelse(time > t_cut, 0, 10/log10(time+1))) %>%
mutate(name = ifelse(time > t_cut, "", name)) %>%
filter(!(time > 200 & is.na(!!as.name(plot_col))))
range(as.data.frame(g)$text.size)
plotGraph(g, color.by=plot_col, pal=input$radio_color_pal, label="name", type = "numeric",border.size=.3, legend.title = sm$gene) +
theme(
axis.ticks.x=element_blank(),
axis.text.x=element_blank(),
axis.ticks.y=element_blank(),
axis.text.y=element_blank(),
legend.margin=margin(15,0,0,0),
legend.box.margin=margin(-10,-10,-10,-10),
plot.margin = unit(c(.3,.5,.3,.3), "cm"))
})
rval <- reactiveValues(mclass = NULL, cells=NULL, group_name=NULL, ulist = list())
return(rval)
}
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.