Skip to content
Permalink
21f0bea500
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 384 lines (312 sloc) 19.2 KB
Raw Blame
library(shiny)
library(shinythemes)
library(ggplot2)
library(grid)
library(dplyr)
library(Seurat)
library(rrvgo)
# Utility function to convert cell type codes to their real names for plotting
setCellTypeNames <- function(df) {
df$CellType <- recode(as.factor(df$CellType),
"Ast"="Astrocytes",
"ExDp1"="Excitatory deeplayer\n1",
"ExDp2"="Excitatory deeplayer\n2",
"ExM"="Maturing excitatory",
"ExM-U"="Maturing excitatory\nupper enriched",
"ExN"="Newborn excitatory",
"Glia"="Unspecified glia/\nnon-neuronal cells",
"InCGE"="Interneurons caudal\nganglionic eminence",
"InMGE"="Interneurons medial\nganglionic eminence",
"IP"="Intermediate\nprogenitors",
"OPC"="Oligodendrocyte\nprecursors",
"oRG"="Outer radial glia",
"PgG2M"="Cycling progenitors\n(G2/M phase)",
"PgS"="Cycling progenitors\n(S phase)",
"UN"="Unspecified neurons",
"vRG"="Ventricular radial \nglia")
return(df)}
# Read in the data (moved)
G6cells <- readRDS("FinalMergedData_linesG6A02-G6E11_all_timepts.rds")
seurat.all <- readRDS("FinalMergedData-downsampled.rds")
# Switch active identities to cell type labels for plotting
Idents(seurat.all) <- "CellType"
celltype_data <- readRDS("FetchDataOutput-AllCells.rds") %>% relocate(CellType)
celltype_props <- readRDS("overall_celltype_props_data.rds")
# convert cell type codes to real names
celltype_data <- setCellTypeNames(celltype_data)
celltype_props <- setCellTypeNames(celltype_props)
celltype_markers <- readRDS("celltype_marker_genes_Ast.rds")
# Create gene selection list for dropdown
geneList <- VariableFeatures(seurat.all)
#Create celltype selection list fr drowpdown
celltypeList <- c("Astrocytes")
###################################################
ui <- navbarPage(title=" ",theme = shinytheme("slate"), windowTitle="AlzApp: Visualize FTD scRNAseq Data",
#shinythemes::themeSelector(),
tabPanel("Overall Dataset",
# Logos
div(
img(src="IDEA_Logo_WHITE.png",align="right",width="200px"),
img(src="NSCI_Full_Logo.png",align="left",width="150px")
),
# Application title
fixedRow(h2("Tool for Exploring scRNAseq Data from Frontotemporal Dementia Organoids", align="center"),
div(align="center",
h6("This application exposes the large dataset of single-cell RNA Sequencing data from dementia-affected brain organoids
described in the paper"),
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 (Bowles et al. 2021)."),
h6("Use the \"Gene Explorer\" and \"Cell Explorer\" top-level views
to visualize dataset trends by individual gene or cell type.")),
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")),
tagList(tags$p("Overall proportions of neuronal cell types represented at each sequencing timepoint"),
plotOutput("CellTypeBarPlot",height="450px"))
)
)
),
tabPanel("Gene Explorer",
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$hr()
),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "gene",
label = "Gene",
choices = geneList),
style = "padding: 5px;"
),
# Show plots
tabsetPanel(
tabPanel(title = "Feature Plots",
fixedRow(tags$p("Expression level mapped onto overall dataset, by variant and over time"),
plotOutput("GeneFeaturePlot",height="600px",width="70%"),align="center")
),
tabPanel(title = "Time Trends - Expression Trajectory",
fixedRow(tags$p("Expression trajectory over time, by cell type and variant"),
plotOutput("CellTypesByVariant",height="600px",width="80%"),align="center")
),
tabPanel(title = "Time Trends - Expression Distributions",
fixedRow(tags$p("Expression distributions over time, by variant"),
plotOutput("GeneVlnPlots",height="600px",width="70%"),align="center")
)
)
)
),
tabPanel("CellType Explorer",
tags$div(class="header", checked=NA,
tags$h4("Use the panels below to visualize celltype-level gene expression trends in the overall dataset."),
tags$hr()
),
tabsetPanel(
tabPanel(title = "Feature Plots",
fixedRow(tags$p("Cell type clusters within the overall single-cell dataset, grouped by variant and time."),
plotOutput("CellTypeExplorerPlots",height="600px"),align="center")
),
tabPanel(title= "Cell Type Marker Genes",
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. 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.</p>"),
tags$em("Only Astrocyte statistics available currently- data for more cell types coming soon!"),
tags$hr(),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "celltype",
label = "Select a cell type:",
choices = celltypeList),
dataTableOutput("celltypeTable"),
style = "padding: 25px;"
),
mainPanel(
fixedRow(splitLayout(cellWidths=c("45%","45%"),
cellArgs = list(style = "padding: 15px"),
tagList(tags$p("Semantic summarization of enriched GO terms"),
plotOutput("REVIGOtree",height="450px")),
tagList(tags$p("Semantic distances between enriched GO terms"),
plotOutput("REVIGOscatter",height="450px"),)
)
),fixedRow(splitLayout(cellWidths=c("45%","45%"),
cellArgs = list(style = "padding: 15px"),
tagList(tags$p(" ")),
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.")))
)
)
)
)
)
)
)
)
# Define server logic
server <- function(input, output, session) {
# Data prep
###########################################################
# Fetch input values
updateSelectInput(session, 'gene', choices = NULL)
updateSelectInput(session, 'celltype', choices = NULL)
# Tab 1: Overall Trends
###########################################################
# Plot UMAP visual colored by celltype
output$CellFeaturePlot <- renderPlot({
plot <- ggplot(celltype_data,aes_string(x = 'UMAP_1', y = 'UMAP_2', color = 'CellType')) +
geom_point(size = 0.1, 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=10), legend.title=element_text(size=10),
legend.spacing.y = unit(0.9, 'cm')) +
coord_fixed(ratio = 1) +
theme_minimal()
#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=10), legend.title=element_text(size=10),
legend.spacing.y = unit(0.9, 'cm')) +
theme_minimal()
})
# Tab 2: Gene Explorer
###########################################################
# Plot UMAPS colored by input gene expression level
output$GeneFeaturePlot <- renderPlot({
# Forced to use FetchData() here because data plotted
# depends on reactive input value input$gene
gene_plot_data <- FetchData(seurat.all, c('UMAP_1', 'UMAP_2', 'Age','Mt',input$gene))
plot1 <- ggplot(gene_plot_data,aes_string(x = 'UMAP_1', y = 'UMAP_2', color=input$gene)) +
# render scatterplot, optionally adjust point size
geom_point(size = 0.3) +
# adjust plot aspect ratio
coord_fixed(ratio = 1) +
# specify color gradient and a name for the associated legend
scale_colour_gradient(low = "lightgrey", high = "blue", name = sprintf("%s expression\nlevel",input$gene)) +
# set plot labels
xlab("UMAP 1") + ylab("UMAP 2")+
facet_grid(Mt~Age) +
theme_minimal()
plot1
})
# Plot expression distributions of input gene by time point
# as grouped violin plots
output$GeneVlnPlots <- renderPlot({
# 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))
gene_plot_data <- setCellTypeNames(gene_plot_data)
ggplot(gene_plot_data, aes(x=Age, y=.data[[input$gene]], fill=Mt)) +
geom_violin(trim=FALSE) + scale_fill_brewer(palette="Paired",name="Variant") +
facet_wrap(~CellType, scales="free") +
labs(x="Developmental Timepoint",y="Expression Level") +
theme_minimal()
# ggplot(plotdata1, aes(x=Age, y=input$gene, fill=Mt)) +
# geom_violin(trim=FALSE) + scale_fill_brewer(palette="Paired",name="Variant") +
# scale_y_continuous(breaks=c(0,1,2,3),name=sprintf("%s Expression Level",input$gene)+
# ylab("Expression Level") +
# xlab("Developmental Timepoint") +
# theme_minimal()
#
})
# plot expression of input gene over time for each celltype by variant
# as line graphs
output$CellTypesByVariant <- renderPlot({
expression_means_for_this_gene <- G6cells %>%
dplyr::select(all_of(input$gene),Mt,Age,CellType) %>%
group_by(Age, CellType, Mt) %>%
summarise(mean_expr = mean(.data[[input$gene]]))
# fix cell type names
expression_means_for_this_gene <- setCellTypeNames(expression_means_for_this_gene)
# convert all character columns to factors for plotting
expression_means_for_this_gene <- as.data.frame(unclass(expression_means_for_this_gene),
stringsAsFactors = TRUE)
# convert Age to an integer
expression_means_for_this_gene$Age <- recode(as.factor(expression_means_for_this_gene$Age),
"2mo"= 2, "4mo" = 4,"6mo" = 6)
#Plot the average expressions over time for each celltype by variant
ggplot(expression_means_for_this_gene,aes(x=Age, y=mean_expr, col=Mt, by=Mt)) +
geom_line() +
scale_x_continuous(breaks=c(2,4,6)) +
labs(title= sprintf("Average %s expression over time",input$gene),
x="Developmental timepoint (months)",
y = "Average expression") +
# 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_minimal() +
coord_fixed(ratio=1.2)
})
# Tab 3: CellType Explorer
###########################################################
# Plot UMAP visual colored by celltype, faceted by age and variant
output$CellTypeExplorerPlots <- renderPlot({
plot2 <- ggplot(celltype_data,aes_string(x = 'UMAP_1', y = 'UMAP_2', color="CellType")) +
# render scatterplot, optionally adjust point size
geom_point(size = 0.1,alpha=0.3) +
# 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")+
facet_grid(Mt~Age) +
theme_minimal() +
theme(legend.text = element_text(size=10), legend.title=element_text(size=10)) +
guides(color = guide_legend(override.aes = list(size = 2,alpha=1)))
plot2
})
# Show table of cell type marker genes
output$celltypeTable <- renderDataTable({
#showdata <- celltype_data %>% filter(CellType==input$celltype)
showdata <- tibble::rownames_to_column(celltype_markers)
colnames(showdata)[1] <- "Gene"
showdata <- showdata %>% filter(avg_log2FC>=2) %>% dplyr::select(Gene,avg_log2FC,p_val)
showdata
}, options=list(searching=F))
# Show GO output for the celltype marker genes of input celltype
# output$GOtable <- renderDataTable({
#
# GOres <- readRDS("GOresults_Astrocytes_top30.rds")
#
# # Make a dataframe of major Gene Ontology terms returned and their p-values
# # Note we order the results by increasing p-value (most significant come first)
# GOres.df <- GOres%>%
# select(term_name,p_value) %>%
# arrange(p_value)
#
# # Show results
# GOres.df[1:10,]
# })
# Plot REVIGO output for the celltype marker genes of input celltype
output$REVIGOscatter <- renderPlot({
ct_select <- input$celltype
# File read-in must be here because data depends on a reactive input value
simMatrix <- readRDS(sprintf("REVIGO_simMatrix_%s.rds",ct_select))
reducedTerms <- readRDS(sprintf("REVIGO_reducedTerms_%s.rds",ct_select))
scatterPlot(simMatrix, reducedTerms)
})
output$REVIGOtree <- renderPlot({
ct_select <- input$celltype
# File read-in must be here because data depends on a reactive input value
reducedTerms <- readRDS(sprintf("REVIGO_reducedTerms_%s.rds",ct_select))
treemapPlot(reducedTerms)
})
}
# Run app
shinyApp(ui = ui, server = server)