Skip to content
Permalink
main
Switch branches/tags

Name already in use

A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?

AlzApp/app.R

Go to file
 
 
Cannot retrieve contributors at this time
executable file 2723 lines (2395 sloc) 159 KB
Raw Blame
Open in GitHub Desktop
suppressMessages(suppressWarnings(library(shiny, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(shinythemes, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(shinyjs, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(shinycustomloader, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(shinybusy, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(waiter, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(ggplot2, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(ggrepel, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(ggalluvial, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(grid, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(tidyverse, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(DT, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(Seurat, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(rrvgo, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(Nebulosa, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(plotly, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(CellChat, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(stringr, warn.conflicts = FALSE, quietly=TRUE)))
suppressMessages(suppressWarnings(library(gprofiler2, warn.conflicts = FALSE, quietly=TRUE)))
#suppressMessages(suppressWarnings(library(clusterProfiler, warn.conflicts = FALSE, quietly=TRUE)))
#suppressMessages(suppressWarnings(library(enrichplot, warn.conflicts = FALSE, quietly=TRUE)))
#suppressMessages(suppressWarnings(library(DOSE, warn.conflicts = FALSE, quietly=TRUE)))
# Utility and plotting functions #######################################################################
# Convert cell type codes to their real names for plotting
setCellTypeNames <- function(df) {
df$CellType <- recode(as.factor(df$CellType),
"Ast"="Astrocytes",
"ExDp1"="Excitatory Deep Layer 1",
"ExDp2"="Excitatory Deep Layer 2",
"ExM"="Maturing Excitatory",
"ExM-U"="Maturing Exc Upper",
"ExN"="Newborn Excitatory",
"InCGE"="Interneurons CGE",
"InMGE"="Interneurons MGE",
"IP"="Intermediate Progenitors",
"OPC"="Oligodendrocyte Precursors",
"oRG"="Outer Radial Glia",
"PgG2M"="Cycling Progen. G2M Phase",
"PgS"="Cycling Progen. S Phase",
"vRG"="Ventricular Radial Glia")
return(df)}
# CellType Explorer Tab 3 Summary Plot generation
summaryPlot <- function(my_celltype,marker_genes.df,ngenes) {
genes.df <- marker_genes.df %>% dplyr::filter(celltype==my_celltype) %>% group_by(timepoint) %>%
dplyr::slice_min(n = ngenes, order_by = p_val)
p <- ggplot(genes.df, aes(x = timepoint, y = -log10(p_val),color = pct.1))+
geom_point() +
geom_text_repel(label = genes.df$gene,
max.overlaps = getOption("ggrepel.max.overlaps",
default = 30)) +
scale_x_continuous(breaks = c(2,4,6))+
labs(title = sprintf("Top %s genes differentially expressed between Mt and Wt at each timepoint, %s cells",
ngenes, my_celltype),
x = "Developmental timepoint (months)",y="Significance (-log10(pvalue))",
color = "Percent of Tau-mutant cells expressing") +
theme_bw() + guides(size='none')
return(p)
}
#####################################################################################
# Volcano Plots:
# put the biological significance (fold changes)
# and statistical significance (p-value) in one plot
# Generate the volcano plot
volcanoPlot <- function(results.df, fold_cutoff=0.5,
pvalue_cutoff=0.01, title =
"Volcano Plot of Gene Expression"){
# Inputs: ##############################################
# results.df: dataframe containing columns:
# 1) "geneIDs": gene IDs
# 2) "logFC": foldchange values from DE analysis
# 3) "logpval": log-transformed p-values from DE analysis
# fold cutoff: significance threshold to render visually on plot;
# denotes fold difference between mutant and wildtype
# also referred to as "biologial signal"
# p_value_cutoff: significance threshold to render visually on plot;
# denotes statistical significance
########################################################
# create factor denoting differential expression status
stats.df <- results.df %>% mutate(diffexpressed =
ifelse(logFC < -(fold_cutoff),
"Significant, downregulated in Tau-mutant cells",
ifelse(logFC > fold_cutoff,
"Significant, upregulated in Tau-mutant cells", "Significant")))
stats.df$diffexpressed <- as.factor(stats.df$diffexpressed)
# Base plot
plot <- ggplot(stats.df, aes(x = logFC, y = logpval, shape = diffexpressed,
col=percent_expressed, text = geneIDs)) +
geom_point() +
ggtitle(title) +
labs(y="-log10(pvalue)",color = "Percent of Tau-mutant cells expressing",
shape="Differential expression status") +
geom_vline(xintercept=c(-fold_cutoff, fold_cutoff), col="red") +
# scale_color_manual(values=c("black", "blue", "red"),
# name = "Differential expression\nstatus") +
theme_minimal()
return(plot)
}
#####################################################################################
DotPlotggSig <- function(input_gene, genes.df, cellcats.to.plot, log.scale=F,
dot.scale.factor = 15,
scale.min = 10,
scale.max = 100,
title = "Average expression by variant, over time") {
# prep data
res.gene <- genes.df %>% dplyr::filter(features.plot==all_of(input_gene)) %>%
dplyr::filter(CellType %in% cellcats.to.plot)
res.gene$Variant <- recode_factor(res.gene$Variant,"V337M" = "FTD-Tau mutant cells",
"V337V" = "Isogenic control cells")
# significance anaotations
res.gene <- res.gene %>% mutate(plot_annotation = ifelse(is.na(p_val),"","*"))
#res.gene <- setCellTypeNames(res.gene)
# set desired coloring variable
color.by <- ifelse(test = log.scale, yes = 'avg.exp.scaled',
no = 'avg.exp')
color.by.legend.text <- ifelse(test = log.scale,
yes = 'Average normalized expression\n(log1p-transformed)',
no = 'Average normalized expression')
# plot
dp <- ggplot(data = res.gene, mapping = aes(x = Timepoint, y = Variant)) +
geom_point(mapping = aes_string(size = 'pct.exp', color = color.by),na.rm=TRUE) +
geom_text(
aes( label = plot_annotation), nudge_y = 1.5,
size = 8, color = "black") +
scale_radius(range = c(0, dot.scale.factor), limits = c(scale.min, scale.max)) +
scale_color_gradient(low = "lightgray", high = "blue") +
guides(size = guide_legend(title = 'Percent Cells\nExpressing'),
color = guide_colorbar(title = color.by.legend.text)) +
labs(x = 'Developmental Timepoint', y = 'Condition', title=title,
caption = '* = significant difference in y-axis conditions at 0.01 threshold,
as found by differential expression testing with a generalized linear model for single-cell RNAseq data.') +
# faceting
facet_wrap(~CellType) +
# aesthetics
theme_linedraw()+
theme(plot.caption.position = "plot",
plot.caption = element_text(size = 14,hjust = 0),
strip.text = element_text(size = 14),
axis.text = element_text(size = 16),
legend.text = element_text(size = 16),
legend.title = element_text(size = 16),
plot.title = element_text(size=16),
axis.title=element_text(size=16)
)
return(dp)
}
#####################################################################################
# Logos and footer prep
# logos <- fixedRow(div(
# img(src="IDEA_Logo_WHITE.png",align="right",width="200px"),
# img(src="NSCI_Full_Logo.png",align="left",width="150px"))
# )
#####################################################################################
# Data read-in
# full dataset for all other app features
seurat.all <- readRDS("FinalMergedData-downsampled.rds")
# Switch active identities to cell type labels for plotting
Idents(seurat.all) <- "CellType"
# Data for main panel 1 bar graph
celltype_data_with_codes <- readRDS("FetchDataOutput-AllCells.rds") %>% relocate(CellType)
celltype_props <- readRDS("overall_celltype_props_data.rds")
# Average expression & percent expressed data for Gene Explorer line plots
res_combined_ann <- readRDS("average_expression_allcelltypes_timepoints_mtvswt_withpvals.rds")
# Average expression & percent expressed data for Gene Explorer dot plots
avg.pct.df <- readRDS("avgexp_pctexp_data_allgenes_alltimepoints_withpvals.rds")
# Marker gene statistics for Differential Expression Statistics Tab
data <- read.csv("DEgenes_MtvsWt_alltimepts_allcelltypes.csv")
# convert cell type codes to real names
celltype_data <- setCellTypeNames(celltype_data_with_codes)
celltype_props <- setCellTypeNames(celltype_props)
# Create gene selection list for Gene Explorer drop down
selection_genes <- c(VariableFeatures(seurat.all),unique(res_combined_ann$gene))
geneList <- rownames(seurat.all)
# Create celltype selection list for CellType Explorer drop down
celltypeList <- c("Astrocytes",
"Excitatory Deep Layer 1",
"Excitatory Deep Layer 2",
"Maturing Excitatory",
"Maturing Exc Upper",
"Newborn Excitatory",
"Intermediate Progenitors",
"Interneurons CGE",
"Interneurons MGE",
"Oligodendrocyte Precursors",
"Cycling Progen. G2M Phase",
"Cycling Progen. S Phase",
"Outer Radial Glia",
"Ventricular Radial Glia")
celltypeList2 <- c(celltypeList,"All")
ctcode_map <- list("Ast","ExDp1","ExDp2",
"ExM","ExM-U","ExN","IP","InCGE","InMGE",
"OPC","PgG2M","PgS","oRG","vRG")
names(ctcode_map) <- celltypeList
ctcode_list <- list("Ast","ExDp1","ExDp2",
"ExM","ExM-U","ExN","IP","InCGE","InMGE",
"OPC","PgG2M","PgS","oRG","vRG")
#celltype color mapping
colormap <- scales::hue_pal()(14)
names(colormap) <- ctcode_list
# Create selection list for cell lines
cLinesList <- c(levels(as.factor(seurat.all$Line)),"All")
# cell-cell communication data
#cellchat <- readRDS("cellchat.rds")
cellchat_2m <- readRDS("cellchat_2M.rds")
cellchat_2v <- readRDS("cellchat_2V.rds")
cellchat_4m <- readRDS("cellchat_4M.rds")
cellchat_4v <- readRDS("cellchat_4V.rds")
cellchat_6m <- readRDS("cellchat_6M.rds")
cellchat_6v <- readRDS("cellchat_6V.rds")
# cell net pathway data
#net_df <- read.csv(file = 'net_pathway.csv')
#net_df$prob <- format(net_df$prob, scientific = TRUE)
#colnames(net_df) <- c("X", "source", "target", "pathway", "prob", "pval")
net_pathway_2m <- read.csv(file = 'net_pathway_2m.csv')
net_pathway_2m$prob <- format(net_pathway_2m$prob, scientific = TRUE)
colnames(net_pathway_2m) <- c("X", "source", "target", "pathway", "prob", "pval")
net_pathway_2v <- read.csv(file = 'net_pathway_2v.csv')
net_pathway_2v$prob <- format(net_pathway_2v$prob, scientific = TRUE)
colnames(net_pathway_2v) <- c("X", "source", "target", "pathway", "prob", "pval")
net_pathway_4m <- read.csv(file = 'net_pathway_4m.csv')
net_pathway_4m$prob <- format(net_pathway_4m$prob, scientific = TRUE)
colnames(net_pathway_4m) <- c("X", "source", "target", "pathway", "prob", "pval")
net_pathway_4v <- read.csv(file = 'net_pathway_4v.csv')
net_pathway_4v$prob <- format(net_pathway_4v$prob, scientific = TRUE)
colnames(net_pathway_4v) <- c("X", "source", "target", "pathway", "prob", "pval")
net_pathway_6m <- read.csv(file = 'net_pathway_6m.csv')
net_pathway_6m$prob <- format(net_pathway_6m$prob, scientific = TRUE)
colnames(net_pathway_6m) <- c("X", "source", "target", "pathway", "prob", "pval")
net_pathway_6v <- read.csv(file = 'net_pathway_6v.csv')
net_pathway_6v$prob <- format(net_pathway_6v$prob, scientific = TRUE)
colnames(net_pathway_6v) <- c("X", "source", "target", "pathway", "prob", "pval")
# cell pathway names
#choices <- cellchat@netP$pathways
pathway_op <- read.csv(file = 'pathway_choices.csv')
# signaling pathway annotation
CellChatDB <- read.csv(file = 'CellChatDB.csv')
# comparative analysis of ccc conditions
ccc_comparsion_List <- c("tau-V337M organoids at two months",
"isogenic controls at two months",
"tau-V337M organoids at four months",
"isogenic controls at four months",
"tau-V337M organoids at six months",
"isogenic controls at six months")
setCCCNames <- function(df) {
df <- recode(as.factor(df),
"tau-V337M organoids at two months"="2M",
"isogenic controls at two months"="2V",
"tau-V337M organoids at four months"="4M",
"isogenic controls at four months"="4V",
"tau-V337M organoids at six months"="6M",
"isogenic controls at six months"="6V")
return(df)}
ccc_list <- c("Ast","ExDp1","ExDp2",
"ExM","ExM-U","ExN","IP","InCGE","InMGE",
"OPC","PgG2M","PgS","oRG","vRG")
# About page text ##############################################################
comments_link <- "<br><br><p>Thanks for using <b>FTD MINDER!</b></p><p>Please take a few moments
to fill out our short <a href='https://forms.gle/X6HrChvrSXChkRJq8'>comments form</a><br>or
submit programming-related suggestions and critiques to our
<a href='https://github.rpi.edu/DataINCITE/AlzApp/issues'>GitHub issue page.</a>
<br>We'd really welcome your feedback.</p>"
contacts <- "<p>Comments, questions and concerns can also be addressed directly to the developers
by emailing<br>rachael.white105@gmail.com.</p><br><br>"
whatisit_text <- "<br><p><b>FTD MINDER</b> is a dashboard-style application that exposes
the large dataset of single-cell RNA sequencing data from dementia-affected brain organoids presented in<br>
<a href='https://doi.org/10.1016/j.cell.2021.07.003'>ELAVL4, splicing, and glutamatergic dysfunction
precede neuron loss in MAPT mutation cerebral organoids</a><br>(Bowles et al. 2021).<br>
This study performed transcriptomic and physiological characterization of over 6,000 cerebral organoids
derived from three tau-V337M (<i>MAPT</i> gene) mutation carriers and respective isogenic CRISPR-corrected lines.<br>
We aim to enhance the accessibility of this large-scale NGS data to both the biology researcher and general user
for drawing biological insights by making it <b>browsable</b>-<br>that is,
by allowing the user to quicky and easily explore the data from multiple perspectives,
and to tailor their view of the data to their specific research focus.<br><br>
The current data-browsing features of our tool are by no means exaustive;
<br>we are adding new ones all the time, and open to suggestions!</p><br>"
background_text <-
"<p><b>FTD MINDER</b> is an ongoing project which was spearheaded in the Spring and Summer of 2022 by researchers at the
<a href ='https://www.neuralsci.org/'> Neural Stem Cell Institute</a> directed by Dr. Sally Temple,
in conjunction with researchers and students of
<a href='http://idea.rpi.edu/'>The Rensselaer Institute for Data Exploration
and Applications</a> at <a href='http://rpi.edu/'>Rensselaer Polytechnic Institute</a> co-directed by Drs. Kristin P. Bennett and John S. Erickson.
This collaboration was made possible with generous support from the NIA T-32 Alzheimer's Disease Clinical and
Translational Research (ADCTR) Training Program at RPI.
<br>The application was originally developed by student researchers with the Rensselaer IDEA
and is implemented on the <a href='https://shiny.rstudio.com/'>R Shiny platform</a>
for building interactive web apps with the R programming language.</p><br>"
GitHub_links <- "<p>Our source code is freely available at our <br><a href='https://github.rpi.edu/DataINCITE/AlzApp'>app production Github</a>.<br>
Additionally, learn more about the code, data preparation, and background furnishing FTD MINDER at our associated single-cell analysis <br><a href= 'https://github.rpi.edu/DataINCITE/AlzheimersDS'>teaching GitHub</a>.
</p><br><br>"
#####################################################################################
# App
ui <- navbarPage(title = tags$a(tags$script(HTML("var header = $('.navbar > .container-fluid');
header.append('<div style=\"float:right\"><a href=\"https://www.neuralsci.org\"><img src=\"NSCI_Full_Logo.png\" alt=\"alt\" style=\"float:right;width:153px;height:60px;\"> </a></div>');
console.log(header)")),
tags$script(HTML("var header = $('.navbar > .container-fluid');
header.append('<div style=\"float:right\"><a href=\"https://idea.rpi.edu\"><img src=\"IDEA_Logo_WHITE.png\" alt=\"alt\" style=\"float:right;width:190px;height:60px;padding-top:1px;padding-bottom:3px;\"> </a></div>');
console.log(header)"))),
windowTitle="FTD MINDER: Visualize FTD scRNAseq Data",
#shinythemes::themeSelector(),
theme = shinytheme("yeti"),
tabPanel(HTML(paste(h5("Overall Dataset"))),
add_busy_spinner(spin = "scaling-squares", position = "bottom-right", margins = c(36, 36)),
waiter::use_waiter(),
#useHostess(),
#waiterPreloader(spin_wave()),
waiterPreloader(html = div(spin_wave(), h4("Launching FTD Minder..."))),
# Application title
fixedRow(
column(8,offset=2,align="center",hr(),
h2("FTD MINDER"),
h3("Tool for Exploring scRNAseq Data from Frontotemporal Dementia Organoids"),
hr(),
h4("Use the \"Gene Explorer\",\"Cell Explorer\", and \"Differential Expression Statistics\" top-level views
to browse and visualize dataset trends."),
hr(),
HTML("<p>This application exposes
the large dataset of single-cell RNA sequencing data from dementia-affected brain organoids presented in<br>
<a href='https://doi.org/10.1016/j.cell.2021.07.003'>ELAVL4, splicing, and glutamatergic dysfunction
precede neuron loss in <em>MAPT</em> mutation cerebral organoids</a><br>(Bowles et al. 2021).<br><br>
Frontotemporal dementia (FTD) because of <em>MAPT</em> mutation causes pathological accumulation of tau and glutamatergic cortical neuronal death by unknown mechanisms.
This study used human induced pluripotent stem cell
(iPSC)-derived cerebral organoids expressing tau-V337M (MAPT mutant) and isogenic corrected controls to discover early
alterations because of the <em>MAPT</em> mutation that precede neurodegeneration in FTD. At 2 months, mutant organoids show
upregulated expression of a) <em>MAPT</em>, b) glutamatergic signaling pathways, and c) regulators, including the RNA-binding protein ELAVL4, as well as increased stress granules.
Over the following 4 months, mutant organoids accumulate splicing changes, disruption of autophagy function, and build-up of tau and P-tau-S396. By 6 months,
tau-V337M organoids showed specific loss of glutamatergic neurons as seen in individuals with FTD. Mutant
neurons are susceptible to glutamate toxicity, which can be rescued pharmacologically by the PIKFYVE kinase inhibitor apilimod.<br><br>In summary, this dataset encapsulates a sequence of cellular events that precede neurodegeneration,
revealing molecular pathways associated with glutamate signaling as potential targets for therapeutic intervention in FTD.</p>"),
hr())
),
fixedRow(
splitLayout(cellWidths = c("50%", "50%"),
cellArgs = list(style = "text-align:center;padding:15px"),
tagList(tags$p("Dimensional reduction plot of the full dataset of ~370,000 single cells, colored by neuronal cell type"),
plotOutput("CellFeaturePlot",height="450px",hover=hoverOpts(id="hover",delay=100))),
tagList(tags$p("Overall proportions of neuronal cell types represented at each sequencing timepoint"),
plotOutput("CellTypeBarPlot",height="450px"))
)
#, uiOutput("hoverTT")
)
),
tabPanel(HTML(paste(h5("Gene Explorer"))),
add_busy_spinner(spin = "scaling-squares", position = "bottom-right", margins = c(36, 36)),
tags$div(class="header", checked=NA,
tags$h4("Search for a gene below to visualize its expression trends in the overall dataset and over time."),
tags$em("Genes available for selection are the 40,096 genes detected in the complete Bowles scRNAseq dataset. The user should be precautioned that the extent of representation of individual genes can vary greatly."),
tags$hr()
),
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "gene",
label = "Gene",
choices = NULL),
#selected = c("APOE")),
style = "padding: 5px;"
),
# Show plots
tabsetPanel(
tabPanel(title = "Feature Plots",
#fixedRow(div(align = "center",tags$em("These plots use reduced versions of the data to aid visualization of expression trends."))),
fixedRow(
column(1, style='padding:0px;',
offset = 0,
align="center"),
column(7, align = "center",
div(align= "center", tags$p("Expression level mapped onto overall dataset of single cells, by variant and over time")),
uiOutput("GeneFeaturePlotConditional"),
plotOutput("GeneFeaturePlot",height = "1000px")),
column(3,
tags$p("Celltype distributions for comparison"),
plotOutput("CellTypeComparisonPlots1",height = "1000px"),align="center"),
column(1, style='padding:0px;',
offset = 0,
align="center")
),
hr(),
fixedRow(column(12, align="center",
h4("Visualize co-expression of two features simultaneously, by variant and over time.")
)
),
fluidRow(style = "padding-top:5px;",
column(3,
style='padding:0px;',
offset = 0,
align="center"
),
column(6,
style='padding:0px;',
offset = 0,
align="center",
wellPanel(align="left",
fixedRow(style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
column(6, style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
selectizeInput("gene_1", "Gene 1", choices = NULL)
),
column(6, style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
selectizeInput("gene_2", "Gene 2", choices = NULL)
),
),
style="padding-left: 2%; padding-right: 2%; padding-top: 0px; padding-bottom: 0px; width: 80%, height: 100%"
)
),
column(3,
style='padding:0px;',
offset = 0,
align="center"
)
),
fixedRow(
column(1),
column(7,
uiOutput("GeneFeaturePlotConditional2"),
plotOutput("CoExpressionPlots",height = "1000px"), align="center"),
column(3,
plotOutput("CellTypeComparisonPlots2",height = "950px"),align="center"),
column(1)
),
hr(),
fixedRow(div(align = "center",
tags$p("We generated these feature plots using a novel visualization approach, Nebulosa, to resolve sparsity based on gene-weighted kernel density estimation."),
tags$p("The joint density estimate visualizes the expression overlap of two genes, which allows a more precise identification of cell types based on combined expression of markers."),
a(href = "https://bioconductor.org/packages/release/bioc/vignettes/Nebulosa/inst/doc/nebulosa_seurat.html",
"Read more about Nebulosa here."))),hr()
),
tabPanel(title = "DotPlots of Average Expression Level",
fixedRow(column(12,align="center",
tags$p("Dot Plots of average gene expression levels and detection rates over time"),
)
),
sidebarLayout(
sidebarPanel(
selectInput('dotplot_celltypes', multiple = T,
label = "Select celltypes to plot:",
choices = ctcode_list,
selected = ctcode_list),
selectInput('dotplot_scale',
label = "Data scaling:",
choices = c("Unscaled",
"Natural log scale"),
selected = "Natural log scale"),
width = 3,
style = "padding: 15px;"
),
mainPanel(width = 8,
fixedRow( plotOutput("GeneDotPlot",height="700px",width="100%")),
style = "padding: 15px;"
)
),
hr(),
fixedRow(column(12,align="center",
tags$p("About this plot:"),
tags$p("Expression data shown for the selected gene is averaged, normalized counts
generated by applying
Seurat NormalizeData()."),
tags$p("User can choose whether to show these normalized counts
on the natural log scale or unscaled."),
tags$p("Gene detection percentages are the pre-calculated, within-group percentages
(where the groups are celltype + variant combined)."),
tags$p("Celltype selection is intended as a focus aid only;
percent expressed values shown will not change
based on the number of celltypes selected."),
HTML("<p><b>*</b> indicates significant difference in expression between V337M (FTD-Tau) and isogenic control cells
at an FDR-adjusted p-value threshold of 0.01,<br> as found by D.E. testing with the <a
href='https://genomebiology.biomedcentral.com/articles/10.1186/s13059-015-0844-5#:~:text=MAST%20accounts%20for%20the%20bimodality,or%20gene%20set%2Dbased%20statistics'>MAST</a>
generalized linear model for single-cell RNAseq data.</p>"))),
hr()
),
tabPanel(title = "Expression Over Time - Trendline Plots",
fixedRow(tags$p("Gene expression trajectory over time, colored by variant, and plotted separately for each cell type"),
uiOutput("GeneTrajecConditional"), align="center"),
fixedRow(plotOutput("CellTypesByVariant", height= "700px",width = "80%"), align="center"),
hr(),
fixedRow(align="center",
tags$p("About this plot:"),
HTML("<p><b>*</b> indicates significant difference in expression between V337M (FTD-Tau) and isogenic control cells at an FDR-adjusted p-value threshold of 0.01,<br> as found by D.E. testing with the <a
href='https://genomebiology.biomedcentral.com/articles/10.1186/s13059-015-0844-5#:~:text=MAST%20accounts%20for%20the%20bimodality,or%20gene%20set%2Dbased%20statistics'>MAST</a> hurdle model for scRNAseq data.</p>"),
HTML("<p> Expression data shown is averaged from raw counts then log-normalized, separately at each timepoint and within each celltype.</p>"),
hr()
)
),
tabPanel(title = "Expression Over Time - Violin Plots",
fixedRow(column(12,align="center",
tags$p("Expression data shown is original read counts, log-normalized separately at each timepoint. This data normalization mode is consistent with the data shown in the previous tab.")
)
),
hr(),
fixedRow( column(4,align="center", offset=4,
plotOutput("GeneVlnPlotOverall"))
),
fixedRow( style = "padding: 50px;",
column(4,align="center", plotOutput("GeneVlnPlotND")),
column(4,align="center", plotOutput("GeneVlnPlotG6")),
column(4,align="center", plotOutput("GeneVlnPlotG7"))
)
)
)
)
),
tabPanel(HTML(paste(h5("CellType Explorer"))),
add_busy_spinner(spin = "scaling-squares", position = "bottom-right", margins = c(36, 36)),
tags$div(class="header", checked=NA,
h4("Use the panels below to visualize celltype-level gene expression trends in the overall dataset."),
hr()
),
tabsetPanel(
tabPanel(title = "Feature Plots",
br(),
p("Browse the distributions of the major cell type categories represented in the overall dataset, by variant and over time."),
hr(),
fixedRow(column(4, offset=1,
selectInput(inputId = "celltype_to_highlight",
label = "Select a cell type to highlight its representation in the data:",
choices = c("All",ctcode_list),
selected = "All"),
),column(6)
),
fixedRow( style="padding:50px;",
column(6,align="center",plotOutput("CellTypeExplorerPlots1",height="1000px")),
column(6,align="center",plotOutput("CellTypeExplorerPlots2",height="900px"))
)
),
tabPanel(title= "Genes Differentially Expressed per Celltype (Overall)",
HTML("<p>Left, marker genes distinguishing this cell type from all other cell types represented in the dataset,
as ranked by average log2 fold change.<br>Right, <a href='https://journals.plos.org/plosone/article?id=10.1371/journal.pone.0021800'>REVIGO</a> semantic summarization of GO terms enriched
in the top 100 cell type marker genes.<br></p>"),
tags$hr(),
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "celltype",
label = "Select a cell type:",
choices = celltypeList),
dataTableOutput("celltypeTable"),
width = 6,
style = "padding: 15px;"
),
mainPanel(width = 6,
fixedRow(tagList(tags$p("Semantic summarization of enriched GO terms"),
plotOutput("REVIGOtree",height="450px",width="80%"))),
fixedRow(tagList(tags$p("Dot size, GO term significance."),
tags$p("Labels, most-populated reduced term categories."),
br(),br(),br(),
div(tags$p("Read more about REVIGO visualizations "),
a(href="http://revigo.irb.hr/FAQ.aspx#q01", "here.")
)
), style = "padding: 15px;"
)
)
)
),
tabPanel(title= "Cell-Cell Communication Analysis",
HTML("<p> Compute the inter-celltype communication probability and infer cellular communication network for a celltype of interest using <a href='https://github.com/sqjin/CellChat'>CellChat</a>.
<br>CellChat takes the gene expression data of cells as input, and combines the interaction of ligand receptor and its cofactors (from <a href='http://www.cellchat.org/cellchatdb/'>CellChatDB</a>) to simulate intercellular communication.<br>
Left, browse the ligand receptor interactions associated with each signal pathway ranked by their calculated communication probability.
Right, visualize how the cells of your celltype of interest interact with other celltype categories in the dataset.</p>"),
tags$hr(),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "cellchat",
label = "Select a cell type:",
choices = celltypeList),
selectInput(inputId = "cellchatmonth",
label = "Select a developmental timepoint:",
choices = c("2 months" = "2mo", "4 months" = "4mo", "6 months" = "6mo"),
selected = "2 months"),
selectInput(inputId = "cellchatvariant",
label = "Wildtype/mutant:",
choices = c("FTD-Tau-affected organoid cells" = "V337M", "CRISPR-corrected isogenic control" = "V337V"),
selected = "FTD-Tau-affected organoid cells"),
dataTableOutput("cellchatTable"),
width = 6,
style = "padding: 15px;"
),
mainPanel(width = 6,
fixedRow(tagList(tags$p("Display of cell-cell interaction across celltype categories."),
plotOutput("cellchatnet",height="560px",width="100%"))),
fixedRow(tagList(tags$p("Plot shows the specified celltype modeled as the ligand in all plotted interactions. The size of the circle of various colors in the periphery indicates the number of cells in that celltype category. The larger the circle, the more cells.
The cells that emit arrows express ligands, and the cells that the arrows point to express receptors. The more ligand-receptor pairs, the thicker the line.")
),
style = "padding: 15px;"
)
)
),
tags$hr(),
fluidRow(style = "padding-top:5px;",
column(3,
style='padding:0px;',
offset = 0,
align="center"
),
column(6,
style='padding:0px;',
offset = 0,
align="center",
wellPanel(align="left",
fixedRow(style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
column(12,
style='padding-left: 5px; padding-right: 0px; padding-top: 0px; padding-bottom: 0px;',
offset = 0,
align="left",
# selectizeInput('pathwayNames', "Select up to 3 genes",
# choices=NULL, selected=sample(top100,3), multiple=TRUE, options = list(placeholder ='Start typing gene name', maxItems = 3, plugins=list("remove_button")))
#selectizeInput('pathwayNames', "Select pathway to explore its communication network in the dataset",
#choices=NULL, multiple=FALSE, selected = NULL, options = list(maxItems = 1, plugins=list("remove_button")))
#uiOutput("pathway.out"),
selectInput("pathwayNames", label = "Select pathway to explore its communication network in the dataset",
choices = pathway_op$pathway,
selected = "PTN")
)
),
style="padding-left: 2%; padding-right: 2%; padding-top: 0px; padding-bottom: 0px; width: 80%, height: 100%"
)
),
column(3,
style='padding:0px;',
offset = 0,
align="center"
)
),
fixedRow(div(align = "center",
p("Left, cellular communication visualization outputs for different analytical tasks, showing the inferred intercellular communication network for selected signaling pathway."),
p("Right, more in-depth analyses of the inter-celltype communication."),
)),
fluidRow(style='padding:0px;',
column(7, style='padding:0px;', offset = 0, align="center",
tabsetPanel(id = "mainTab",
tabPanel("Hierarchy plot", plotOutput('aggregatePlot',height="500px")),
tabPanel("Heatmap", br(),
p("Heatmap of the relative importance of each cell group based on the computed four-network centrality measures of selected signaling pathway."),
plotOutput("heatmap",height="500px")),
tabPanel("Chord plot", plotOutput("chordPlot",height="500px")),
tabPanel("Circle plot", plotOutput("circlePlot",height="500px"))
)
),
column(5,
style='padding:0px;',
offset = 0,
align="center",
tabsetPanel(id = "AnalysisTab",
tabPanel("Key signaling roles", plotOutput("rolePlot",height="500px")),
tabPanel("Contribution of each L-R", br(),
p("Histogram of the relative contribution of each ligand-receptor pair to the overall communication network of selected signaling pathway,
which is the ratio of the total communication probability of the inferred network of each ligand-receptor pair to that of selected signaling pathway."),br(),
plotOutput("contributionPlot",height = "400px", width = "80%")),
tabPanel("Signaling gene distribution", plotOutput("distPlot",height="500px")),
tabPanel("Pathway annotation", DT::dataTableOutput("cellchatannotation"))
)
)
),
hr(),
fixedRow(column(6,align = "center",style='padding:20px;',
HTML("<p><b>Signaling Patterns: Prediction of key incoming and outgoing signals for specific cell types.</b><br>
Outgoing patterns reveal how the sender cells coordinate with each other,
as well as how they coordinate with certain signaling pathways to drive communication.
Incoming patterns show how the target cells coordinate with each other,
as well as how they coordinate with certain signaling pathways to respond to incoming signals.</p>")),
column(6,align = "center",style='padding:20px;',
HTML("<p><b>Functional and Structural Classification: Projecting signaling pathways onto a two-dimensional manifold according to their functional/structural
similarity</b>.<br>We can group signaling pathways by defining similarity measures and performing manifold
learning from both functional and topological perspectives.</p>")),
),
hr(),
fluidRow(style='padding:0px',
tags$hr(),
column(12,
style='padding:0px:',
align="center",
tabsetPanel(id = "Tab",
tabPanel("Signaling patterns in river plot", plotOutput("RiverOut", height = "500px")),
tabPanel("Signaling patterns in dot plot", plotOutput("DotOut", height = "500px")),
tabPanel("Functional classification", plotOutput("EmbedFunctional", height = "500px")),
tabPanel("Structural classification", plotOutput("EmbedStructural", height = "500px"))
)
)
),
hr(),
fixedRow(div(align = "center",
h4("Statistical Methods"),
HTML("<p>CellChat infers biologically significant cell-cell communication by assigning each interaction
with a probability value and peforming a permutation test.<br>
The probability of cell-cell communication is modeled by integrating gene expression<br> with prior
known knowledge of the interactions between signaling ligands, receptors and their cofactors, using the law of mass action.<br>
The number of inferred ligand-receptor pairs clearly depends on the method for calculating the average gene expression per cell group.
By default, CellChat uses a statistically robust mean method called ‘trimean’, which produces fewer interactions than other methods.</p>"),
a(href = "https://www.nature.com/articles/s41467-021-21246-9",
"Read more about CellChat here."))),hr()
),
tabPanel(title = "Comparative Analysis of CCC",
fixedRow(column(1,
style='padding:0px;',
offset = 0,
align="center"
),
column(10, align="center",
h4("Comparing cell-cell communication between two different biological conditions")
),
column(1,
style='padding:0px;',
offset = 0,
align="center"
)
),
fluidRow(style = "padding-top:5px;",
column(1,
style='padding:0px;',
offset = 0,
align="center"
),
column(10,
style='padding:0px;',
offset = 0,
align="center",
wellPanel(align="left",
fixedRow(style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
column(6, style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
selectizeInput("condition_1", "Condition 1", choices = NULL)
),
column(6, style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
#selectizeInput("condition_2", "Condition 2", choices = NULL)
uiOutput("condition2")
),
),
style="padding-left: 2%; padding-right: 2%; padding-top: 0px; padding-bottom: 0px; width: 80%, height: 100%"
)
),
column(1,
style='padding:0px;',
offset = 0,
align="center"
)
),
#fixedRow(
#column(1),
#column(5,
#plotOutput("NumberOfInteractionPlot",height = "500px"), align="center"),
#column(5,
#plotOutput("NumberOfInteractionHeatmap",height = "500px"), align="center"),
#column(1)
#),
fixedRow(div(align = "center",
p("By selecting two different biological conditions above, we can apply CellChat to identify major signaling changes through quantitative contrasts of cell-cell communication networks at these two conditions."),
p("Left, to find out whether the cell-cell communication is enhanced or not, we compare the the total number of interactions as well as interaction strength of
the inferred cell-cell communication networks from different biological conditions."),
p("Right, to identify the interaction between which cell populations showing significant changes, we visualize the differential number of interactions as well as
differential interaction strength in the cell-cell communication network between two conditions."),
)),
fluidRow(style='padding:0px;',
column(6, style='padding:0px;', offset = 0, align="center",
tabsetPanel(id = "InteractionTab",
tabPanel("Total number/strength of interactions by biological conditions", br(),
plotOutput('NumberOfInteractionPlot',height="500px"))
)
),
column(6,
style='padding:0px;',
offset = 0,
align="center",
tabsetPanel(id = "DifferentialTab",
tabPanel("Heatmap of differential number/strength of interactions", br(),
plotOutput("NumberOfInteractionHeatmap",height = "500px"))
)
)
),
hr(),
fixedRow(column(6,align = "center",style='padding:20px;',
HTML("<p><b>Compare the total number of interactions and interaction strength</b><br>
When comparing cell-cell communication between two different biological conditions,
we can find out whether the cell-cell communication is enhanced or not.
The bar plot on the left shows the number of inferred interactions at two selected conditions ,
while the bar plot on the right compares the interaction strength between two selected conditions.</p>")),
column(6,align = "center",style='padding:20px;',
HTML("<p><b>Compare the differential number of interactions and interaction strength among different cell groups</b><br>
In the colorbar, red represents increased signaling in the second condition, as compared to the first one condition,
while blue represents decreased signaling in the second condition, as compared to the first one.
The top colored bar plot represents the sum of column of values displayed in the heatmap, which is incoming signaling.
The right colored bar plot represents the sum of row of values, which is outgoing signaling.</p>")),
),
hr(),
fixedRow(column(1,
style='padding:0px;',
offset = 0,
align="center"
),
column(10, align="center",
h4("Comparing the cell-cell communication networks based on the defined cell groups.")
),
column(1,
style='padding:0px;',
offset = 0,
align="center"
)
),
fluidRow(style = "padding-top:5px;",
column(1,
style='padding:0px;',
offset = 0,
align="center"
),
column(10,
style='padding:0px;',
offset = 0,
align="center",
wellPanel(align="left",
fixedRow(style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
column(11, style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
selectizeInput("source_cell", "Select three different cell groups to visualize", choices = NULL, multiple = TRUE, options = list(maxItems = 3))
),
column(1, style='margin-top: 22px; padding-right:5px; padding-left: 0px; padding-top: 0px; padding-bottom: 0px;',
offset = 0,
align="center",
#style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
#selectizeInput("condition_2", "Condition 2", choices = NULL)
actionButton("action", "Go")
),
),
style="padding-left: 2%; padding-right: 2%; padding-top: 0px; padding-bottom: 0px; width: 80%, height: 100%"
)
),
column(1,
style='padding:0px;',
offset = 0,
align="center"
)
),
fixedRow(
column(1),
column(10,
plotOutput("interact_1",height = "500px"), align="center"),
column(1)
),
tags$hr(),
fixedRow(column(1),
column(10,align = "center",style='padding:20px;',
HTML("<p><b>Differential number of interactions among selected cell types</b><br>
To simplify the complicated network and gain insights into the cell-cell communication at the cell type level,
we can aggregate the cell-cell communication networks based on the defined cell groups.
On the left, the cell-cell communication network among the three selected cell types visualizes the number of interactions at condition one.
On the right, the cell-cell communication network among the three selected cell types visualizes the number of interactions at condition two.
Note that the edge colors are consistent with the sources as sender.</p>")),
column(1)
),
hr(),
fixedRow(column(1,
style='padding:0px;',
offset = 0,
align="center"
),
column(10, align="center",
h4("Comparing the cell-cell communication networks based on the defined signaling pathway.")
),
column(1,
style='padding:0px;',
offset = 0,
align="center"
)
),
fluidRow(style = "padding-top:5px;",
column(1,
style='padding:0px;',
offset = 0,
align="center"
),
column(10,
style='padding:0px;',
offset = 0,
align="center",
wellPanel(align="left",
fixedRow(style='padding-left: 5px; padding-right: 5px; padding-top: 0px; padding-bottom: 0px;',
column(12,
style='padding-left: 5px; padding-right: 0px; padding-top: 0px; padding-bottom: 0px;',
offset = 0,
align="left",
# selectizeInput('pathwayNames', "Select up to 3 genes",
# choices=NULL, selected=sample(top100,3), multiple=TRUE, options = list(placeholder ='Start typing gene name', maxItems = 3, plugins=list("remove_button")))
#selectizeInput('pathwayNames', "Select pathway to explore its communication network in the dataset",
#choices=NULL, multiple=FALSE, selected = NULL, options = list(maxItems = 1, plugins=list("remove_button")))
#uiOutput("pathway.out"),
selectInput("pathways", label = "Select one pathway to compare the signaling network between two conditions",
choices = pathway_op$pathway,
selected = "PTN")
)
),
style="padding-left: 2%; padding-right: 2%; padding-top: 0px; padding-bottom: 0px; width: 80%, height: 100%"
)
),
column(1,
style='padding:0px;',
offset = 0,
align="center"
)
),
fixedRow(
column(1),
column(10,
plotOutput("interact_2",height = "500px"), align="center"),
column(1)
),
hr(),
fixedRow(column(1),
column(10,align = "center",style='padding:20px;',
HTML("<p><b>Visually compare cell-cell communication networks of the selected signaling pathway</b><br>
On the left, the chord diagram shows the cell-cell communication network of the selected signaling pathway at condition one.
On the right, the chord diagram shows the cell-cell communication network of the selected signaling pathway at condition two.
In the chord diagram, edge colors are consistent with the sources as sender, and edge weights are proportional to the interaction strength.
Note that the inner thinner bar colors represent the targets that receive signal from the corresponding outer bar,
and the inner bar size is proportional to the signal strength received by the targets.</p>")),
column(1)
),
hr()
)
)
),
tabPanel(HTML(paste(h5("Differential Expression Statistics"))),
add_busy_spinner(spin = "scaling-squares", position = "bottom-right", margins = c(36, 36)),
tags$div( class="header",
h4("Browse genes differentially expressed in FTD-mutant cells vs. isogenic controls.")
),
hr(),
fluidRow(div(style = "padding: 15px;",
HTML("<p>Genes represented are those found to be significantly differentially expressed between V337M (FTD-Tau) and isogenic control cells within the respective celltype and timepoint, as found by D.E. testing with the <a
href='https://genomebiology.biomedcentral.com/articles/10.1186/s13059-015-0844-5#:~:text=MAST%20accounts%20for%20the%20bimodality,or%20gene%20set%2Dbased%20statistics'>MAST</a> hurdle model.</p>"),
HTML("<p>The genes shown are those found to have FDR-adjusted p-values less than 0.01. The authors of the MAST framework also recommend using a magnitude log2 fold change cutoff of >= 1.5 for designating significance.</p>"),
HTML("<p>Selecting a specific cell type displays a summary plot below the table.</p>"),
a(href="https://github.rpi.edu/DataINCITE/AlzheimersDS/blob/main/dev-notebooks/overall-DE-analysis-each-timepoint-allcelltypes.pdf", "Link to the workflow and code used to generate these statistics."),
hr()
)
),
wellPanel(
# Create a row for selectInputs
fluidRow(
column(3,
selectInput("time",
"Developmental Timepoint (Month):",
c("All","2","4","6"))
),
column(3,
selectInput("ct",
"CellType:",
c("All",
unique(as.character(data$celltype))))
),
column(3,
selectizeInput("gene2",
"Gene:",
choices=NULL)
),
column(3,
numericInput(
inputId = "pval",
label = "P-Value Threshold (max 0.01):",
value = 0.01,
max = 0.01,
min = 1E-260
)
)
)
),
wellPanel(
# Create a row for the table
DT::dataTableOutput("table")
),
fluidRow( column(4,
downloadButton("downloadData", "Download selected data")
),
column(8,
style='padding:0px;',
offset = 0,
align="center"
)
),
hr(),
fluidRow( column(6,
plotlyOutput("VolcanoPlots", height = "500px")
),
column(6,
plotOutput("DEsummary", height = "500px")
)
),
hr(),
fixedRow(column(1,
style='padding:0px;',
offset = 0,
align="center"
),
column(10, align="center",
h4("Visualization of Gene Set functional Enrichment Analysis Results")
),
column(1,
style='padding:0px;',
offset = 0,
align="center"
)
),
fluidRow(
column(6,
plotlyOutput("manhattanplot", height = "500px")
),
column(6,
plotOutput("enrichmentplot", height = "500px")
)
),
hr(),
fixedRow(column(6,align = "center",style='padding:20px;',
HTML("<p><b>Interactive Manhattan plot: visualization of functional enrichment results</b><br>
The x-axis of the plot shows the terms and y-axis of the plot shows the enrichment P-values on log(10) scale.
Each circle corresponds to a single term. The circles are colored according to the annotation source, and
size of the circles is scaled according to the total number of genes annotated to the corresponding term.
The top graph shows the functional enrichment results of down-regulated genes based on the selected cell type and time point,
while the bottom graph shows the functional enrichment results of up-regulated genes based on the selections.</p>")),
column(6,align = "center",style='padding:20px;',
HTML("<p><b>Gene ontology enrichment bar chart of DEGs showing top 15 enriched GO terms </b><br>
Bar plot is the most widely used method to visualize enriched terms. It depicts the enrichment scores (adjusted P-values)
and the number of enriched DEGs as bar height and color, and the y-axis shows the enriched GO terms. The top 15 significant enriched terms
is displayed and they are splitted by up-regulated and down-regulated genes.</p>")),
),
hr()
),
# About page
tabPanel(
#HTML("<div>About</div>"),
#value = "about",
HTML(paste(h5("About"))),
fluidRow(column(
8,
style = "text-align:center;font-weight:bold;background-color: #EBEBEB;",
tags$h2("FTD Minder:"),
tags$h3("A Single-Cell RNAseq Data Browser"),
offset = 2
)),
fluidRow(column(6,offset=3,
div(align="center",
tags$h3("About the Project"),
tags$h4("Inspirations"),
HTML(whatisit_text),
tags$h4("Background"),
HTML(background_text),
tags$h4("Source"),
HTML(GitHub_links)
)
)
)
),
# Feedback page
tabPanel(
#HTML("<div>About</div>"),
#value = "about",
HTML(paste(h5("Comments & Suggestions"))),
fluidRow(column(8,offset = 2,
style = "text-align:center;font-weight:bold;background-color: #EBEBEB;",
tags$h3("How to Leave Us Feedback"),
)
),
fluidRow(column(6,offset=3,
div(align="center",
HTML(comments_link),
HTML(contacts),
)
)
)
),
# User survey
tabPanel(
#HTML("<div>About</div>"),
#value = "about",
HTML(paste(h5("BETA TESTING SURVEY"))),
fluidRow(column(8,offset = 2,
style = "height:500px;text-align:center;font-weight:bold;",
HTML("<h4><b>Please find our User Study Feedback Survey at the link below:</b></h4>"),
a("https://forms.gle/7yxtEMHZErbK9Duf6")
)
)
)
)
# Define server logic
server <- function(input, output, session) {
#Sys.sleep(5)
# Data prep
###########################################################
# Fetch input values
updateSelectizeInput(session, 'gene', choices = geneList, selected = "APOE", server=T)
updateSelectizeInput(session, 'gene_1', choices = geneList, selected = "APOE",server=T)
updateSelectizeInput(session, 'gene2', choices = c(geneList,"All"), selected = "All", server=T)
updateSelectizeInput(session, 'celltype', choices = celltypeList,server=T)
updateSelectizeInput(session, 'condition_1', choices = ccc_comparsion_List, selected = "tau-V337M organoids at two months",server=T)
#updateSelectizeInput(session, 'source_cell', choices = ctcode_map, server=T)
# Tab 1: Overall Trends
###########################################################
# Plot UMAP visual colored by celltype
output$CellFeaturePlot <- renderPlot({
celltype_data <- celltype_data %>%
dplyr::filter(CellType %in% celltypeList)
plot <- ggplot(celltype_data,aes_string(x = 'UMAP_1', y = 'UMAP_2', color = 'CellType')) +
geom_point(size = 0.5, alpha = 0.1) +
scale_colour_discrete(name = "Cell Type") +
xlab("UMAP 1") + ylab("UMAP 2") +
guides(colour = guide_legend(override.aes = list(size=4,alpha=1),byrow=T)) +
theme(legend.text = element_text(size=16), legend.title=element_text(size=16),
legend.spacing.y = unit(0.9, 'cm')) +
coord_fixed(ratio = 1) +
theme_linedraw()
#coord_fixed(xlim=c(-11,11),ylim=c(-11,11)) +
plot
})
# Plot overall celltype proportions with a stacked barplot
output$CellTypeBarPlot <- renderPlot({
ggplot(celltype_props, aes(x = Age, y=freq, fill = CellType)) +
geom_col() +
labs(
x = "Developmental Timepoint of Organoid Cells",
y = "Proportion of Cells", fill="Cell Type" ) +
guides(fill = guide_legend(override.aes = list(size=4,alpha=1),byrow=T)) +
theme(legend.text = element_text(size=16),
legend.title=element_text(size=16),
legend.spacing.y = unit(0.9, 'cm')) +
theme_linedraw()
})
# Tab 2: Gene Explorer
###########################################################
# Plot UMAPS colored by input gene expression level with plot_density
output$GeneFeaturePlot <- renderPlot({
if(input$gene %in% selection_genes) {
# use notification
plot1 <- plot_density(seurat.all, input$gene, size = 2) +
facet_grid(seurat.all$Age~recode_factor(seurat.all$Mt,"V337M"="FTD-Tau mutant cells", "V337V" = "Isogenic control cells")) +
# adjust plot aspect ratio
coord_fixed(ratio = 1) +
# specify a name for the associated legend
labs(color= "Expression\nDensity Estimate") +
ggtitle(sprintf("Scatterplots of single cells, colored by kernel-density estimation of %s expression signals", input$gene)) +
theme_linedraw() +
theme(strip.text = element_text(size = 16),
plot.title = element_text(size=14),
axis.title=element_text(size=16))
plot1
}
})
output$CellTypeComparisonPlots1 <- renderPlot({
plot <- DimPlot(seurat.all, split.by = "Age",
label = T,label.size = 6,
repel =T, ncol = 1) +
coord_fixed(ratio = 1) +
theme_linedraw() +
theme(legend.position ="none",plot.title.position = "plot")+
ggtitle("") + theme(strip.text = element_text(size = 16),
plot.title = element_text(size=16),
axis.title=element_text(size=16))
plot
})
output$CellTypeComparisonPlots2 <- renderPlot({
plot <- DimPlot(seurat.all, split.by = "Age",
label = T,label.size = 6,
repel =T, ncol = 1) +
coord_fixed(ratio = 1) +
theme_linedraw() +
theme(legend.position ="none",plot.title.position = "plot")+
ggtitle("") + theme(strip.text = element_text(size = 16),
plot.title = element_text(size=16),
axis.title=element_text(size=16))
plot
})
observeEvent(input$gene_1,{
updateSelectizeInput(session,'gene_2',
choices = geneList[!(geneList %in% input$gene_1)],
selected = "MAPT",
server=T)
})
output$CoExpressionPlots <- renderPlot({
cogenes <- c(input$gene_1, input$gene_2)
if(all(cogenes %in% selection_genes)) {
coexpressplot <- plot_density(seurat.all, c(input$gene_1, input$gene_2), joint = TRUE, size = 2) +
facet_grid(seurat.all$Age~recode_factor(seurat.all$Mt,"V337M"="FTD-Tau mutant cells", "V337V" = "Isogenic control cells")) +
# adjust plot aspect ratio
coord_fixed(ratio = 1) +
# specify a name for the associated legend
labs(color= "Joint\nExpression Density") +
ggtitle(sprintf("Scatterplots of single cells, colored by kernel-density estimation of %s + %s expression density overlap", input$gene_1,input$gene_2)) +
theme_linedraw() + theme(strip.text = element_text(size = 16),
plot.title = element_text(size=14),
axis.title=element_text(size=16))
coexpressplot[[3,3]]
}
})
# plot expression of input gene over time for each celltype by variant
# as line graphs
output$CellTypesByVariant <- renderPlot({
# only plot if gene is in
# the list of genes we have stats for
if(input$gene %in% selection_genes) {
#Plot the average expressions over time for each celltype by variant
res.gene <- res_combined_ann %>% dplyr::filter(gene==all_of(input$gene)) %>%
dplyr::filter(celltype %in% ctcode_map) %>%
mutate(plot_annotation = ifelse(!is.na(p_val),"*",""))
res.gene$Mt <- recode_factor(res.gene$Mt,"V337M" = "FTD-Tau mutant cells", "V337V" = "Isogenic control cells")
colnames(res.gene)[3] <- "CellType"
res.gene <- setCellTypeNames(res.gene)
res.gene <- res.gene %>% arrange(CellType)
# coerce x-axis values *manually* from factor to numeric for plotting
#(just doing as.numeric loses the correct values)
ggplot(res.gene,aes(x=as.numeric(as.character(timepoint)), y=avg_expr, col=Mt, by=Mt)) +
geom_line(size=2) +
geom_point(size=3) +
geom_text(
aes(label = plot_annotation, x=as.numeric(as.character(timepoint)),
y = 0.9*(max(avg_expr))
),
size = 8,
color = "black") +
scale_x_continuous(breaks=c(2,4,6),labels=c("2mo","4mo","6mo")) +
scale_color_manual(values=c("tomato2","steelblue2")) +
labs(title= sprintf("Average %s expression, by celltype and over time",input$gene),
x="Developmental timepoint (months)",
y = "Average expression",color = "Variant") +
# Use facet_wrap to make a separate plot for each cluster
facet_wrap(~CellType, nrow=3) +
# adjust spacing between facet plots
#theme(panel.spacing = unit(3, "cm")) +
theme_linedraw() +
theme(plot.caption.position = "plot",
plot.caption = element_text(hjust = 0.5),
strip.text = element_text(size = 14),
legend.text = element_text(size = 16),
legend.title = element_text(size = 16),
plot.title = element_text(size=16),
axis.title=element_text(size=16)
)
}
})
# Plot expression distributions of input gene by time point
# as grouped violin plots
output$GeneVlnPlotOverall <- renderPlot({
# Manual plotting mode
# Forced to use FetchData() here because data plotted
# depends on reactive input value input$gene
# gene_plot_data <- FetchData(seurat.all, c('Age','Mt','CellType',input$gene)) %>% filter(CellType %in% ctcode_map)
# gene_plot_data$Mt <- recode_factor(gene_plot_data$Mt,"V337M" = "FTD-Tau mutant cells", "V337V" = "Isogenic control cells")
# gene_plot_data <- setCellTypeNames(gene_plot_data)
#
# vln_df <- gene_plot_data
# noise <- rnorm(n = length(x = vln_df[, input$gene])) / 100000
# vln_df[, input$gene] <- vln_df[, input$gene] + noise
#
# ggplot(vln_df, aes(x=Age, y=.data[[input$gene]], fill=Mt)) +
# geom_violin(adjust =1,trim=TRUE, scale = "width") + scale_fill_manual(values=c("tomato2","steelblue2"),name="Variant") +
# facet_wrap(~CellType,nrow=3) +
# labs(x="Developmental Timepoint",y="Expression Level") +
# theme_linedraw()
# Seurat plotting mode
VlnPlot(seurat.all,
features = c(input$gene),
# use non-normalized counts data
assay= "RNA",
slot="counts",
# use only the 14 major celltypes
idents = ctcode_map,
#normalize; plot data on log scale
log=T,
# group and split organization
group.by = "Age",
split.by = "Mt",
#ncol=3,
same.y.lims=T,
split.plot=T) +
labs(x="Developmental Timepoint",y="Expression Level (Log2 scale)", fill="Variant") +
ggtitle(sprintf("%s expression distributions over time, full dataset",input$gene)) +
theme_linedraw() + theme(strip.text = element_text(size = 20),
plot.title = element_text(size=14),
axis.title=element_text(size=16)) +
scale_fill_manual(labels = c("FTD-Tau mutant cells","Isogenic control cells"),
values=c("V337M"="tomato2","V337V"="steelblue2"))
})
# Plot expression distributions of input gene by time point
# as grouped violin plots, by cell line
output$GeneVlnPlotND <- renderPlot({
# Seurat plotting mode
VlnPlot(subset(seurat.all,subset=Line=="NDlines"),
cols=c("tomato2","steelblue2"),
features = c(input$gene),
# use non-normalized counts data
assay= "RNA",
slot="counts",
# use only the 14 major celltypes
idents = ctcode_map,
#normalize; plot data on log scale
log=T,
# group ad split organization
group.by = "Age",
split.by = "Mt",
split.plot = T,
same.y.lims=T) +
labs(x="Developmental Timepoint",y="Expression Level (Log2 scale)", fill="Variant") +
ggtitle(sprintf("%s expression distributions over time, ND cell lines",input$gene)) +
theme_linedraw() + theme(strip.text = element_text(size = 20),
plot.title = element_text(size=14),
axis.title=element_text(size=16)) +
scale_fill_manual(labels = c("FTD-Tau mutant cells","Isogenic control cells"),
values=c("V337M"="tomato2","V337V"="steelblue2"))
})
# Plot expression distributions of input gene by time point
# as grouped violin plots, by cell line
output$GeneVlnPlotG6 <- renderPlot({
# Seurat plotting mode
VlnPlot(subset(seurat.all,subset=Line=="G6lines"),
cols=c("tomato2","steelblue2"),
features = c(input$gene),
# use non-normalized counts data
assay= "RNA",
slot="counts",
# use only the 14 major celltypes
idents = ctcode_map,
#normalize; plot data on log scale
log=T,
# group ad split organization
group.by = "Age",
split.by = "Mt",
split.plot = T,
same.y.lims=T) +
labs(x="Developmental Timepoint",y="Expression Level (Log2 scale)", fill="Variant") +
ggtitle(sprintf("%s expression distributions over time, G6 cell lines",input$gene)) +
theme_linedraw() + theme(strip.text = element_text(size = 20),
plot.title = element_text(size=14),
axis.title=element_text(size=16))+
scale_fill_manual(labels = c("FTD-Tau mutant cells","Isogenic control cells"),
values=c("V337M"="tomato2","V337V"="steelblue2"))
})
# Plot expression distributions of input gene by time point
# as grouped violin plots, by cell line
output$GeneVlnPlotG7 <- renderPlot({
# Seurat plotting mode
VlnPlot(subset(seurat.all,subset=Line=="G7lines"),
cols=c("tomato2","steelblue2"),
features = c(input$gene),
# use non-normalized counts data
assay= "RNA",
slot="counts",
# use only the 14 major celltypes
idents = ctcode_map,
#normalize; plot data on log scale
log=T,
# group ad split organization
group.by = "Age",
split.by = "Mt",
split.plot = T,
same.y.lims=T) +
labs(x="Developmental Timepoint",y="Expression Level (Log2 scale)", fill="Variant") +
ggtitle(sprintf("%s expression distributions over time, G7 cell lines",input$gene)) +
theme_linedraw() + theme(strip.text = element_text(size = 20),
plot.title = element_text(size=14),
axis.title=element_text(size=16))+
scale_fill_manual(labels = c("FTD-Tau mutant cells","Isogenic control cells"),
values=c("V337M"="tomato2","V337V"="steelblue2"))
})
output$GeneDotPlot <- renderPlot({
scale = T
if (input$dotplot_scale == "Unscaled") {scale=F}
p <- DotPlotggSig(input_gene=input$gene, cellcats.to.plot = c(input$dotplot_celltypes),
genes.df = avg.pct.df,
log.scale=scale,
dot.scale.factor = 15,
scale.min = 10,
scale.max = 100,
title = sprintf("Average %s expression by variant, over time",
input$gene))
p
})
# Tab 3: CellType Explorer
###########################################################
# Plot UMAP visual colored by celltype, faceted by age and variant
output$CellTypeExplorerPlots1 <- renderPlot({
celltype_data$Mt <- recode_factor(celltype_data$Mt,
"V337M"="FTD-Tau mutant cells",
"V337V"="Isogenic control cells")
celltype_data <- celltype_data %>% dplyr::filter(CellType %in% celltypeList)
ggplot(celltype_data,aes_string(x = 'UMAP_1', y = 'UMAP_2', color="CellType")) +
# render scatterplot, optionally adjust point size
geom_point(size = 0.8,alpha=0.5) +
# adjust plot aspect ratio
coord_fixed(ratio = 1) +
# specify color gradient and a name for the associated legend
scale_colour_discrete(name = "Cell Type") +
# set plot labels
xlab("UMAP 1") + ylab("UMAP 2")+
ggtitle("Distributions of identified cell types, by variant and over time.")+
facet_grid(Age~Mt) +
theme_linedraw() +
theme(legend.text = element_text(size=10),
legend.title=element_blank(),
legend.position="bottom",
strip.text = element_text(size=18),
plot.title = element_text(size=15),
axis.title=element_text(size=16)) +
guides(color = guide_legend(override.aes = list(size = 4,alpha=1)))
})
# Plot UMAP visual colored by celltype, faceted by age and variant
output$CellTypeExplorerPlots2 <- renderPlot({
if(input$celltype_to_highlight!="All") {
celltype_data_with_codes <- celltype_data_with_codes %>% dplyr::filter(CellType %in% ctcode_list)
celltype_data_with_codes$Mt <- recode_factor(celltype_data_with_codes$Mt,
"V337M"="FTD-Tau mutant cells",
"V337V"="Isogenic control cells")
# convert celltype name input to code for plotting
ct_code <- as.character(input$celltype_to_highlight)
# don't really know if this is necessary
celltype_data_with_codes$CellType <- as.character(celltype_data_with_codes$CellType)
ggplot(celltype_data_with_codes,aes(x = UMAP_1, y = UMAP_2)) +
# render scatterplot, optionally adjust point size
#plot unhighligted points
geom_point(size = 0.8, color = "snow2") +
#plot highlighted points
geom_point(data=celltype_data_with_codes[celltype_data_with_codes$CellType==ct_code,],
aes(x = UMAP_1, y = UMAP_2), size = 0.8, color = colormap[[ct_code]]) +
# adjust plot aspect ratio
coord_fixed(ratio = 1) +
# set plot labels
xlab("UMAP 1") + ylab("UMAP 2")+
ggtitle(sprintf("Distribution of %s cells in the full dataset, by variant over time",
ct_code)) +
theme_linedraw() +
theme(strip.text = element_text(size = 16),
plot.title = element_text(size=16),
axis.title=element_text(size=16)) +
facet_grid(Age~Mt)
}
})
# Show table of cell type marker genes
output$celltypeTable <- DT::renderDataTable(DT::datatable({
# prep data to show based on user-selected celltype
ct_select <- input$celltype
ct_code <- ctcode_map[[ct_select]]
ct_data_to_show <- readRDS(sprintf("celltype_marker_genes_%s.rds",ct_code))
showdata <- tibble::rownames_to_column(ct_data_to_show, "Gene")
showdata <- showdata %>% dplyr::select(Gene,avg_log2FC,p_val)
showdata
}) %>% DT::formatSignif(columns = c(2,3), 4))
output$REVIGOtree <- renderPlot({
ct_select <- input$celltype
ct_code <- ctcode_map[[ct_select]]
# File read-in must be here because data depends on a reactive input value
reducedTerms <- readRDS(sprintf("REVIGO_reducedTerms_%s.rds",ct_code))
# treemapPlot(reducedTerms,title=sprintf("Summary of enriched Gene Ontology terms in %s cells, all timepoints.",ct_code),
# fontsize.title=10)
treemapPlot(reducedTerms)
})
output$cellchatTable <- DT::renderDataTable(DT::datatable({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
cellchatdata_2m <- net_pathway_2m %>% dplyr::select(-X)
data_2m <- cellchatdata_2m[cellchatdata_2m$source == cell_code,]
data_to_show_2m <- subset(data_2m, pathway %in% pathway_op$pathway)
data_to_show_2m$pval <- sort(data_to_show_2m$pval)
return(data_to_show_2m)
}
if (input$cellchatvariant == "V337V") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
cellchatdata_2v <- net_pathway_2v %>% dplyr::select(-X)
data_2v <- cellchatdata_2v[cellchatdata_2v$source == cell_code,]
data_to_show_2v <- subset(data_2v, pathway %in% pathway_op$pathway)
data_to_show_2v$pval <- sort(data_to_show_2v$pval)
return(data_to_show_2v)
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
cellchatdata_4m <- net_pathway_4m %>% dplyr::select(-X)
data_4m <- cellchatdata_4m[cellchatdata_4m$source == cell_code,]
data_to_show_4m <- subset(data_4m, pathway %in% pathway_op$pathway)
data_to_show_4m$pval <- sort(data_to_show_4m$pval)
return(data_to_show_4m)
}
if (input$cellchatvariant == "V337V") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
cellchatdata_4v <- net_pathway_4v %>% dplyr::select(-X)
data_4v <- cellchatdata_4v[cellchatdata_4v$source == cell_code,]
data_to_show_4v <- subset(data_4v, pathway %in% pathway_op$pathway)
data_to_show_4v$pval <- sort(data_to_show_4v$pval)
return(data_to_show_4v)
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
cellchatdata_6m <- net_pathway_6m %>% dplyr::select(-X)
data_6m <- cellchatdata_6m[cellchatdata_6m$source == cell_code,]
data_to_show_6m <- subset(data_6m, pathway %in% pathway_op$pathway)
data_to_show_6m$pval <- sort(data_to_show_6m$pval)
return(data_to_show_6m)
}
if (input$cellchatvariant == "V337V") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
cellchatdata_6v <- net_pathway_6v %>% dplyr::select(-X)
data_6v <- cellchatdata_6v[cellchatdata_6v$source == cell_code,]
data_to_show_6v <- subset(data_6v, pathway %in% pathway_op$pathway)
data_to_show_6v$pval <- sort(data_to_show_6v$pval)
return(data_to_show_6v)
}
}
}) %>% DT::formatSignif(columns = c(4,5),4))
output$cellchatnet <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
groupSize_2m <- as.numeric(table(cellchat_2m@idents))
mat_2m <- cellchat_2m@net$weight
mat2_2m <- matrix(0, nrow = nrow(mat_2m), ncol = ncol(mat_2m), dimnames = dimnames(mat_2m))
mat2_2m[cell_code, ] <- mat_2m[cell_code, ]
netVisual_circle(mat2_2m, vertex.weight = groupSize_2m, weight.scale = T, edge.weight.max = max(mat_2m), title.name = cell_code)
}
if (input$cellchatvariant == "V337V") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
groupSize_2v <- as.numeric(table(cellchat_2v@idents))
mat_2v <- cellchat_2v@net$weight
mat2_2v <- matrix(0, nrow = nrow(mat_2v), ncol = ncol(mat_2v), dimnames = dimnames(mat_2v))
mat2_2v[cell_code, ] <- mat_2v[cell_code, ]
netVisual_circle(mat2_2v, vertex.weight = groupSize_2v, weight.scale = T, edge.weight.max = max(mat_2v), title.name = cell_code)
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
groupSize_4m <- as.numeric(table(cellchat_4m@idents))
mat_4m <- cellchat_4m@net$weight
mat2_4m <- matrix(0, nrow = nrow(mat_4m), ncol = ncol(mat_4m), dimnames = dimnames(mat_4m))
mat2_4m[cell_code, ] <- mat_4m[cell_code, ]
netVisual_circle(mat2_4m, vertex.weight = groupSize_4m, weight.scale = T, edge.weight.max = max(mat_4m), title.name = cell_code)
}
if (input$cellchatvariant == "V337V") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
groupSize_4v <- as.numeric(table(cellchat_4v@idents))
mat_4v <- cellchat_4v@net$weight
mat2_4v <- matrix(0, nrow = nrow(mat_4v), ncol = ncol(mat_4v), dimnames = dimnames(mat_4v))
mat2_4v[cell_code, ] <- mat_4v[cell_code, ]
netVisual_circle(mat2_4v, vertex.weight = groupSize_4v, weight.scale = T, edge.weight.max = max(mat_4v), title.name = cell_code)
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
groupSize_6m <- as.numeric(table(cellchat_6m@idents))
mat_6m <- cellchat_6m@net$weight
mat2_6m <- matrix(0, nrow = nrow(mat_6m), ncol = ncol(mat_6m), dimnames = dimnames(mat_6m))
mat2_6m[cell_code, ] <- mat_6m[cell_code, ]
netVisual_circle(mat2_6m, vertex.weight = groupSize_6m, weight.scale = T, edge.weight.max = max(mat_6m), title.name = cell_code)
}
if (input$cellchatvariant == "V337V") {
cell_select <- input$cellchat
cell_code <- ctcode_map[[cell_select]]
groupSize_6v <- as.numeric(table(cellchat_6v@idents))
mat_6v <- cellchat_6v@net$weight
mat2_6v <- matrix(0, nrow = nrow(mat_6v), ncol = ncol(mat_6v), dimnames = dimnames(mat_6v))
mat2_6v[cell_code, ] <- mat_6v[cell_code, ]
netVisual_circle(mat2_6v, vertex.weight = groupSize_6v, weight.scale = T, edge.weight.max = max(mat_6v), title.name = cell_code)
}
}
})
#output$pathway.out <- renderUI({
#selectInput("pathwayNames", label = "Select pathway to explore its communication network in the dataset",
#choices = pathway_op[pathway_op$age == input$cellchatmonth & pathway_op$group == input$cellchatvariant,] %>% dplyr::select(pathway),
#selected = "PTN")
#})
output$aggregatePlot <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_2m, signaling = pathways.show, vertex.receiver = vertex.receiver, layout = "hierarchy", title.space = 3)
}
if (input$cellchatvariant == "V337V") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_2v, signaling = pathways.show, vertex.receiver = vertex.receiver, layout = "hierarchy", title.space = 3)
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_4m, signaling = pathways.show, vertex.receiver = vertex.receiver, layout = "hierarchy", title.space = 3)
}
if (input$cellchatvariant == "V337V") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_4v, signaling = pathways.show, vertex.receiver = vertex.receiver, layout = "hierarchy", title.space = 3)
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_6m, signaling = pathways.show, vertex.receiver = vertex.receiver, layout = "hierarchy", title.space = 3)
}
if (input$cellchatvariant == "V337V") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_6v, signaling = pathways.show, vertex.receiver = vertex.receiver, layout = "hierarchy", title.space = 3)
}
}
})
output$heatmap <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
print(netVisual_heatmap(cellchat_2m, signaling = pathways.show, color.heatmap = "Reds"))
}
if (input$cellchatvariant == "V337V") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
print(netVisual_heatmap(cellchat_2v, signaling = pathways.show, color.heatmap = "Reds"))
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
print(netVisual_heatmap(cellchat_4m, signaling = pathways.show, color.heatmap = "Reds"))
}
if (input$cellchatvariant == "V337V") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
print(netVisual_heatmap(cellchat_4v, signaling = pathways.show, color.heatmap = "Reds"))
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
print(netVisual_heatmap(cellchat_6m, signaling = pathways.show, color.heatmap = "Reds"))
}
if (input$cellchatvariant == "V337V") {
vertex.receiver = seq(1,10)
pathways.show <- input$pathwayNames
print(netVisual_heatmap(cellchat_6v, signaling = pathways.show, color.heatmap = "Reds"))
}
}
})
output$rolePlot <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
print(netAnalysis_signalingRole_scatter(cellchat_2m, signaling = pathways.show))
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
print(netAnalysis_signalingRole_scatter(cellchat_2v, signaling = pathways.show))
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
print(netAnalysis_signalingRole_scatter(cellchat_4m, signaling = pathways.show))
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
print(netAnalysis_signalingRole_scatter(cellchat_4v, signaling = pathways.show))
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
print(netAnalysis_signalingRole_scatter(cellchat_6m, signaling = pathways.show))
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
print(netAnalysis_signalingRole_scatter(cellchat_6v, signaling = pathways.show))
}
}
})
output$distPlot <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
print(plotGeneExpression(cellchat_2m, signaling = pathways.show))
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
print(plotGeneExpression(cellchat_2v, signaling = pathways.show))
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
print(plotGeneExpression(cellchat_4m, signaling = pathways.show))
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
print(plotGeneExpression(cellchat_4v, signaling = pathways.show))
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
print(plotGeneExpression(cellchat_6m, signaling = pathways.show))
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
print(plotGeneExpression(cellchat_6v, signaling = pathways.show))
}
}
})
output$contributionPlot <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
print(netAnalysis_contribution(cellchat_2m, signaling = pathways.show, font.size = 12, font.size.title = 14))
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
print(netAnalysis_contribution(cellchat_2v, signaling = pathways.show, font.size = 12, font.size.title = 14))
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
print(netAnalysis_contribution(cellchat_4m, signaling = pathways.show, font.size = 12, font.size.title = 14))
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
print(netAnalysis_contribution(cellchat_4v, signaling = pathways.show, font.size = 12, font.size.title = 14))
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
print(netAnalysis_contribution(cellchat_6m, signaling = pathways.show, font.size = 12, font.size.title = 14))
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
print(netAnalysis_contribution(cellchat_6v, signaling = pathways.show, font.size = 12, font.size.title = 14))
}
}
})
output$chordPlot <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_2m, signaling = pathways.show, layout = "chord")
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_2v, signaling = pathways.show, layout = "chord")
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_4m, signaling = pathways.show, layout = "chord")
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_4v, signaling = pathways.show, layout = "chord")
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_6m, signaling = pathways.show, layout = "chord")
}
if (input$cellchatvariant == "V337V") {
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_6v, signaling = pathways.show, layout = "chord")
}
}
})
output$circlePlot <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
vertex.receiver = seq(1,10)
groupSize_m2 <- as.numeric(table(cellchat_2m@idents))
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_2m, signaling = pathways.show, layout = "circle", vertex.receiver = vertex.receiver,
vertex.size = groupSize_m2, pt.title = 14, title.space = 4)
}
if (input$cellchatvariant == "V337V") {
vertex.receiver = seq(1,10)
groupSize_v2 <- as.numeric(table(cellchat_2v@idents))
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_2v, signaling = pathways.show, layout = "circle", vertex.receiver = vertex.receiver,
vertex.size = groupSize_v2, pt.title = 14, title.space = 4)
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
vertex.receiver = seq(1,10)
groupSize_m4 <- as.numeric(table(cellchat_4m@idents))
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_4m, signaling = pathways.show, layout = "circle", vertex.receiver = vertex.receiver,
vertex.size = groupSize_m4, pt.title = 14, title.space = 4)
}
if (input$cellchatvariant == "V337V") {
vertex.receiver = seq(1,10)
groupSize_v4 <- as.numeric(table(cellchat_4v@idents))
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_4v, signaling = pathways.show, layout = "circle", vertex.receiver = vertex.receiver,
vertex.size = groupSize_v4, pt.title = 14, title.space = 4)
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
vertex.receiver = seq(1,10)
groupSize_m6 <- as.numeric(table(cellchat_6m@idents))
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_6m, signaling = pathways.show, layout = "circle", vertex.receiver = vertex.receiver,
vertex.size = groupSize_m6, pt.title = 14, title.space = 4)
}
if (input$cellchatvariant == "V337V") {
vertex.receiver = seq(1,10)
groupSize_v6 <- as.numeric(table(cellchat_6v@idents))
pathways.show <- input$pathwayNames
netVisual_aggregate(cellchat_6v, signaling = pathways.show, layout = "circle", vertex.receiver = vertex.receiver,
vertex.size = groupSize_v6, pt.title = 14, title.space = 4)
}
}
})
output$RiverOut <- renderPlot({
river1_2m <- netAnalysis_river(cellchat_2m, pattern = "outgoing", font.size = 4, font.size.title = 14)
river2_2m <- netAnalysis_river(cellchat_2m, pattern = "incoming", font.size = 4, font.size.title = 14)
cowplot::plot_grid(river1_2m, river2_2m, ncol=2)
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
river1_2m <- netAnalysis_river(cellchat_2m, pattern = "outgoing", font.size = 4, font.size.title = 14)
river2_2m <- netAnalysis_river(cellchat_2m, pattern = "incoming", font.size = 4, font.size.title = 14)
print(cowplot::plot_grid(river1_2m, river2_2m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
river1_2v <- netAnalysis_river(cellchat_2v, pattern = "outgoing", font.size = 4, font.size.title = 14)
river2_2v <- netAnalysis_river(cellchat_2v, pattern = "incoming", font.size = 4, font.size.title = 14)
print(cowplot::plot_grid(river1_2v, river2_2v, ncol=2))
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
river1_4m <- netAnalysis_river(cellchat_4m, pattern = "outgoing", font.size = 4, font.size.title = 14)
river2_4m <- netAnalysis_river(cellchat_4m, pattern = "incoming", font.size = 4, font.size.title = 14)
print(cowplot::plot_grid(river1_4m, river2_4m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
river1_4v <- netAnalysis_river(cellchat_4v, pattern = "outgoing", font.size = 4, font.size.title = 14)
river2_4v <- netAnalysis_river(cellchat_4v, pattern = "incoming", font.size = 4, font.size.title = 14)
print(cowplot::plot_grid(river1_4v, river2_4v, ncol=2))
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
river1_6m <- netAnalysis_river(cellchat_6m, pattern = "outgoing", font.size = 4, font.size.title = 14)
river2_6m <- netAnalysis_river(cellchat_6m, pattern = "incoming", font.size = 4, font.size.title = 14)
print(cowplot::plot_grid(river1_6m, river2_6m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
river1_6v <- netAnalysis_river(cellchat_6v, pattern = "outgoing", font.size = 4, font.size.title = 14)
river2_6v <- netAnalysis_river(cellchat_6v, pattern = "incoming", font.size = 4, font.size.title = 14)
print(cowplot::plot_grid(river1_6v, river2_6v, ncol=2))
}
}
})
output$DotOut <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
dot1_2m <- netAnalysis_dot(cellchat_2m, pattern = "outgoing", font.size = 12, font.size.title = 14)
dot2_2m <- netAnalysis_dot(cellchat_2m, pattern = "incoming", font.size = 12, font.size.title = 14)
print(cowplot::plot_grid(dot1_2m, dot2_2m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
dot1_2v <- netAnalysis_dot(cellchat_2v, pattern = "outgoing", font.size = 12, font.size.title = 14)
dot2_2v <- netAnalysis_dot(cellchat_2v, pattern = "incoming", font.size = 12, font.size.title = 14)
print(cowplot::plot_grid(dot1_2v, dot2_2v, ncol=2))
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
dot1_4m <- netAnalysis_dot(cellchat_4m, pattern = "outgoing", font.size = 12, font.size.title = 14)
dot2_4m <- netAnalysis_dot(cellchat_4m, pattern = "incoming", font.size = 12, font.size.title = 14)
print(cowplot::plot_grid(dot1_4m, dot2_4m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
dot1_4v <- netAnalysis_dot(cellchat_4v, pattern = "outgoing", font.size = 12, font.size.title = 14)
dot2_4v <- netAnalysis_dot(cellchat_4v, pattern = "incoming", font.size = 12, font.size.title = 14)
print(cowplot::plot_grid(dot1_4v, dot2_4v, ncol=2))
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
dot1_6m <- netAnalysis_dot(cellchat_6m, pattern = "outgoing", font.size = 12, font.size.title = 14)
dot2_6m <- netAnalysis_dot(cellchat_6m, pattern = "incoming", font.size = 12, font.size.title = 14)
print(cowplot::plot_grid(dot1_6m, dot2_6m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
dot1_6v <- netAnalysis_dot(cellchat_6v, pattern = "outgoing", font.size = 12, font.size.title = 14)
dot2_6v <- netAnalysis_dot(cellchat_6v, pattern = "incoming", font.size = 12, font.size.title = 14)
print(cowplot::plot_grid(dot1_6v, dot2_6v, ncol=2))
}
}
})
output$EmbedFunctional <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
func1_2m <- netVisual_embedding(cellchat_2m, type = "functional", label.size = 4, title = "Functiional classification of signaling networks")
func1Zoom_2m <- netVisual_embeddingZoomIn(cellchat_2m, type = "functional", label.size = 5, nCol = 2)
print(cowplot::plot_grid(func1_2m, func1Zoom_2m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
func1_2v <- netVisual_embedding(cellchat_2v, type = "functional", label.size = 4, title = "Functiional classification of signaling networks")
func1Zoom_2v <- netVisual_embeddingZoomIn(cellchat_2v, type = "functional", label.size = 5, nCol = 2)
print(cowplot::plot_grid(func1_2v, func1Zoom_2v, ncol=2))
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
func1_4m <- netVisual_embedding(cellchat_4m, type = "functional", label.size = 4, title = "Functiional classification of signaling networks")
func1Zoom_4m <- netVisual_embeddingZoomIn(cellchat_4m, type = "functional", label.size = 5, nCol = 2)
print(cowplot::plot_grid(func1_4m, func1Zoom_4m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
func1_4v <- netVisual_embedding(cellchat_4v, type = "functional", label.size = 4, title = "Functiional classification of signaling networks")
func1Zoom_4v <- netVisual_embeddingZoomIn(cellchat_4v, type = "functional", label.size = 5, nCol = 2)
print(cowplot::plot_grid(func1_4v, func1Zoom_4v, ncol=2))
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
func1_6m <- netVisual_embedding(cellchat_6m, type = "functional", label.size = 4, title = "Functiional classification of signaling networks")
func1Zoom_6m <- netVisual_embeddingZoomIn(cellchat_6m, type = "functional", label.size = 5, nCol = 2)
print(cowplot::plot_grid(func1_6m, func1Zoom_6m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
func1_6v <- netVisual_embedding(cellchat_6v, type = "functional", label.size = 4, title = "Functiional classification of signaling networks")
func1Zoom_6v <- netVisual_embeddingZoomIn(cellchat_6v, type = "functional", label.size = 5, nCol = 2)
print(cowplot::plot_grid(func1_6v, func1Zoom_6v, ncol=2))
}
}
})
output$EmbedStructural <- renderPlot({
if (input$cellchatmonth == "2mo") {
if (input$cellchatvariant == "V337M") {
struct1_2m <- netVisual_embedding(cellchat_2m, type = "structural", label.size = 4, title = "Structural classification of signaling networks")
struct1Zoom_2m <- netVisual_embeddingZoomIn(cellchat_2m, type = "structural", label.size = 5, nCol = 2)
print(cowplot::plot_grid(struct1_2m, struct1Zoom_2m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
struct1_2v <- netVisual_embedding(cellchat_2v, type = "structural", label.size = 4, title = "Structural classification of signaling networks")
struct1Zoom_2v <- netVisual_embeddingZoomIn(cellchat_2v, type = "structural", label.size = 5, nCol = 2)
print(cowplot::plot_grid(struct1_2v, struct1Zoom_2v, ncol=2))
}
}
if (input$cellchatmonth == "4mo") {
if (input$cellchatvariant == "V337M") {
struct1_4m <- netVisual_embedding(cellchat_4m, type = "structural", label.size = 4, title = "Structural classification of signaling networks")
struct1Zoom_4m <- netVisual_embeddingZoomIn(cellchat_4m, type = "structural", label.size = 5, nCol = 2)
print(cowplot::plot_grid(struct1_4m, struct1Zoom_4m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
struct1_4v <- netVisual_embedding(cellchat_4v, type = "structural", label.size = 4, title = "Structural classification of signaling networks")
struct1Zoom_4v <- netVisual_embeddingZoomIn(cellchat_4v, type = "structural", label.size = 5, nCol = 2)
print(cowplot::plot_grid(struct1_4v, struct1Zoom_4v, ncol=2))
}
}
if (input$cellchatmonth == "6mo") {
if (input$cellchatvariant == "V337M") {
struct1_6m <- netVisual_embedding(cellchat_6m, type = "structural", label.size = 4, title = "Structural classification of signaling networks")
struct1Zoom_6m <- netVisual_embeddingZoomIn(cellchat_6m, type = "structural", label.size = 5, nCol = 2)
print(cowplot::plot_grid(struct1_6m, struct1Zoom_6m, ncol=2))
}
if (input$cellchatvariant == "V337V") {
struct1_6v <- netVisual_embedding(cellchat_6v, type = "structural", label.size = 4, title = "Structural classification of signaling networks")
struct1Zoom_6v <- netVisual_embeddingZoomIn(cellchat_6v, type = "structural", label.size = 5, nCol = 2)
print(cowplot::plot_grid(struct1_6v, struct1Zoom_6v, ncol=2))
}
}
})
output$cellchatannotation <- DT::renderDataTable(DT::datatable({
outputdata <- CellChatDB %>% dplyr::select(-X)
data_out <- outputdata[outputdata$pathway_name == input$pathwayNames, ]
data_out
}))
#observeEvent(input$condition_1,{
#if (is.null(input$condition_2)) {
#updateSelectizeInput(session,'condition_2',
#choices = ccc_comparsion_List[!(ccc_comparsion_List %in% input$condition_1)],
#selected = "isogenic controls at two months",
#server=T)
#} else {
#updateSelectizeInput(session,'condition_2',
#choices = ccc_comparsion_List,
#selected = "",
#server=T)
#}
#})
#observeEvent(input$condition_1,{
#updateSelectizeInput(session,'condition_2',
#choices = ccc_comparsion_List[!(ccc_comparsion_List %in% input$condition_1)],
#selected = "isogenic controls at two months",
#server=T)
#})
output$condition2 <- renderUI({
selectInput(inputId="condition_2",
label="Condition 2",
ccc_comparsion_List[!(ccc_comparsion_List %in% input$condition_1)],
selected = input$condition_2)
})
observeEvent(input$condition_2,{
updateSelectizeInput(session,'condition_1',
choices = ccc_comparsion_List[!(ccc_comparsion_List %in% input$condition_2)],
selected = input$condition_1,
server=T)
})
output$NumberOfInteractionPlot <- renderPlot({
req(input$condition_1, input$condition_2)
cond_1 <- setCCCNames(input$condition_1)
cond_2 <- setCCCNames(input$condition_2)
my_data_1 <- readRDS(sprintf("cellchat_%s%s.rds",str_extract_all(cond_1, "[0-9]+"), str_extract_all(cond_1, "[aA-zZ]+")))
file_names <- paste0('cellchat_', cond_2, '.rds')
my_data_2 <- readRDS(file_names)
#my_data_2 <- readRDS(sprintf("cellchat_%s%s.rds",str_extract_all(cond_2, "[0-9]+"), str_extract_all(cond_2, "[aA-zZ]+")))
name_1 <- as.character(input$condition_1)
name_2 <- as.character(input$condition_2)
object.list <- dplyr::lst(!!name_1 := my_data_1, !!name_2 := my_data_2)
cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
gg1 <- compareInteractions(cellchat_compare, show.legend = F, group = c(1,2))
gg2 <- compareInteractions(cellchat_compare, show.legend = F, group = c(1,2), measure = "weight")
gg1 + gg2
})
output$NumberOfInteractionHeatmap <- renderPlot({
req(input$condition_1, input$condition_2)
cond_1 <- setCCCNames(input$condition_1)
cond_2 <- setCCCNames(input$condition_2)
my_data_1 <- readRDS(sprintf("cellchat_%s%s.rds",str_extract_all(cond_1, "[0-9]+"), str_extract_all(cond_1, "[aA-zZ]+")))
file_names <- paste0('cellchat_', cond_2, '.rds')
my_data_2 <- readRDS(file_names)
#my_data_2 <- readRDS(sprintf("cellchat_%s%s.rds",str_extract_all(cond_2, "[0-9]+"), str_extract_all(cond_2, "[aA-zZ]+")))
name_1 <- as.character(input$condition_1)
name_2 <- as.character(input$condition_2)
object.list <- dplyr::lst(!!name_1 := my_data_1, !!name_2 := my_data_2)
cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
hh1 <- netVisual_heatmap(cellchat_compare)
hh2 <- netVisual_heatmap(cellchat_compare, measure = "weight")
hh1 + hh2
})
updateSelectizeInput(session, 'source_cell', choices = ctcode_map, selected = c("Ast", "oRG", "OPC"), server = TRUE)
mydata <- reactiveValues(
#cellgroup = c("Ast", "oRG", "OPC")
cellgroup = sample(ctcode_map, 3)
)
observeEvent(input$action, {
if (is.null(input$source_cell)) {
updateSelectizeInput(session, 'source_cell', choices = ctcode_map, selected = c("Ast", "oRG", "OPC"), server=T)
mydata$cellgroup <- input$source_cell
}
mydata$cellgroup <- input$source_cell
})
interaction_circ <- eventReactive(mydata$cellgroup, {
req(input$condition_1, input$condition_2)
cond_1 <- setCCCNames(input$condition_1)
cond_2 <- setCCCNames(input$condition_2)
my_data_1 <- readRDS(sprintf("cellchat_%s%s.rds",str_extract_all(cond_1, "[0-9]+"), str_extract_all(cond_1, "[aA-zZ]+")))
#my_data_2 <- readRDS(sprintf("cellchat_%s%s.rds",str_extract_all(cond_2, "[0-9]+"), str_extract_all(cond_2, "[aA-zZ]+")))
if (cond_2 == "2M") {
my_data_2 <- readRDS("cellchat_2M.rds")
name_1 <- as.character(input$condition_1)
name_2 <- as.character(input$condition_2)
object.list <- dplyr::lst(!!name_1 := my_data_1, !!name_2 := my_data_2)
cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
myd <- mydata$cellgroup
group.cellType <- c(rep(myd[1], 4), rep(myd[2], 4), rep(myd[3], 4))
group.cellType <- factor(group.cellType, levels = c(myd[1], myd[2], myd[3]))
object.list <- lapply(object.list, function(x) {mergeInteractions(x, group.cellType)})
cellchat_diff <- mergeCellChat(object.list, add.names = names(object.list))
weight.max <- getMaxWeight(object.list, slot.name = c("idents", "net", "net"), attribute = c("idents","count", "count.merged"))
par(mfrow = c(1,2), xpd=TRUE)
for (i in 1:length(object.list)) {
netVisual_circle(object.list[[i]]@net$count.merged, weight.scale = T, label.edge= T, edge.weight.max = weight.max[3], edge.width.max = 12, title.name = paste0("Number of interactions - ", names(object.list)[i]))
}
}
if (cond_2 == "2V") {
my_data_2 <- readRDS("cellchat_2V.rds")
name_1 <- as.character(input$condition_1)
name_2 <- as.character(input$condition_2)
object.list <- dplyr::lst(!!name_1 := my_data_1, !!name_2 := my_data_2)
cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
myd <- mydata$cellgroup
group.cellType <- c(rep(myd[1], 4), rep(myd[2], 4), rep(myd[3], 4))
group.cellType <- factor(group.cellType, levels = c(myd[1], myd[2], myd[3]))
object.list <- lapply(object.list, function(x) {mergeInteractions(x, group.cellType)})
cellchat_diff <- mergeCellChat(object.list, add.names = names(object.list))
weight.max <- getMaxWeight(object.list, slot.name = c("idents", "net", "net"), attribute = c("idents","count", "count.merged"))
par(mfrow = c(1,2), xpd=TRUE)
for (i in 1:length(object.list)) {
netVisual_circle(object.list[[i]]@net$count.merged, weight.scale = T, label.edge= T, edge.weight.max = weight.max[3], edge.width.max = 12, title.name = paste0("Number of interactions - ", names(object.list)[i]))
}
}
if (cond_2 == "4M") {
my_data_2 <- readRDS("cellchat_4M.rds")
name_1 <- as.character(input$condition_1)
name_2 <- as.character(input$condition_2)
object.list <- dplyr::lst(!!name_1 := my_data_1, !!name_2 := my_data_2)
cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
myd <- mydata$cellgroup
group.cellType <- c(rep(myd[1], 4), rep(myd[2], 4), rep(myd[3], 4))
group.cellType <- factor(group.cellType, levels = c(myd[1], myd[2], myd[3]))
object.list <- lapply(object.list, function(x) {mergeInteractions(x, group.cellType)})
cellchat_diff <- mergeCellChat(object.list, add.names = names(object.list))
weight.max <- getMaxWeight(object.list, slot.name = c("idents", "net", "net"), attribute = c("idents","count", "count.merged"))
par(mfrow = c(1,2), xpd=TRUE)
for (i in 1:length(object.list)) {
netVisual_circle(object.list[[i]]@net$count.merged, weight.scale = T, label.edge= T, edge.weight.max = weight.max[3], edge.width.max = 12, title.name = paste0("Number of interactions - ", names(object.list)[i]))
}
}
if (cond_2 == "4V") {
my_data_2 <- readRDS("cellchat_4V.rds")
name_1 <- as.character(input$condition_1)
name_2 <- as.character(input$condition_2)
object.list <- dplyr::lst(!!name_1 := my_data_1, !!name_2 := my_data_2)
cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
myd <- mydata$cellgroup
group.cellType <- c(rep(myd[1], 4), rep(myd[2], 4), rep(myd[3], 4))
group.cellType <- factor(group.cellType, levels = c(myd[1], myd[2], myd[3]))
object.list <- lapply(object.list, function(x) {mergeInteractions(x, group.cellType)})
cellchat_diff <- mergeCellChat(object.list, add.names = names(object.list))
weight.max <- getMaxWeight(object.list, slot.name = c("idents", "net", "net"), attribute = c("idents","count", "count.merged"))
par(mfrow = c(1,2), xpd=TRUE)
for (i in 1:length(object.list)) {
netVisual_circle(object.list[[i]]@net$count.merged, weight.scale = T, label.edge= T, edge.weight.max = weight.max[3], edge.width.max = 12, title.name = paste0("Number of interactions - ", names(object.list)[i]))
}
}
if (cond_2 == "6M") {
my_data_2 <- readRDS("cellchat_6M.rds")
name_1 <- as.character(input$condition_1)
name_2 <- as.character(input$condition_2)
object.list <- dplyr::lst(!!name_1 := my_data_1, !!name_2 := my_data_2)
cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
myd <- mydata$cellgroup
group.cellType <- c(rep(myd[1], 4), rep(myd[2], 4), rep(myd[3], 4))
group.cellType <- factor(group.cellType, levels = c(myd[1], myd[2], myd[3]))
object.list <- lapply(object.list, function(x) {mergeInteractions(x, group.cellType)})
cellchat_diff <- mergeCellChat(object.list, add.names = names(object.list))
weight.max <- getMaxWeight(object.list, slot.name = c("idents", "net", "net"), attribute = c("idents","count", "count.merged"))
par(mfrow = c(1,2), xpd=TRUE)
for (i in 1:length(object.list)) {
netVisual_circle(object.list[[i]]@net$count.merged, weight.scale = T, label.edge= T, edge.weight.max = weight.max[3], edge.width.max = 12, title.name = paste0("Number of interactions - ", names(object.list)[i]))
}
}
if (cond_2 == "6V") {
my_data_2 <- readRDS("cellchat_6V.rds")
name_1 <- as.character(input$condition_1)
name_2 <- as.character(input$condition_2)
object.list <- dplyr::lst(!!name_1 := my_data_1, !!name_2 := my_data_2)
cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
myd <- mydata$cellgroup
group.cellType <- c(rep(myd[1], 4), rep(myd[2], 4), rep(myd[3], 4))
group.cellType <- factor(group.cellType, levels = c(myd[1], myd[2], myd[3]))
object.list <- lapply(object.list, function(x) {mergeInteractions(x, group.cellType)})
cellchat_diff <- mergeCellChat(object.list, add.names = names(object.list))
weight.max <- getMaxWeight(object.list, slot.name = c("idents", "net", "net"), attribute = c("idents","count", "count.merged"))
par(mfrow = c(1,2), xpd=TRUE)
for (i in 1:length(object.list)) {
netVisual_circle(object.list[[i]]@net$count.merged, weight.scale = T, label.edge= T, edge.weight.max = weight.max[3], edge.width.max = 12, title.name = paste0("Number of interactions - ", names(object.list)[i]))
}
}
#object.list <- list("Condition 1" = my_data_1, "Condition 2" = my_data_2)
#cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
#myd <- mydata$cellgroup
#group.cellType <- c(rep(myd[1], 4), rep(myd[2], 4), rep(myd[3], 4))
#group.cellType <- factor(group.cellType, levels = c(myd[1], myd[2], myd[3]))
#object.list <- lapply(object.list, function(x) {mergeInteractions(x, group.cellType)})
#cellchat_diff <- mergeCellChat(object.list, add.names = names(object.list))
#weight.max <- getMaxWeight(object.list, slot.name = c("idents", "net", "net"), attribute = c("idents","count", "count.merged"))
#par(mfrow = c(1,2), xpd=TRUE)
#for (i in 1:length(object.list)) {
#netVisual_circle(object.list[[i]]@net$count.merged, weight.scale = T, label.edge= T, edge.weight.max = weight.max[3], edge.width.max = 12, title.name = paste0("Number of interactions - ", names(object.list)[i]))
#}
})
output$interact_1 <- renderPlot(interaction_circ())
output$interact_2 <- renderPlot({
req(input$condition_1, input$condition_2)
cond_1 <- setCCCNames(input$condition_1)
cond_2 <- setCCCNames(input$condition_2)
my_data_1 <- readRDS(sprintf("cellchat_%s%s.rds",str_extract_all(cond_1, "[0-9]+"), str_extract_all(cond_1, "[aA-zZ]+")))
file_names <- paste0('cellchat_', cond_2, '.rds')
my_data_2 <- readRDS(file_names)
#my_data_2 <- readRDS(sprintf("cellchat_%s%s.rds",str_extract_all(cond_2, "[0-9]+"), str_extract_all(cond_2, "[aA-zZ]+")))
name_1 <- as.character(input$condition_1)
name_2 <- as.character(input$condition_2)
object.list <- dplyr::lst(!!name_1 := my_data_1, !!name_2 := my_data_2)
cellchat_compare <- mergeCellChat(object.list, add.names = names(object.list))
pathways.show <- input$pathways
par(mfrow = c(1,2), xpd=TRUE)
for (i in 1:length(object.list)) {
netVisual_aggregate(object.list[[i]], signaling = pathways.show, layout = "chord", signaling.name = paste(pathways.show, names(object.list)[i]))
}
})
# Filter marker gene data based on selections
output$table <- DT::renderDataTable(DT::datatable({
if (input$time != "All") {
data <- data[data$timepoint == as.numeric(input$time),]
}
if (input$ct != "All") {
data <- data[data$celltype == input$ct,]
}
if (input$pval != "All") {
data <- data[data$p_val <= input$pval,]
}
if (input$gene2!= "All") {
data <- data[data$gene == input$gene2,]
}
colnames(data) <- c("Gene","D.E. P Value","Bonferroni-Corrected P Value",
"Average Log2 Fold Change in mutant from control for this celltype and timepoint",
"Percent of V337M cells expressing gene within this celltype and timepoint",
"Developmental timepoint", "Celltype","D.E. status")
data
}) %>% DT::formatRound(columns = c(4), 2) %>%
DT::formatSignif(columns = c(2,3), 2) %>%
DT::formatPercentage(columns = c(5), 2)
)
# Download csv of selected dataset
output$downloadData <- downloadHandler(
filename = function() {
paste("DEgenes_MtvsWt_timepoint",input$time,"_celltype",input$ct, ".csv", sep = "")
},
content = function(file) {
if (input$time != "All") {
data <- data[data$timepoint == as.numeric(input$time),]
}
if (input$ct != "All") {
data <- data[data$celltype == input$ct,]
}
write.csv(data, file, row.names = FALSE)
}
)
output$VolcanoPlots <- renderPlotly({
if(input$ct != "All") {
allcelltype_data <- read.csv("DEgenes_MtvsWt_alltimepts_allcelltypes.csv")
celltype_data <- allcelltype_data[allcelltype_data$celltype == input$ct,]
if(input$time == "All") {
df_all <- celltype_data %>%
dplyr::select(gene, avg_log2FC, p_val, pct.1) %>%
mutate(logpval = -log10(p_val))
colnames(df_all) <- c("geneIDs","logFC","pvalue","percent_expressed","logpval")
fold_cutoff = 0.5
pvalue_cutoff = 0.01
plot_all <- volcanoPlot(df_all, fold_cutoff, pvalue_cutoff,
title = sprintf("Gene Expression in %s Cells at all timepoints", input$ct))
ggplotly(plot_all, tooltip="text")
}
else{
df_timept <- celltype_data[celltype_data$timepoint == as.numeric(input$time),]
df_eachtp <- df_timept %>%
dplyr::select(gene, avg_log2FC, p_val,pct.1) %>%
mutate(logpval = -log10(p_val))
colnames(df_eachtp) <- c("geneIDs","logFC","pvalue","percent_expressed","logpval")
fold_cutoff = 0.5
pvalue_cutoff = 0.01
plot_eachtp <- volcanoPlot(df_eachtp, fold_cutoff, pvalue_cutoff,
title = sprintf("Gene Expression in %s Cells at %s month", input$ct, input$time))
ggplotly(plot_eachtp, tooltip="text")
}
}
})
output$manhattanplot <- renderPlotly({
if(input$ct != "All") {
allcelltype_data <- read.csv("DEgenes_MtvsWt_alltimepts_allcelltypes.csv")
celltype_data <- allcelltype_data[allcelltype_data$celltype == input$ct,]
if(input$time == "All") {
df_all <- celltype_data %>%
dplyr::select(gene, avg_log2FC, p_val, pct.1) %>%
mutate(logpval = -log10(p_val))
colnames(df_all) <- c("geneIDs","logFC","pvalue","percent_expressed","logpval")
up = subset(df_all, logFC > 0)
down = subset(df_all, logFC < 0)
multi_gp = gost(list("up-regulated" = up$geneIDs,
"down-regulated" = down$geneIDs))
gostplot(multi_gp, interactive = TRUE)
}
else{
df_timept <- celltype_data[celltype_data$timepoint == as.numeric(input$time),]
df_eachtp <- df_timept %>%
dplyr::select(gene, avg_log2FC, p_val,pct.1) %>%
mutate(logpval = -log10(p_val))
colnames(df_eachtp) <- c("geneIDs","logFC","pvalue","percent_expressed","logpval")
up = subset(df_eachtp, logFC > 0)
down = subset(df_eachtp, logFC < 0)
multi_gp = gost(list("up-regulated" = up$geneIDs,
"down-regulated" = down$geneIDs))
gostplot(multi_gp, interactive = TRUE)
}
}
})
output$enrichmentplot <- renderPlot({
if(input$ct != "All") {
allcelltype_data <- read.csv("DEgenes_MtvsWt_alltimepts_allcelltypes.csv")
celltype_data <- allcelltype_data[allcelltype_data$celltype == input$ct,]
if(input$time == "All") {
up = subset(celltype_data, avg_log2FC > 0)
down = subset(celltype_data, avg_log2FC < 0)
up_names = gconvert(up$gene)
down_names = gconvert(down$gene)
multi_gp = gost(list("up-regulated" = up_names$name,
"down-regulated" = down_names$name), multi_query = FALSE, evcodes = TRUE)
gp_mod = multi_gp$result[,c("query", "source", "term_id",
"term_name", "p_value", "query_size",
"intersection_size", "term_size",
"effective_domain_size", "intersection")]
gp_mod$GeneRatio = paste0(gp_mod$intersection_size, "/", gp_mod$query_size)
gp_mod$BgRatio = paste0(gp_mod$term_size, "/", gp_mod$effective_domain_size)
names(gp_mod) = c("Cluster", "Category", "ID", "Description", "p.adjust",
"query_size", "Count", "term_size", "effective_domain_size",
"geneID", "GeneRatio", "BgRatio")
gp_mod$geneID = gsub(",", "/", gp_mod$geneID)
df <- gp_mod[order(gp_mod$p.adjust, decreasing = TRUE),]
df_to_plot <- df[1:15, ]
p <- ggplot(df_to_plot, aes_string(x = "Count", y = "Description", fill = "p.adjust")) +
#theme_dose(font.size = 9) +
scale_fill_continuous(low="red", high="blue", name = 'p.adjust', guide=guide_colorbar(reverse=TRUE)) +
geom_col() + # geom_bar(stat = "identity") + coord_flip() +
#ggtitle("") +
facet_grid(~Cluster)
p
}
else{
df_timept <- celltype_data[celltype_data$timepoint == as.numeric(input$time),]
up = subset(df_timept, avg_log2FC > 0)
down = subset(df_timept, avg_log2FC < 0)
up_names = gconvert(up$gene)
down_names = gconvert(down$gene)
multi_gp = gost(list("up-regulated" = up_names$name,
"down-regulated" = down_names$name), multi_query = FALSE, evcodes = TRUE)
gp_mod = multi_gp$result[,c("query", "source", "term_id",
"term_name", "p_value", "query_size",
"intersection_size", "term_size",
"effective_domain_size", "intersection")]
gp_mod$GeneRatio = paste0(gp_mod$intersection_size, "/", gp_mod$query_size)
gp_mod$BgRatio = paste0(gp_mod$term_size, "/", gp_mod$effective_domain_size)
names(gp_mod) = c("Cluster", "Category", "ID", "Description", "p.adjust",
"query_size", "Count", "term_size", "effective_domain_size",
"geneID", "GeneRatio", "BgRatio")
gp_mod$geneID = gsub(",", "/", gp_mod$geneID)
df <- gp_mod[order(gp_mod$p.adjust, decreasing = TRUE),]
df_to_plot <- df[1:15, ]
p <- ggplot(df_to_plot, aes_string(x = "Count", y = "Description", fill = "p.adjust")) +
#theme_dose(font.size = 9) +
scale_fill_continuous(low="red", high="blue", name = 'p.adjust', guide=guide_colorbar(reverse=TRUE)) +
geom_col() + # geom_bar(stat = "identity") + coord_flip() +
#ggtitle("") +
facet_grid(~Cluster)
p
}
}
})
output$DEsummary <- renderPlot({
if(input$ct != "All") {
p <- summaryPlot(input$ct,data,10)
p
}
})
query_modal <- modalDialog(
title = "Welcome to FTD Minder!",
"PLEASE NOTE: This application is a product of the efforts of student researchers at
Rensselaer Polytechnic Institute’s Data INCITE Lab. It aims to expose a large corpus of scRNAseq data
from organoid models of frontotemporal dementia and isogenic controls to the biologist
and the general user, for browsing and hypothesis development.
Brief loading delays in plot rendering are to be expected due to the size of the dataset.",
easyClose = F,
footer = tagList(actionButton("run", "Continue to the App"))
)
showModal(query_modal)
observeEvent(input$run, {
removeModal()
})
# Conditional output based
output$GeneTrajecConditional <- renderUI({
if(!(input$gene %in% selection_genes)){
h4("Gene not found to be significantly represented.")
}
})
output$GeneFeaturePlotConditional <- renderUI({
if(!(input$gene %in% selection_genes)){
h4("Gene not found to be significantly represented.")
}
})
output$GeneFeaturePlotConditional2 <- renderUI({
cogenes <- c(input$gene_1, input$gene_2)
if(any(!(cogenes %in% selection_genes))){
h4("Genes not found to be significantly represented.")
}
})
}
# Run app
shinyApp(ui = ui, server = server)