#' Gene expression heatmap
#'
#' Draws a heatmap of single cell gene expression using ggplot2.
#'
#' @param object Seurat object
#' @param data.use Option to pass in data to use in the heatmap. Default will pick from either
#' object@@data or object@@scale.data depending on use.scaled parameter. Should have cells as columns
#' and genes as rows.
#' @param use.scaled Whether to use the data or scaled data if data.use is NULL
#' @param cells.use Cells to include in the heatmap (default is all cells)
#' @param genes.use Genes to include in the heatmap (ordered)
#' @param disp.min Minimum display value (all values below are clipped)
#' @param disp.max Maximum display value (all values above are clipped)
#' @param group.by Groups cells by this variable. Default is object@@ident
#' @param draw.line Draw vertical lines delineating different groups
#' @param col.low Color for lowest expression value
#' @param col.mid Color for mid expression value
#' @param col.high Color for highest expression value
#' @param slim.col.label display only the identity class name once for each group
#' @param remove.key Removes the color key from the plot.
#' @param rotate.key Rotate color scale horizantally
#' @param title Title for plot
#' @param cex.col Controls size of column labels (cells)
#' @param cex.row Controls size of row labels (genes)
#' @param group.label.loc Place group labels on bottom or top of plot.
#' @param group.label.rot Whether to rotate the group label.
#' @param group.cex Size of group label text
#' @param group.spacing Controls amount of space between columns.
#' @param do.plot Whether to display the plot.
#'
#' @return Returns a ggplot2 plot object
#'
#' @importFrom reshape2 melt
#' @importFrom dplyr %>%
#'
#' @export
#'
<- (
object,
data.use = ,
use.scaled = ,
cells.use = ,
genes.use = ,
disp.min = -2.5,
disp.max = 2.5,
group.by = "ident",
draw.line = ,
col.low = "#FF00FF",
col.mid = "#000000",
col.high = "#FFFF00",
slim.col.label = ,
remove.key = ,
rotate.key = ,
= ,
cex.col = 10,
cex.row = 10,
group.label.loc = "bottom",
group.label.rot = ,
group.cex = 15,
group.spacing = 0.15,
do.plot =
) {
if ((x = data.use)) {
if (use.scaled) {
data.use <- (object,assay.type = "RNA", = "scale.data")
} {
data.use <- (object,assay.type = "RNA", = "data")
}
}
# note: data.use should have cells as column names, genes as row names
cells.use <- SetIfNull(x = cells.use, default = object@cell.names)
cells.use <- (x = cells.use, y = (x = data.use))
if ((x = cells.use) == 0) {
("No cells given to cells.use present in object")
}
genes.use <- SetIfNull(x = genes.use, default = (x = data.use))
genes.use <- (x = genes.use, y = (x = data.use))
if ((x = genes.use) == 0) {
("No genes given to genes.use present in object")
}
if ((x = group.by) || group.by == "ident") {
cells.ident <- object@ident[cells.use]
} {
cells.ident <- (x = (
object = object,
cells.use = cells.use,
vars.all = group.by
), 1])
(x = cells.ident) <- cells.use
}
cells.ident <- (
x = cells.ident,
= (x = (x = cells.ident), y = cells.ident)
)
data.use <- data.use[genes.use, cells.use]
if ((!use.scaled)) {
data.use = (x = data.use)
if (disp.max==2.5) disp.max = 10;
}
data.use <- ( = data.use, = disp.min, = disp.max)
data.use <- (x = (x = data.use))
data.use$cell <- (x = data.use)
(x = data.use) <- ( = (x = data.use))
data.use %>% melt(id.vars = "cell") -> data.use
(x = data.use)[names(x = data.use) == 'variable'] <- 'gene'
(x = data.use)[names(x = data.use) == 'value'] <- 'expression'
data.use$ident <- cells.ident[data.use$cell]
breaks <- (
from = (data.use$),
to = (data.use$),
= (x = PurpleAndYellow()) + 1
)
data.use$gene <- (
= data.use,
expr = (x = gene, = (x = (x = data.use$gene)))
)
data.use$cell <- (
= data.use,
expr = (x = cell, = cells.use)
)
# might be a solution if we want discrete interval units, makes the legend clunky though
#data.use$expression <- cut(data.use$expression, breaks = breaks, include.lowest = T)
#heatmap <- ggplot(data.use, aes(x = cell, y = gene, fill = expression)) + geom_tile() +
# scale_fill_manual(values = PurpleAndYellow(), name= "Expression") +
# scale_y_discrete(position = "right", labels = rev(genes.use)) +
# theme(axis.line=element_blank(), axis.title.y=element_blank(),
# axis.ticks.y = element_blank())
if (rotate.key) {
key.direction <- "horizontal"
key.title.pos <- "top"
} {
key.direction <- "vertical"
key.title.pos <- "left"
}
<- ggplot(
= data.use,
mapping = aes(x = cell, y = gene, fill = )
) +
geom_tile() +
scale_fill_gradient2(
low = col.low,
mid = col.mid,
high = col.high,
= "Expression",
guide = guide_colorbar(
direction = key.direction,
title.position = key.title.pos
)
) +
scale_y_discrete(position = "right", = (genes.use)) +
theme(
axis.line = element_blank(),
axis.title.y = element_blank(),
axis.ticks.y = element_blank(),
strip.text.x = element_text(size = group.cex),
axis.text.y = element_text(size = cex.row),
axis.text.x = element_text(size = cex.col),
axis.title.x = element_blank()
)
if (slim.col.label) {
<- +
theme(
axis.title.x = element_blank(),
axis.text.x = element_blank(),
axis.ticks.x = element_blank(),
axis.line = element_blank(),
axis.title.y = element_blank(),
axis.ticks.y = element_blank()
)
} {
<- + theme(axis.text.x = element_text(angle = 90))
}
if (! (x = group.by)) {
if (group.label.loc == "top") {
<-
# heatmap <- heatmap +
# facet_grid(
# facets = ~ident,
# drop = TRUE,
# space = "free",
# scales = "free"
# ) +
# scale_x_discrete(expand = c(0, 0), drop = TRUE)
} {
<- 'x'
# heatmap <- heatmap +
# facet_grid(
# facets = ~ident,
# drop = TRUE,
# space = "free",
# scales = "free",
# switch = "x"
# ) +
# scale_x_discrete(expand = c(0, 0), drop = TRUE)
}
<- +
facet_grid(
facets = ~ident,
= ,
space = "free",
scales = "free",
= ,
) +
scale_x_discrete(expand = (0, 0), = )
if (draw.line) {
panel.spacing <- (x = group.spacing, = 'lines')
# heatmap <- heatmap + theme(strip.background = element_blank(), panel.spacing = unit(group.spacing, "lines"))
} {
panel.spacing <- (x = 0, = 'lines')
#
}
<- +
theme(strip.background = element_blank(), panel.spacing = panel.spacing)
if (group.label.rot) {
<- + theme(strip.text.x = element_text(angle = 90))
}
}
if (remove.key) {
<- + theme(legend.position = "none")
}
if (! (x = )) {
<- + labs( = )
}
if (do.plot) {
}
()
}
#' Single cell violin plot
#'
#' Draws a violin plot of single cell data (gene expression, metrics, PC
#' scores, etc.)
#'
#' @param object Seurat object
#' @param features.plot Features to plot (gene expression, metrics, PC scores,
#' anything that can be retreived by FetchData)
#' @param ident.include Which classes to include in the plot (default is all)
#' @param nCol Number of columns if multiple plots are displayed
#' @param do.sort Sort identity classes (on the x-axis) by the average
#' expression of the attribute being potted
#' @param y.max Maximum y axis value
#' @param same.y.lims Set all the y-axis limits to the same values
#' @param size.x.use X axis title font size
#' @param size.y.use Y axis title font size
#' @param size.title.use Main title font size
#' @param adjust.use Adjust parameter for geom_violin
#' @param point.size.use Point size for geom_violin
#' @param cols.use Colors to use for plotting
#' @param group.by Group (color) cells in different ways (for example, orig.ident)
#' @param y.log plot Y axis on log scale
#' @param x.lab.rot Rotate x-axis labels
#' @param y.lab.rot Rotate y-axis labels
#' @param legend.position Position the legend for the plot
#' @param single.legend Consolidate legend the legend for all plots
#' @param remove.legend Remove the legend from the plot
#' @param do.return Return a ggplot2 object (default : FALSE)
#' @param return.plotlist Return the list of individual plots instead of compiled plot.
#' @param \dots additional parameters to pass to FetchData (for example, use.imputed, use.scaled, use.raw)
#'
#' @import ggplot2
#' @importFrom cowplot plot_grid get_legend
#'
#' @return By default, no return, only graphical output. If do.return=TRUE,
#' returns a list of ggplot objects.
#'
#' @export
<- (
object,
features.plot,
ident.include = ,
nCol = ,
do.sort = ,
y.max = ,
same.y.lims = ,
size.x.use = 16,
size.y.use = 16,
size.title.use = 20,
adjust.use = 1,
point.size.use = 1,
cols.use = ,
group.by = ,
y.log = ,
x.lab.rot = ,
y.lab.rot = ,
legend.position = "right",
single.legend = ,
remove.legend = ,
do.return = ,
return.plotlist = ,
) {
if ((x = nCol)) {
if ((x = features.plot) > 9) {
nCol <- 4
} {
nCol <- ((x = features.plot), 3)
}
}
data.use <- ((object = object, vars.all = features.plot, ), check.names = F)
if ((x = ident.include)) {
cells.to.include <- object@cell.names
} {
cells.to.include <- (object = object, ident = ident.include)
}
data.use <- data.use[cells.to.include, , = ]
if (!(x = group.by)) {
ident.use <- (x = (
object = object,
vars.all = group.by
)[cells.to.include, 1])
} {
ident.use <- object@ident[cells.to.include]
}
gene.names <- (x = data.use)[colnames(x = data.use) %in% (x = object@)]
if (single.legend) {
remove.legend <-
}
if (same.y.lims && (x = y.max)) {
y.max <- (data.use)
}
plots <- (
X = features.plot,
FUN = (x) {
(SingleVlnPlot(
feature = x,
= data.use, x, = ],
cell.ident = ident.use,
do.sort = do.sort, y.max = y.max,
size.x.use = size.x.use,
size.y.use = size.y.use,
size.title.use = size.title.use,
adjust.use = adjust.use,
point.size.use = point.size.use,
cols.use = cols.use,
gene.names = gene.names,
y.log = y.log,
x.lab.rot = x.lab.rot,
y.lab.rot = y.lab.rot,
legend.position = legend.position,
remove.legend = remove.legend
))
}
)
if ((x = features.plot) > 1) {
plots.combined <- plot_grid(plotlist = plots, = nCol)
if (single.legend && !remove.legend) {
<- get_legend(
= plots[1]] + theme(legend.position = legend.position)
)
if (legend.position == "bottom") {
plots.combined <- plot_grid(
plots.combined,
,
= 1,
rel_heights = (1, .2)
)
} if (legend.position == "right") {
plots.combined <- plot_grid(
plots.combined,
,
rel_widths = (3, .3)
)
} {
("Shared legends must be at the bottom or right of the plot")
}
}
} {
plots.combined <- plots[1]]
}
if (do.return) {
if (return.plotlist) {
(plots)
} {
(plots.combined)
}
} {
if ((x = plots.combined) > 1) {
plots.combined
}
{
(x = (X = plots.combined, FUN = ))
}
}
}
#' Single cell joy plot
#'
#' Draws a joy plot of single cell data (gene expression, metrics, PC
#' scores, etc.)
#'
#' @param object Seurat object
#' @param features.plot Features to plot (gene expression, metrics, PC scores,
#' anything that can be retreived by FetchData)
#' @param ident.include Which classes to include in the plot (default is all)
#' @param nCol Number of columns if multiple plots are displayed
#' @param do.sort Sort identity classes (on the x-axis) by the average
#' expression of the attribute being potted
#' @param y.max Maximum y axis value
#' @param same.y.lims Set all the y-axis limits to the same values
#' @param size.x.use X axis title font size
#' @param size.y.use Y axis title font size
#' @param size.title.use Main title font size
#' @param cols.use Colors to use for plotting
#' @param group.by Group (color) cells in different ways (for example, orig.ident)
#' @param y.log plot Y axis on log scale
#' @param x.lab.rot Rotate x-axis labels
#' @param y.lab.rot Rotate y-axis labels
#' @param legend.position Position the legend for the plot
#' @param single.legend Consolidate legend the legend for all plots
#' @param remove.legend Remove the legend from the plot
#' @param do.return Return a ggplot2 object (default : FALSE)
#' @param return.plotlist Return the list of individual plots instead of compiled plot.
#' @param \dots additional parameters to pass to FetchData (for example, use.imputed, use.scaled, use.raw)
#'
#' @import ggplot2
#' @importFrom cowplot get_legend
#' @importFrom ggjoy geom_joy theme_joy
#' @importFrom cowplot plot_grid
#'
#' @return By default, no return, only graphical output. If do.return=TRUE,
#' returns a list of ggplot objects.
#'
#' @export
#'
<- (
object,
features.plot,
ident.include = ,
nCol = ,
do.sort = ,
y.max = ,
same.y.lims = ,
size.x.use = 16,
size.y.use = 16,
size.title.use = 20,
cols.use = ,
group.by = ,
y.log = ,
x.lab.rot = ,
y.lab.rot = ,
legend.position = "right",
single.legend = ,
remove.legend = ,
do.return = ,
return.plotlist = ,
) {
if ((x = nCol)) {
if ((x = features.plot) > 9) {
nCol <- 4
} {
nCol <- ((x = features.plot), 3)
}
}
data.use <- ((object = object, vars.all = features.plot, ),
check.names = F)
if ((x = ident.include)) {
cells.to.include <- object@cell.names
} {
cells.to.include <- (object = object, ident = ident.include)
}
data.use <- data.use[cells.to.include, , = ]
if (!(x = group.by)) {
ident.use <- (x = (
object = object,
vars.all = group.by
)[cells.to.include, 1])
} {
ident.use <- object@ident[cells.to.include]
}
gene.names <- (x = data.use)[colnames(x = data.use) %in% (x = object@)]
if (single.legend) {
remove.legend <-
}
if (same.y.lims && (x = y.max)) {
y.max <- (data.use)
}
plots <- (
X = features.plot,
FUN = (x) {
(SingleJoyPlot(
feature = x,
= data.use, x, = ],
cell.ident = ident.use,
do.sort = do.sort, y.max = y.max,
size.x.use = size.x.use,
size.y.use = size.y.use,
size.title.use = size.title.use,
cols.use = cols.use,
gene.names = gene.names,
y.log = y.log,
x.lab.rot = x.lab.rot,
y.lab.rot = y.lab.rot,
legend.position = legend.position,
remove.legend = remove.legend
))
}
)
if ((x = features.plot) > 1) {
plots.combined <- plot_grid(plotlist = plots, = nCol)
if (single.legend && !remove.legend) {
<- get_legend(
= plots[1]] + theme(legend.position = legend.position)
)
if (legend.position == "bottom") {
plots.combined <- plot_grid(
plots.combined,
,
= 1,
rel_heights = (1, .2)
)
} if (legend.position == "right") {
plots.combined <- plot_grid(
plots.combined,
,
rel_widths = (3, .3)
)
} {
("Shared legends must be at the bottom or right of the plot")
}
}
} {
plots.combined <- plots[1]]
}
if (do.return) {
if (return.plotlist) {
(plots)
} {
(plots.combined)
}
} {
if ((x = plots.combined) > 1) {
plots.combined
}
{
(x = (X = plots.combined, FUN = ))
}
}
}
#' Old Dot plot visualization (pre-ggplot implementation)
#
#' Intuitive way of visualizing how gene expression changes across different identity classes (clusters).
#' The size of the dot encodes the percentage of cells within a class, while the color encodes the
#' AverageExpression level of 'expressing' cells (green is high).
#'
#' @param object Seurat object
#' @param genes.plot Input vector of genes
#' @param cex.use Scaling factor for the dots (scales all dot sizes)
#' @param cols.use colors to plot
#' @param thresh.col The raw data value which corresponds to a red dot (lowest expression)
#' @param dot.min The fraction of cells at which to draw the smallest dot (default is 0.05)
#' @param group.by Factor to group the cells by
#'
#' @return Only graphical output
#'
#' @importFrom graphics axis
#'
#' @export
#'
<- (
object,
genes.plot,
cex.use = 2,
cols.use = ,
thresh.col = 2.5,
dot.min = 0.05,
group.by =
) {
if (! (x = group.by)) {
object <- (object = object, id = group.by)
}
#object@data=object@data[genes.plot,]
object@ <- ((x = (object = object, vars.all = genes.plot)))
#this line is in case there is a '-' in the cell name
(x = object@) <- object@cell.names
avg.exp <- (object = object)
avg.alpha <- (object = object)
cols.use <- SetIfNull(x = cols.use, default = (low = "red", high = "green"))
exp.scale <- (x = (x = (x = avg.exp)))
exp.scale <- ( = exp.scale, = thresh.col, = (-1) * thresh.col)
n.col <- (x = cols.use)
data.y <- (x = 1:(x = avg.exp), (x = avg.exp))
data.x <- (x = (X = 1:(x = avg.exp), FUN = , (x = avg.exp)))
data.avg <- (x = (
X = 1:(x = data.y),
FUN = (x) {
(exp.scale[data.x[x], data.y[x]])
}
))
exp.col <- cols.use[floor(
x = n.col * (data.avg + thresh.col) / (2 * thresh.col) + .5
)]
data.cex <- (x = (
X = 1:(x = data.y),
FUN = (x) {
(avg.alpha[data.x[x], data.y[x]])
}
)) * cex.use + dot.min
(
x = data.x,
y = data.y,
cex = data.cex,
= 16,
= exp.col,
xaxt = "n",
xlab = "",
ylab = "",
yaxt = "n"
)
(side = 1, at = 1:(x = genes.plot), = genes.plot)
(side = 2, at = 1:(x = avg.alpha), (x = avg.alpha), las = 1)
}
#' Dot plot visualization
#'
#' Intuitive way of visualizing how gene expression changes across different
#' identity classes (clusters). The size of the dot encodes the percentage of
#' cells within a class, while the color encodes the AverageExpression level of
#' 'expressing' cells (blue is high).
#'
#' @param object Seurat object
#' @param genes.plot Input vector of genes
#' @param cols.use colors to plot
#' @param col.min Minimum scaled average expression threshold (everything smaller
#' will be set to this)
#' @param col.max Maximum scaled average expression threshold (everything larger
#' will be set to this)
#' @param dot.min The fraction of cells at which to draw the smallest dot
#' (default is 0.05). All cell groups with less than this expressing the given
#' gene will have no dot drawn.
#' @param dot.scale Scale the size of the points, similar to cex
#' @param group.by Factor to group the cells by
#' @param plot.legend plots the legends
#' @param x.lab.rot Rotate x-axis labels
#' @param do.return Return ggplot2 object
#' @return default, no return, only graphical output. If do.return=TRUE, returns a ggplot2 object
#' @importFrom dplyr %>% group_by summarize_each mutate ungroup
#' @importFrom tidyr gather
#' @export
<- (
object,
genes.plot,
cols.use = ("lightgrey", "blue"),
col.min = -2.5,
col.max = 2.5,
dot.min = 0,
dot.scale = 6,
group.by,
plot.legend = ,
do.return = ,
x.lab.rot =
) {
if (! (x = group.by)) {
object <- (object = object, id = group.by)
}
data.to.plot <- ((object = object, vars.all = genes.plot))
data.to.plot$cell <- (x = data.to.plot)
data.to.plot$id <- object@ident
data.to.plot %>% gather(
key = genes.plot,
value = ,
-(cell, id)
) -> data.to.plot
data.to.plot %>%
group_by(id, genes.plot) %>%
summarize(
avg.exp = ((x = )),
pct.exp = PercentAbove(x = , threshold = 0)
) -> data.to.plot
data.to.plot %>%
ungroup() %>%
group_by(genes.plot) %>%
mutate(avg.exp.scale = (x = avg.exp)) %>%
mutate(avg.exp.scale = (
= avg.exp.scale,
= col.max,
= col.min
)) -> data.to.plot
data.to.plot$genes.plot <- (
x = data.to.plot$genes.plot,
= (x = ( = "-", replacement = ".", x = genes.plot))
)
data.to.plot$pct.exp[data.to.plot$pct.exp < dot.min] <-
p <- ggplot( = data.to.plot, mapping = aes(x = genes.plot, y = id)) +
geom_point(mapping = aes(size = pct.exp, color = avg.exp.scale)) +
scale_radius( = (0, dot.scale)) +
scale_color_gradient(low = cols.use[1], high = cols.use[2]) +
theme(axis.title.x = element_blank(), axis.title.y = element_blank())
if (! plot.legend) {
p <- p + theme(legend.position = "none")
}
if (x.lab.rot) {
p <- p + theme(axis.text.x = element_text(angle = 90, vjust = 0.5))
}
((p))
if (do.return) {
(p)
}
}
#' Split Dot plot visualization
#'
#' Intuitive way of visualizing how gene expression changes across different identity classes (clusters).
#' The size of the dot encodes the percentage of cells within a class, while the color encodes the
#' AverageExpression level of 'expressing' cells (green is high). Splits the cells into two groups based on a
#' grouping variable.
#' Still in BETA
#'
#' @param object Seurat object
#' @param grouping.var Grouping variable for splitting the dataset
#' @param genes.plot Input vector of genes
#' @param cols.use colors to plot
#' @param col.min Minimum scaled average expression threshold (everything smaller will be set to this)
#' @param col.max Maximum scaled average expression threshold (everything larger will be set to this)
#' @param dot.min The fraction of cells at which to draw the smallest dot (default is 0.05).
#' @param dot.scale Scale the size of the points, similar to cex
#' @param group.by Factor to group the cells by
#' @param plot.legend plots the legends
#' @param x.lab.rot Rotate x-axis labels
#' @param do.return Return ggplot2 object
#' @param gene.groups Add labeling bars to the top of the plot
#' @return default, no return, only graphical output. If do.return=TRUE, returns a ggplot2 object
#' @importFrom dplyr %>% group_by summarize_each mutate ungroup
#' @importFrom tidyr gather
#' @export
<- (
object,
grouping.var,
genes.plot,
gene.groups,
cols.use = ("green", "red"),
col.min = -2.5,
col.max = 2.5,
dot.min = 0,
dot.scale = 6,
group.by,
plot.legend = ,
do.return = ,
x.lab.rot =
) {
if (! (x = group.by)) {
object <- (object = object, id = group.by)
}
grouping.data <- (
object = object,
vars.all = grouping.var
)[names(x = object@ident), 1]
idents.old <- (x = object@ident)
object@ident <- (object@ident, grouping.data, sep="_")
object@ident <- (
x = object@ident,
= (x = (
X = idents.old,
FUN = (x) {
((
(x, (x = grouping.data)[1], sep="_"),
(x, (x = grouping.data)[2], sep="_")
))
}
)),
=
)
data.to.plot <- ((object = object, vars.all = genes.plot))
data.to.plot$cell <- (x = data.to.plot)
data.to.plot$id <- object@ident
data.to.plot %>%
gather(key = genes.plot, value = , -(cell, id)) -> data.to.plot
data.to.plot %>%
group_by(id, genes.plot) %>%
summarize(
avg.exp = (x = ),
pct.exp = PercentAbove(x = , threshold = 0)
) -> data.to.plot
ids.2 <- (
idents.old,
(x = (x = grouping.data)[2]),
sep = "_"
)
vals.2 <- (x = data.to.plot$id %in% ids.2)
ids.1 <- (
idents.old,
(x = (x = grouping.data)[1]),
sep = "_"
)
vals.1 <- (x = data.to.plot$id %in% ids.1)
#data.to.plot[vals.2,3]=-1*data.to.plot[vals.2,3]
data.to.plot %>%
ungroup() %>%
group_by(genes.plot) %>%
mutate(avg.exp = (avg.exp)) %>%
mutate(avg.exp.scale = (x = (
x = ( = avg.exp, = col.max, = col.min),
breaks = 20
))) -> data.to.plot
data.to.plot$genes.plot <- (
x = data.to.plot$genes.plot,
= (x = ( = "-", replacement = ".", x = genes.plot))
)
data.to.plot$pct.exp[data.to.plot$pct.exp < dot.min] <-
palette.1 <- (low = "grey", high = "blue", k = 20)
palette.2 <- (low = "grey", high = "red", k = 20)
data.to.plot$ptcolor <- "grey"
data.to.plot[vals.1, "ptcolor"] <- palette.1[as.matrix(
x = data.to.plot[vals.1, "avg.exp.scale"]
), 1]]
data.to.plot[vals.2, "ptcolor"] <- palette.2[as.matrix(
x = data.to.plot[vals.2, "avg.exp.scale"]
), 1]]
if (! (x = gene.groups)) {
(x = gene.groups) <- genes.plot
data.to.plot %>%
mutate(gene.groups = gene.groups[genes.plot]) -> data.to.plot
}
p <- ggplot( = data.to.plot, mapping = aes(x = genes.plot, y = id)) +
geom_point(mapping = aes(size = pct.exp, color = ptcolor)) +
scale_radius( = (0, dot.scale)) +
scale_color_identity() +
theme(axis.title.x = element_blank(), axis.title.y = element_blank())
if (! (x = gene.groups)) {
p <- p +
facet_grid(
facets = ~gene.groups,
scales = "free_x",
space = "free_x",
= "y"
) +
theme(
panel.spacing = (x = 1, = "lines"),
strip.background = element_blank(),
strip.placement = "outside"
)
}
if (! plot.legend) {
p <- p + theme(legend.position = "none")
}
if (x.lab.rot) {
p <- p + theme(axis.text.x = element_text(angle = 90, vjust = 0.5))
}
((p))
if (do.return) {
(p)
}
}
#' Visualize 'features' on a dimensional reduction plot
#'
#' Colors single cells on a dimensional reduction plot according to a 'feature'
#' (i.e. gene expression, PC scores, number of genes detected, etc.)
#'
#'
#' @param object Seurat object
#' @param features.plot Vector of features to plot
#' @param min.cutoff Vector of minimum cutoff values for each feature, may specify quantile in the form of 'q##' where '##' is the quantile (eg, 1, 10)
#' @param max.cutoff Vector of maximum cutoff values for each feature, may specify quantile in the form of 'q##' where '##' is the quantile (eg, 1, 10)
#' @param dim.1 Dimension for x-axis (default 1)
#' @param dim.2 Dimension for y-axis (default 2)
#' @param cells.use Vector of cells to plot (default is all cells)
#' @param pt.size Adjust point size for plotting
#' @param cols.use The two colors to form the gradient over. Provide as string vector with
#' the first color corresponding to low values, the second to high. Also accepts a Brewer
#' color scale or vector of colors. Note: this will bin the data into number of colors provided.
#' @param pch.use Pch for plotting
#' @param overlay Plot two features overlayed one on top of the other
#' @param do.hover Enable hovering over points to view information
#' @param data.hover Data to add to the hover, pass a character vector of features to add. Defaults to cell name and identity. Pass 'NULL' to remove extra data.
#' @param do.identify Opens a locator session to identify clusters of cells
#' @param reduction.use Which dimensionality reduction to use. Default is
#' "tsne", can also be "pca", or "ica", assuming these are precomputed.
#' @param use.imputed Use imputed values for gene expression (default is FALSE)
#' @param nCol Number of columns to use when plotting multiple features.
#' @param no.axes Remove axis labels
#' @param no.legend Remove legend from the graph. Default is TRUE.
#' @param dark.theme Plot in a dark theme
#' @param do.return return the ggplot2 object
#'
#' @importFrom RColorBrewer brewer.pal.info
#'
#' @return No return value, only a graphical output
#'
#' @export
#'
<- (
object,
features.plot,
min.cutoff = ,
max.cutoff = ,
dim.1 = 1,
dim.2 = 2,
cells.use = ,
pt.size = 1,
cols.use = ("yellow", "red"),
pch.use = 16,
overlay = ,
do.hover = ,
data.hover = 'ident',
do.identify = ,
reduction.use = "tsne",
use.imputed = ,
nCol = ,
no.axes = ,
no.legend = ,
dark.theme = ,
do.return =
) {
cells.use <- SetIfNull(x = cells.use, default = (x = object@))
if ((x = nCol)) {
nCol <- 2
if ((x = features.plot) == 1) {
nCol <- 1
}
if ((x = features.plot) > 6) {
nCol <- 3
}
if ((x = features.plot) > 9) {
nCol <- 4
}
}
num.row <- (x = (x = features.plot) / nCol - 1e-5) + 1
if (overlay | do.hover) {
num.row <- 1
nCol <- 1
}
(mfrow = (num.row, nCol))
dim.code <- (
object = object,
reduction.type = reduction.use,
= 'key'
)
dim.codes <- (dim.code, (dim.1, dim.2))
data.plot <- ((
object = object,
reduction.type = reduction.use,
dims.use = (dim.1, dim.2),
cells.use = cells.use
))
x1 <- (dim.code, dim.1)
x2 <- (dim.code, dim.2)
data.plot$x <- data.plot, x1]
data.plot$y <- data.plot, x2]
data.plot$pt.size <- pt.size
(x = data.plot) <- ('x', 'y')
data.use <- (x = (
object = object,
vars.all = features.plot,
cells.use = cells.use,
use.imputed = use.imputed
))
# Check mins and maxes
min.cutoff <- (
FUN = (cutoff, feature) {
(
test = (x = cutoff),
yes = (data.use[feature, ]),
no = cutoff
)
},
cutoff = min.cutoff,
feature = features.plot
)
max.cutoff <- (
FUN = (cutoff, feature) {
(
test = (x = cutoff),
yes = (data.use[feature, ]),
no = cutoff
)
},
cutoff = max.cutoff,
feature = features.plot
)
check_lengths = (x = (
X = (features.plot, min.cutoff, max.cutoff),
FUN = ,
FUN.VALUE = ( = 1)
))
if ((x = check_lengths) != 1) {
('There must be the same number of minimum and maximum cuttoffs as there are features')
}
if (overlay) {
# Wrap as a list for MutiPlotList
pList <- (
BlendPlot(
data.use = data.use,
features.plot = features.plot,
data.plot = data.plot,
pt.size = pt.size,
pch.use = pch.use,
cols.use = cols.use,
dim.codes = dim.codes,
min.cutoff = min.cutoff,
max.cutoff = max.cutoff,
no.axes = no.axes,
no.legend = no.legend,
dark.theme = dark.theme
)
)
} {
# Use mapply instead of lapply for multiple iterative variables.
pList <- (
FUN = SingleFeaturePlot,
feature = features.plot,
min.cutoff = min.cutoff,
max.cutoff = max.cutoff,
MoreArgs = ( # Arguments that are not being repeated
data.use = data.use,
data.plot = data.plot,
pt.size = pt.size,
pch.use = pch.use,
cols.use = cols.use,
dim.codes = dim.codes,
no.axes = no.axes,
no.legend = no.legend,
dark.theme = dark.theme
),
SIMPLIFY = # Get list, not matrix
)
}
if (do.hover) {
if ((x = pList) != 1) {
("'do.hover' only works on a single feature or an overlayed FeaturePlot")
}
if ((x = data.hover)) {
features.info <-
} {
features.info <- (object = object, vars.all = data.hover)
}
# Use pList[[1]] to properly extract the ggplot out of the plot list
((
= pList[1]],
data.plot = data.plot,
features.info = features.info,
dark.theme = dark.theme,
= features.plot
))
# invisible(readline(prompt = 'Press <Enter> to continue\n'))
} if (do.identify) {
if ((x = pList) != 1) {
("'do.identify' only works on a single feature or an overlayed FeaturePlot")
}
# Use pList[[1]] to properly extract the ggplot out of the plot list
((
= pList[1]],
data.plot = data.plot,
dark.theme = dark.theme
))
} {
(x = cowplot::plot_grid(plotlist = pList, = nCol))
}
ResetPar()
if (do.return){
(pList)
}
}
#' Vizualization of multiple features
#'
#' Similar to FeaturePlot, however, also splits the plot by visualizing each
#' identity class separately.
#'
#' Particularly useful for seeing if the same groups of cells co-exhibit a
#' common feature (i.e. co-express a gene), even within an identity class. Best
#' understood by example.
#'
#' @param object Seurat object
#' @param features.plot Vector of features to plot
#' @param dim.1 Dimension for x-axis (default 1)
#' @param dim.2 Dimension for y-axis (default 2)
#' @param idents.use Which identity classes to display (default is all identity
#' classes)
#' @param pt.size Adjust point size for plotting
#' @param cols.use Ordered vector of colors to use for plotting. Default is
#' heat.colors(10).
#' @param pch.use Pch for plotting
#' @param reduction.use Which dimensionality reduction to use. Default is
#' "tsne", can also be "pca", or "ica", assuming these are precomputed.
#' @param group.by Group cells in different ways (for example, orig.ident)
#' @param sep.scale Scale each group separately. Default is FALSE.
#' @param max.exp Max cutoff for scaled expression value, supports quantiles in the form of 'q##' (see FeaturePlot)
#' @param min.exp Min cutoff for scaled expression value, supports quantiles in the form of 'q##' (see FeaturePlot)
#' @param rotate.key rotate the legend
#' @param plot.horiz rotate the plot such that the features are columns, groups are the rows
#' @param key.position position of the legend ("top", "right", "bottom", "left")
#' @param do.return Return the ggplot2 object
#'
#' @return No return value, only a graphical output
#'
#' @importFrom dplyr %>% mutate_each group_by select ungroup
#'
#' @seealso \code{FeaturePlot}
#'
#' @export
#'
<- (
object,
features.plot,
dim.1 = 1,
dim.2 = 2,
idents.use = ,
pt.size = 2,
cols.use = ("grey", "red"),
pch.use = 16,
reduction.use = "tsne",
group.by = ,
sep.scale = ,
do.return = ,
min.exp = -,
max.exp = ,
rotate.key = ,
plot.horiz = ,
key.position = "right"
) {
if (! (x = group.by)) {
object <- (object = object, id = group.by)
}
idents.use <- SetIfNull(x = idents.use, default = (x = (x = object@ident)))
(mfrow = ((x = features.plot), (x = idents.use)))
dim.code <- (
object = object,
reduction.type = reduction.use,
= 'key'
)
dim.codes <- (dim.code, (dim.1, dim.2))
data.plot <- ((
object = object,
vars.all = (dim.codes, features.plot)
))
(x = data.plot)[1:2] <- ("dim1", "dim2")
data.plot$ident <- (x = object@ident)
data.plot$cell <- (x = data.plot)
features.plot <- ('-', '\\.', features.plot)
data.plot %>% gather(gene, , features.plot, -dim1, -dim2, -ident, -cell) -> data.plot
if (sep.scale) {
data.plot %>% group_by(ident, gene) %>% mutate(scaled.expression = ()) -> data.plot
} {
data.plot %>% group_by(gene) %>% mutate(scaled.expression = ()) -> data.plot
}
min.exp <- SetQuantile(cutoff = min.exp, = data.plot$scaled.expression)
max.exp <- SetQuantile(cutoff = max.exp, = data.plot$scaled.expression)
data.plot$gene <- (x = data.plot$gene, = features.plot)
data.plot$scaled.expression <- (
= data.plot$scaled.expression,
= min.exp,
= max.exp
)
if (rotate.key) {
key.direction <- "horizontal"
key.title.pos <- "top"
} {
key.direction <- "vertical"
key.title.pos <- "left"
}
p <- ggplot( = data.plot, mapping = aes(x = dim1, y = dim2)) +
geom_point(mapping = aes(colour = scaled.expression), size = pt.size)
if (rotate.key) {
p <- p + scale_colour_gradient(
low = cols.use[1],
high = cols.use[2],
guide = guide_colorbar(
direction = key.direction,
title.position = key.title.pos,
= "Scaled Expression"
)
)
} {
p <- p + scale_colour_gradient(
low = cols.use[1],
high = cols.use[2],
guide = guide_colorbar( = "Scaled Expression")
)
}
(plot.horiz){
p <- p + facet_grid(ident ~ gene)
}
{
p <- p + facet_grid(gene ~ ident)
}
p2 <- p +
theme_bw() +
NoGrid() +
ylab(label = dim.codes[2]) +
xlab(label = dim.codes[1])
p2 <- p2 + theme(legend.position = key.position)
if (do.return) {
(p2)
}
(p2)
}
#' Gene expression heatmap
#'
#' Draws a heatmap of single cell gene expression using the heatmap.2 function. Has been replaced by the ggplot2
#' version (now in DoHeatmap), but kept for legacy
#'
#' @param object Seurat object
#' @param cells.use Cells to include in the heatmap (default is all cells)
#' @param genes.use Genes to include in the heatmap (ordered)
#' @param disp.min Minimum display value (all values below are clipped)
#' @param disp.max Maximum display value (all values above are clipped)
#' @param draw.line Draw vertical lines delineating cells in different identity
#' classes.
#' @param do.return Default is FALSE. If TRUE, return a matrix of scaled values
#' which would be passed to heatmap.2
#' @param order.by.ident Order cells in the heatmap by identity class (default
#' is TRUE). If FALSE, cells are ordered based on their order in cells.use
#' @param col.use Color palette to use
#' @param slim.col.label if (order.by.ident==TRUE) then instead of displaying
#' every cell name on the heatmap, display only the identity class name once
#' for each group
#' @param group.by If (order.by.ident==TRUE) default, you can group cells in
#' different ways (for example, orig.ident)
#' @param remove.key Removes the color key from the plot.
#' @param cex.col positive numbers, used as cex.axis in for the column axis labeling.
#' The defaults currently only use number of columns
#' @param do.scale whether to use the data or scaled data
#' @param ... Additional parameters to heatmap.2. Common examples are cexRow
#' and cexCol, which set row and column text sizes
#'
#' @return If do.return==TRUE, a matrix of scaled values which would be passed
#' to heatmap.2. Otherwise, no return value, only a graphical output
#'
#' @importFrom gplots heatmap.2
#'
#' @export
#'
<- (
object,
cells.use = ,
genes.use = ,
disp.min = ,
disp.max = ,
draw.line = ,
do.return = ,
order.by.ident = ,
col.use = PurpleAndYellow(),
slim.col.label = ,
group.by = ,
remove.key = ,
cex.col = ,
do.scale = ,
) {
cells.use <- SetIfNull(x = cells.use, default = object@cell.names)
cells.use <- (x = cells.use, y = object@cell.names)
cells.ident <- object@ident[cells.use]
if (! (x = group.by)) {
cells.ident <- (x = (
object = object,
vars.all = group.by
), 1])
}
cells.ident <- (
x = cells.ident,
= (x = (x = cells.ident), y = cells.ident)
)
if (order.by.ident) {
cells.use <- cells.use[order(cells.ident)]
} {
cells.ident <- (
x = cells.ident,
= (x = (x = cells.ident))
)
}
#determine assay type
data.use <-
assays.use <- ("RNA", (x = object@assay))
if (do.scale) {
slot.use <- "scale.data"
if (((x = disp.min) || (x = disp.max))) {
disp.min <- -2.5
disp.max <- 2.5
}
} {
slot.use <- "data"
if (((x = disp.min) || (x = disp.max))) {
disp.min <- -
disp.max <-
}
}
for (assay.check assays.use) {
data.assay <- (
object = object,
assay.type = assay.check,
= slot.use
)
genes.intersect <- (x = genes.use, y = (x = data.assay))
new.data <- data.assay[genes.intersect, cells.use, = ]
if (! ((x = new.data))) {
new.data <- (x = new.data)
}
data.use <- (data.use, new.data)
}
data.use <- ( = data.use, = disp.min, = disp.max)
vline.use <-
colsep.use <-
if (remove.key) {
hmFunction <- heatmap2NoKey
} {
hmFunction <- heatmap.2
}
if (draw.line) {
colsep.use <- (x = (cells.ident))
}
if (slim.col.label && order.by.ident) {
col.lab <- ("", (x = cells.use))
col.lab[round(x = (x = (cells.ident)) - (cells.ident) / 2) + 1] <- (x = cells.ident)
cex.col <- SetIfNull(
x = cex.col,
default = 0.2 + 1 / (x = (x = (x = cells.ident)))
)
hmFunction(
data.use,
Rowv = ,
Colv = ,
= "none",
= col.use,
colsep = colsep.use,
labCol = col.lab,
cexCol = cex.col,
)
} if (slim.col.label) {
col.lab = ("", (x = cells.use))
cex.col <- SetIfNull(
x = cex.col,
default = 0.2 + 1 / (x = (x = (x = cells.ident)))
)
hmFunction(
data.use,
Rowv = ,
Colv = ,
= "none",
= col.use,
colsep = colsep.use,
labCol = col.lab,
cexCol = cex.col,
)
} {
hmFunction(
data.use,
Rowv = ,
Colv = ,
= "none",
= col.use,
colsep = colsep.use,
)
}
if (do.return) {
(data.use)
}
}
#' JackStraw Plot
#'
#' Plots the results of the JackStraw analysis for PCA significance. For each
#' PC, plots a QQ-plot comparing the distribution of p-values for all genes
#' across each PC, compared with a uniform distribution. Also determines a
#' p-value for the overall significance of each PC (see Details).
#'
#' Significant PCs should show a p-value distribution (black curve) that is
#' strongly skewed to the left compared to the null distribution (dashed line)
#' The p-value for each PC is based on a proportion test comparing the number
#' of genes with a p-value below a particular threshold (score.thresh), compared with the
#' proportion of genes expected under a uniform distribution of p-values.
#'
#' @param object Seurat plot
#' @param PCs Which PCs to examine
#' @param nCol Number of columns
#' @param score.thresh Threshold to use for the proportion test of PC
#' significance (see Details)
#' @param plot.x.lim X-axis maximum on each QQ plot.
#' @param plot.y.lim Y-axis maximum on each QQ plot.
#'
#' @return A ggplot object
#'
#' @author Thanks to Omri Wurtzel for integrating with ggplot
#'
#' @import gridExtra
#' @importFrom stats qqplot runif prop.test qunif
#'
#' @export
#'
<- (
object,
PCs = 1:5,
nCol = 3,
score.thresh = 1e-5,
plot.x.lim = 0.1,
plot.y.lim = 0.3
) {
pAll <- (object,reduction.type = "pca", = "jackstraw")@emperical.p.value
pAll <- pAll, PCs, = ]
pAll <- (pAll)
pAll$Contig <- (x = pAll)
pAll.l <- melt( = pAll, id.vars = "Contig")
(x = pAll.l) <- ("Contig", "PC", "Value")
qq.df <-
score.df <-
for (i PCs) {
<- (x = pAll, i], y = (n = 1000), plot.it = )
#pc.score=mean(q$y[which(q$x <=score.thresh)])
pc.score <- ((
x = (
(x = (x = pAll, i] <= score.thresh)),
(x = (x = pAll) * score.thresh)
),
n = ((pAll), (pAll))
)$p.val)
if ((x = (x = pAll, i] <= score.thresh)) == 0) {
pc.score <- 1
}
if ((x = score.df)) {
score.df <- (PC = ("PC", i), Score = pc.score)
} {
score.df <- (score.df, (PC = ("PC",i), Score = pc.score))
}
if ((x = qq.df)) {
qq.df <- (x = $x, y = $y, PC = ("PC", i))
} {
qq.df <- (qq.df, (x = $x, y = $y, PC = ("PC", i)))
}
}
# create new dataframe column to wrap on that includes the PC number and score
pAll.l$PC.Score <- (
x = (score.df$PC, " ", ("%1.3g", score.df$Score)),
each = (x = (x = pAll.l$Contig))
)
pAll.l$PC.Score <- (
x = pAll.l$PC.Score,
= (score.df$PC, " ", ("%1.3g", score.df$Score))
)
gp <- ggplot( = pAll.l, mapping = aes(=Value)) +
stat_qq( = ) +
facet_wrap("PC.Score", = nCol) +
labs(x = "Theoretical [runif(1000)]", y = "Empirical") +
(0, plot.y.lim) +
(0, plot.x.lim) +
coord_flip() +
geom_abline(intercept = 0, slope = 1, linetype = "dashed", na.rm = ) +
theme_bw()
(gp)
}
#' Scatter plot of single cell data
#'
#' Creates a scatter plot of two features (typically gene expression), across a
#' set of single cells. Cells are colored by their identity class.
#'
#' @param object Seurat object
#' @inheritParams FetchData
#' @param gene1 First feature to plot. Typically gene expression but can also
#' be metrics, PC scores, etc. - anything that can be retreived with FetchData
#' @param gene2 Second feature to plot.
#' @param cell.ids Cells to include on the scatter plot.
#' @param col.use Colors to use for identity class plotting.
#' @param pch.use Pch argument for plotting
#' @param cex.use Cex argument for plotting
#' @param use.imputed Use imputed values for gene expression (Default is FALSE)
#' @param use.scaled Use scaled data
#' @param use.raw Use raw data
#' @param do.hover Enable hovering over points to view information
#' @param data.hover Data to add to the hover, pass a character vector of features to add. Defaults to cell name and ident. Pass 'NULL' to clear extra information.
#' @param do.identify Opens a locator session to identify clusters of cells.
#' @param dark.theme Use a dark theme for the plot
#' @param do.spline Add a spline (currently hardwired to df=4, to be improved)
#' @param spline.span spline span in loess function call
#' @param \dots Additional arguments to be passed to plot.
#'
#' @return No return, only graphical output
#'
#' @export
#'
<- (
object,
gene1,
gene2,
cell.ids = ,
col.use = ,
pch.use = 16,
cex.use = 1.5,
use.imputed = ,
use.scaled = ,
use.raw = ,
do.hover = ,
data.hover = 'ident',
do.identify = ,
dark.theme = ,
do.spline = ,
spline.span = 0.75,
) {
cell.ids <- SetIfNull(x = cell.ids, default = object@cell.names)
# Don't transpose the data.frame for better compatability with FeatureLocator and the rest of Seurat
data.use <- (
x = (
object = object,
vars.all = (gene1, gene2),
cells.use = cell.ids,
use.imputed = use.imputed,
use.scaled = use.scaled,
use.raw = use.raw
)
)
# Ensure that our data is only the cells we're working with and
# the genes we want. This step seems kind of redundant though...
data.plot <- data.use[cell.ids, (gene1, gene2)]
# Set names to 'x' and 'y' for easy calling later on
(x = data.plot) <- ('x', 'y')
ident.use <- (x = object@ident[cell.ids])
if ((x = col.use) > 1) {
col.use <- col.use[as.numeric(x = ident.use)]
} {
col.use <- SetIfNull(x = col.use, default = (x = ident.use))
}
gene.cor <- (x = (x = data.plot$x, y = data.plot$y), digits = 2)
if (dark.theme) {
(bg = 'black')
col.use <- (
X = col.use,
FUN = (color) (
test = ((color) == 0),
yes = 'white',
no = color
)
)
axes =
col.lab = 'white'
} {
axes =
col.lab = 'black'
}
# Plot the data
(
x = data.plot$x,
y = data.plot$y,
xlab = gene1,
ylab = gene2,
= col.use,
cex = cex.use,
main = gene.cor,
= pch.use,
axes = axes,
col.lab = col.lab,
col.main = col.lab,
)
if (dark.theme) {
(
side = 1,
at = ,
= ,
col.axis = col.lab,
= col.lab
)
(
side = 2,
at = ,
= ,
col.axis = col.lab,
= col.lab
)
}
if (do.spline) {
# spline.fit <- smooth.spline(x = g1, y = g2, df = 4)
spline.fit <- (x = data.plot$x, y = data.plot$y, = 4)
#lines(spline.fit$x,spline.fit$y,lwd=3)
#spline.fit=smooth.spline(g1,g2,df = 4)
# loess.fit <- loess(formula = g2 ~ g1, span=spline.span)
loess.fit <- ( = y ~ x, = data.plot, span = spline.span)
#lines(spline.fit$x,spline.fit$y,lwd=3)
# points(x = g1, y = loess.fit$fitted, col="darkblue")
(x = data.plot$x, y = loess.fit$, = 'darkblue')
}
if (do.identify | do.hover) {
# This is where that untransposed renamed data.frame comes in handy
p <- ggplot2::ggplot( = data.plot, mapping = aes(x = x, y = y))
p <- p + geom_point(
mapping = aes(color = ),
size = cex.use,
shape = pch.use,
color = col.use
)
p <- p + labs( = gene.cor, x = gene1, y = gene2)
if (do.hover) {
(x = data.plot) <- (gene1, gene2)
if ((x = data.hover)) {
features.info <-
} {
features.info <- (object = object, vars.all = data.hover)
}
((
= p,
data.plot = data.plot,
features.info = features.info,
dark.theme = dark.theme,
= gene.cor
))
} if (do.identify) {
((
= p,
data.plot = data.plot,
dark.theme = dark.theme
))
}
}
}
#' Cell-cell scatter plot
#'
#' Creates a plot of scatter plot of genes across two single cells
#'
#' @param object Seurat object
#' @param cell1 Cell 1 name (can also be a number, representing the position in
#' object@@cell.names)
#' @param cell2 Cell 2 name (can also be a number, representing the position in
#' object@@cell.names)
#' @param gene.ids Genes to plot (default, all genes)
#' @param col.use Colors to use for the points
#' @param nrpoints.use Parameter for smoothScatter
#' @param pch.use Point symbol to use
#' @param cex.use Point size
#' @param do.hover Enable hovering over points to view information
#' @param do.identify Opens a locator session to identify clusters of cells.
#' points to reveal gene names (hit ESC to stop)
#' @param \dots Additional arguments to pass to smoothScatter
#'
#' @return No return value (plots a scatter plot)
#'
#' @importFrom stats cor
#' @importFrom graphics smoothScatter
#'
#' @export
#'
<- (
object,
cell1,
cell2,
gene.ids = ,
col.use = "black",
nrpoints.use = ,
pch.use = 16,
cex.use = 0.5,
do.hover = ,
do.identify = ,
) {
gene.ids <- SetIfNull(x = gene.ids, default = (x = object@))
# Transpose this data.frame so that the genes are in the row for
# easy selecting with do.identify
data.plot <- (
x = (
x = (
object = object,
vars.all = gene.ids,
cells.use = (cell1, cell2)
)
)
)
# Set names for easy calling with ggplot
(x = data.plot) <- ('x', 'y')
gene.cor <- (x = (x = data.plot$x, y = data.plot$y), digits = 2)
(
x = data.plot$x,
y = data.plot$y,
xlab = cell1,
ylab = cell2,
= col.use,
nrpoints = nrpoints.use,
= pch.use,
cex = cex.use,
main = gene.cor
)
if (do.identify | do.hover) {
# This is where that untransposed renamed data.frame comes in handy
p <- ggplot2::ggplot( = data.plot, mapping = aes(x = x, y = y))
p <- p + geom_point(
mapping = aes(color = ),
size = cex.use,
shape = pch.use,
color = col.use
)
p <- p + labs( = gene.cor, x = cell1, y = cell2)
if (do.hover) {
(x = data.plot) <- (cell1, cell2)
(( = p, data.plot = data.plot, = gene.cor))
} if (do.identify) {
(( = p, data.plot = data.plot, ))
}
}
}
#' Dimensional reduction heatmap
#'
#' Draws a heatmap focusing on a principal component. Both cells and genes are sorted by their
#' principal component scores. Allows for nice visualization of sources of heterogeneity in the dataset.
#'
#' @param object Seurat object.
#' @param reduction.type Which dimmensional reduction t use
#' @param dim.use Dimensions to plot
#' @param cells.use A list of cells to plot. If numeric, just plots the top cells.
#' @param num.genes NUmber of genes to plot
#' @param use.full Use the full PCA (projected PCA). Default is FALSE
#' @param disp.min Minimum display value (all values below are clipped)
#' @param disp.max Maximum display value (all values above are clipped)
#' @param do.return If TRUE, returns plot object, otherwise plots plot object
#' @param col.use Color to plot.
#' @param use.scale Default is TRUE: plot scaled data. If FALSE, plot raw data on the heatmap.
#' @param do.balanced Plot an equal number of genes with both + and - scores.
#' @param remove.key Removes the color key from the plot.
#' @param label.columns Labels for columns
#' @param ... Extra parameters for heatmap plotting.
#'
#' @return If do.return==TRUE, a matrix of scaled values which would be passed
#' to heatmap.2. Otherwise, no return value, only a graphical output
#'
#' @importFrom graphics par
#'
#' @export
#'
<- (
object,
reduction.type = "pca",
dim.use = 1,
cells.use = ,
num.genes = 30,
use.full = ,
disp.min = -2.5,
disp.max = 2.5,
do.return = ,
col.use = PurpleAndYellow(),
use.scale = ,
do.balanced = ,
remove.key = ,
label.columns = ,
) {
num.row <- (x = (x = dim.use) / 3.01) + 1
orig_par <- ()$mfrow
(mfrow = (num.row, ((x = dim.use), 3)))
cells <- cells.use
plots <- ()
if ((x = label.columns)) {
label.columns <- ! ((x = dim.use) > 1)
}
for (ndim dim.use) {
if ((x = (cells))) {
cells.use <- (
object = object,
dim.use = ndim,
reduction.type = reduction.type,
num.cells = cells,
do.balanced = do.balanced
)
} {
cells.use <- SetIfNull(x = cells, default = object@cell.names)
}
genes.use <- (x = (
object = object,
dim.use = ndim,
reduction.type = reduction.type,
num.genes = num.genes,
use.full = use.full,
do.balanced = do.balanced
))
dim.scores <- (
object = object,
reduction.type = reduction.type,
= "cell.embeddings"
)
dim.key <- (
object = object,
reduction.type = reduction.type,
= "key"
)
cells.ordered <- cells.use[order(dim.scores[cells.use, (dim.key, ndim)])]
#determine assay type
data.use <-
assays.use <- ("RNA", (x = object@assay))
if (! use.scale) {
slot.use="data"
} {
slot.use <- "scale.data"
}
for (assay.check assays.use) {
data.assay <- (
object = object,
assay.type = assay.check,
= slot.use
)
genes.intersect <- (x = genes.use, y = (x = data.assay))
new.data <- data.assay[genes.intersect, cells.ordered]
if (! (x = new.data)) {
new.data <- (x = new.data)
}
data.use <- (data.use, new.data)
}
#data.use <- object@scale.data[genes.use, cells.ordered]
data.use <- ( = data.use, = disp.min, = disp.max)
#if (!(use.scale)) data.use <- as.matrix(object@data[genes.use, cells.ordered])
vline.use <-
hmTitle <- (dim.key, ndim)
if (remove.key || (dim.use) > 1) {
hmFunction <- "heatmap2NoKey(data.use, Rowv = NA, Colv = NA, trace = \"none\", col = col.use, dimTitle = hmTitle, "
} {
hmFunction <- "heatmap.2(data.use,Rowv=NA,Colv=NA,trace = \"none\",col=col.use, dimTitle = hmTitle, "
}
if (! label.columns) {
hmFunction <- (hmFunction, "labCol='', ")
}
hmFunction <- (hmFunction, "...)")
#print(hmFunction)
(expr = ( = hmFunction))
}
if (do.return) {
(data.use)
}
# reset graphics parameters
(mfrow = orig_par)
}
#' Principal component heatmap
#'
#' Draws a heatmap focusing on a principal component. Both cells and genes are sorted by their principal component scores.
#' Allows for nice visualization of sources of heterogeneity in the dataset.
#'
#' @param object Seurat object.
#' @param pc.use PCs to plot
#' @param cells.use A list of cells to plot. If numeric, just plots the top cells.
#' @param num.genes Number of genes to plot
#' @param use.full Use the full PCA (projected PCA). Default is FALSE
#' @param disp.min Minimum display value (all values below are clipped)
#' @param disp.max Maximum display value (all values above are clipped)
#' @param do.return If TRUE, returns plot object, otherwise plots plot object
#' @param col.use Color to plot.
#' @param use.scale Default is TRUE: plot scaled data. If FALSE, plot raw data on the heatmap.
#' @param do.balanced Plot an equal number of genes with both + and - scores.
#' @param remove.key Removes the color key from the plot.
#' @param label.columns Whether to label the columns. Default is TRUE for 1 PC, FALSE for > 1 PC
#' @param ... Extra parameters for DimHeatmap
#'
#' @return If do.return==TRUE, a matrix of scaled values which would be passed
#' to heatmap.2. Otherwise, no return value, only a graphical output
#'
#' @export
#'
<- (
object,
pc.use = 1,
cells.use = ,
num.genes = 30,
use.full = ,
disp.min = -2.5,
disp.max = 2.5,
do.return = ,
col.use = PurpleAndYellow(),
use.scale = ,
do.balanced = ,
remove.key = ,
label.columns = ,
) {
((
object,
reduction.type = "pca",
dim.use = pc.use,
cells.use = cells.use,
num.genes = num.genes,
use.full = use.full,
disp.min = disp.min,
disp.max = disp.max,
do.return = do.return,
col.use = col.use,
use.scale = use.scale,
do.balanced = do.balanced,
remove.key = remove.key,
label.columns = label.columns,
))
}
#' Independent component heatmap
#'
#' Draws a heatmap focusing on a principal component. Both cells and genes are sorted by their
#' principal component scores. Allows for nice visualization of sources of heterogeneity
#' in the dataset."()
#'
#' @param object Seurat object
#' @param ic.use Components to use
#' @param cells.use A list of cells to plot. If numeric, just plots the top cells.
#' @param num.genes NUmber of genes to plot
#' @param disp.min Minimum display value (all values below are clipped)
#' @param disp.max Maximum display value (all values above are clipped)
#' @param do.return If TRUE, returns plot object, otherwise plots plot object
#' @param col.use Colors to plot.
#' @param use.scale Default is TRUE: plot scaled data. If FALSE, plot raw data on the heatmap.
#' @param do.balanced Plot an equal number of genes with both + and - scores.
#' @param remove.key Removes the color key from the plot.
#' @param label.columns Labels for columns
#' @param ... Extra parameters passed to DimHeatmap
#'
#' @return If do.return==TRUE, a matrix of scaled values which would be passed
#' to heatmap.2. Otherwise, no return value, only a graphical output
#'
#' @export
#'
<- (
object,
ic.use = 1,
cells.use = ,
num.genes = 30,
disp.min = -2.5,
disp.max = 2.5,
do.return = ,
col.use = PurpleAndYellow(),
use.scale = ,
do.balanced = ,
remove.key = ,
label.columns = ,
) {
((
object = object,
reduction.type = "ica",
dim.use = ic.use,
cells.use = cells.use,
num.genes = num.genes,
disp.min = disp.min,
disp.max = disp.max,
do.return = do.return,
col.use = col.use,
use.scale = use.scale,
do.balanced = do.balanced,
remove.key = remove.key,
label.columns = label.columns,
))
}
#' Visualize Dimensional Reduction genes
#'
#' Visualize top genes associated with reduction components
#'
#' @param object Seurat object
#' @param reduction.type Reduction technique to visualize results for
#' @param dims.use Number of dimensions to display
#' @param num.genes Number of genes to display
#' @param use.full Use reduction values for full dataset (i.e. projected dimensional reduction values)
#' @param font.size Font size
#' @param nCol Number of columns to display
#' @param do.balanced Return an equal number of genes with + and - scores. If FALSE (default), returns
#' the top genes ranked by the scores absolute values
#'
#' @return Graphical, no return value
#'
#' @importFrom graphics axis
#'
#' @export
#'
<- (
object,
reduction.type = "pca",
dims.use = 1:5,
num.genes = 30,
use.full = ,
font.size = 0.5,
nCol = ,
do.balanced =
) {
if (use.full) {
dim.scores <- (
object = object,
reduction.type = reduction.type,
= "gene.loadings.full"
)
} {
dim.scores <- (
object = object,
reduction.type = reduction.type,
= "gene.loadings"
)
}
if ((x = nCol)) {
if ((x = dims.use) > 6) {
nCol <- 3
} if ((x = dims.use) > 9) {
nCol <- 4
} {
nCol <- 2
}
}
num.row <- (x = (x = dims.use) / nCol - 1e-5) + 1
(mfrow = (num.row, nCol))
for (i dims.use) {
subset.use <- dim.scores[DimTopGenes(
object = object,
dim.use = i,
reduction.type = reduction.type,
num.genes = num.genes,
use.full = use.full,
do.balanced = do.balanced
), ]
(
x = subset.use, i],
y = 1:(x = subset.use),
= 16,
= "blue",
xlab = ("PC", i),
yaxt="n",
ylab=""
)
(
side = 2,
at = 1:(x = subset.use),
= (x = subset.use),
las = 1,
cex.axis = font.size
)
}
ResetPar()
}
#' Visualize PCA genes
#'
#' Visualize top genes associated with principal components
#'
#' @param object Seurat object
#' @param pcs.use Number of PCs to display
#' @param num.genes Number of genes to display
#' @param use.full Use full PCA (i.e. the projected PCA, by default FALSE)
#' @param font.size Font size
#' @param nCol Number of columns to display
#' @param do.balanced Return an equal number of genes with both + and - PC scores.
#' If FALSE (by default), returns the top genes ranked by the score's absolute values
#'
#' @return Graphical, no return value
#'
#' @export
#'
<- (
object,
pcs.use = 1:5,
num.genes = 30,
use.full = ,
font.size = 0.5,
nCol = ,
do.balanced =
) {
(
object = object,
reduction.type = "pca",
dims.use = pcs.use,
num.genes = num.genes,
use.full = use.full,
font.size = font.size,
nCol = nCol,
do.balanced = do.balanced
)
}
#' Visualize ICA genes
#'
#' Visualize top genes associated with principal components
#'
#' @param object Seurat object
#' @param ics.use Number of ICs to display
#' @param num.genes Number of genes to display
#' @param use.full Use full ICA (i.e. the projected ICA, by default FALSE)
#' @param font.size Font size
#' @param nCol Number of columns to display
#' @param do.balanced Return an equal number of genes with both + and - IC scores.
#' If FALSE (by default), returns the top genes ranked by the score's absolute values
#'
#' @return Graphical, no return value
#'
#' @export
#'
<- (
object,
ics.use = 1:5,
num.genes = 30,
use.full = ,
font.size = 0.5,
nCol = ,
do.balanced =
) {
(
object = object,
reduction.type = "ica",
dims.use = pcs.use,
num.genes = num.genes,
use.full = use.full,
font.size = font.size,
nCol = nCol,
do.balanced = do.balanced
)
}
#' Dimensional reduction plot
#'
#' Graphs the output of a dimensional reduction technique (PCA by default).
#' Cells are colored by their identity class.
#'
#' @param object Seurat object
#' @param reduction.use Which dimensionality reduction to use. Default is
#' "pca", can also be "tsne", or "ica", assuming these are precomputed.
#' @param dim.1 Dimension for x-axis (default 1)
#' @param dim.2 Dimension for y-axis (default 2)
#' @param cells.use Vector of cells to plot (default is all cells)
#' @param pt.size Adjust point size for plotting
#' @param do.return Return a ggplot2 object (default : FALSE)
#' @param do.bare Do only minimal formatting (default : FALSE)
#' @param cols.use Vector of colors, each color corresponds to an identity
#' class. By default, ggplot assigns colors.
#' @param group.by Group (color) cells in different ways (for example, orig.ident)
#' @param pt.shape If NULL, all points are circles (default). You can specify any
#' cell attribute (that can be pulled with FetchData) allowing for both different colors and
#' different shapes on cells.
#' @param do.hover Enable hovering over points to view information
#' @param data.hover Data to add to the hover, pass a character vector of features to add. Defaults to cell name and ident. Pass 'NULL' to clear extra information.
#' @param do.identify Opens a locator session to identify clusters of cells.
#' @param do.label Whether to label the clusters
#' @param label.size Sets size of labels
#' @param no.legend Setting to TRUE will remove the legend
#' @param no.axes Setting to TRUE will remove the axes
#' @param dark.theme Use a dark theme for the plot
#' @param ... Extra parameters to FeatureLocator for do.identify = TRUE
#'
#' @return If do.return==TRUE, returns a ggplot2 object. Otherwise, only
#' graphical output.
#'
#' @seealso \code{FeatureLocator}
#'
#' @import SDMTools
#' @importFrom stats median
#' @importFrom dplyr summarize group_by
#'
#' @export
#'
<- (
object,
reduction.use = "pca",
dim.1 = 1,
dim.2 = 2,
cells.use = ,
pt.size = 3,
do.return = ,
do.bare = ,
cols.use = ,
group.by = "ident",
pt.shape = ,
do.hover = ,
data.hover = 'ident',
do.identify = ,
do.label = ,
label.size = 1,
no.legend = ,
no.axes = ,
dark.theme = ,
) {
embeddings.use = (object = object, reduction.type = reduction.use, = "cell.embeddings")
if ((x = embeddings.use) == 0) {
((reduction.use, "has not been run for this object yet."))
}
cells.use <- SetIfNull(x = cells.use, default = (x = object@))
dim.code <- (
object = object,
reduction.type = reduction.use,
= "key"
)
dim.codes <- (dim.code, (dim.1, dim.2))
data.plot <- (x = embeddings.use)
# data.plot <- as.data.frame(GetDimReduction(object, reduction.type = reduction.use, slot = ""))
cells.use <- (x = cells.use, y = (x = data.plot))
data.plot <- data.plot[cells.use, dim.codes]
ident.use <- (x = object@ident[cells.use])
if (group.by != "ident") {
ident.use <- (x = (
object = object,
vars.all = group.by
)[cells.use, 1])
}
data.plot$ident <- ident.use
data.plot$x <- data.plot, dim.codes[1]]
data.plot$y <- data.plot, dim.codes[2]]
data.plot$pt.size <- pt.size
p <- ggplot( = data.plot, mapping = aes(x = x, y = y)) +
geom_point(mapping = aes(colour = (x = ident)), size = pt.size)
if (! (x = pt.shape)) {
shape.val <- (object = object, vars.all = pt.shape)[cells.use, 1]
if ((shape.val)) {
shape.val <- (x = shape.val, breaks = 5)
}
data.plot, "pt.shape"] <- shape.val
p <- ggplot( = data.plot, mapping = aes(x = x, y = y)) +
geom_point(
mapping = aes(colour = (x = ident), shape = (x = pt.shape)),
size = pt.size
)
}
if (! (x = cols.use)) {
p <- p + scale_colour_manual(values = cols.use)
}
p2 <- p +
xlab(label = dim.codes[1]]) +
ylab(label = dim.codes[2]]) +
scale_size( = (pt.size, pt.size))
p3 <- p2 +
SetXAxisGG() +
SetYAxisGG() +
SetLegendPointsGG(x = 6) +
SetLegendTextGG(x = 12) +
no.legend.title +
theme_bw() +
NoGrid()
p3 <- p3 + theme(legend.title = element_blank())
if (do.label) {
data.plot %>%
dplyr::group_by(ident) %>%
summarize(x = (x = x), y = (x = y)) -> centers
p3 <- p3 +
geom_point( = centers, mapping = aes(x = x, y = y), size = 0, alpha = 0) +
geom_text( = centers, mapping = aes(label = ident), size = label.size)
}
if (dark.theme) {
p <- p + ()
p3 <- p3 + ()
}
if (no.legend) {
p3 <- p3 + theme(legend.position = "none")
}
if (no.axes) {
p3 <- p3 + theme(
axis.line = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.ticks = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
panel.background = element_blank(),
panel.border = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
plot.background = element_blank()
)
}
if (do.identify || do.hover) {
if (do.bare) {
plot.use <- p
} {
plot.use <- p3
}
if (do.hover) {
if ((x = data.hover)) {
features.info <-
} {
features.info <- (object = object, vars.all = data.hover)
}
((
= plot.use,
data.plot = data.plot,
features.info = features.info,
dark.theme = dark.theme
))
} if (do.identify) {
((
= plot.use,
data.plot = data.plot,
dark.theme = dark.theme,
))
}
}
if (do.return) {
if (do.bare) {
(p)
} {
(p3)
}
}
if (do.bare) {
(p)
} {
(p3)
}
}
#' Plot PCA map
#'
#' Graphs the output of a PCA analysis
#' Cells are colored by their identity class.
#'
#' This function is a wrapper for DimPlot. See ?DimPlot for a full list of possible
#' arguments which can be passed in here.
#'
#' @param object Seurat object
#' @param \dots Additional parameters to DimPlot, for example, which dimensions to plot.
#'
#' @export
#'
<- (object, ) {
((object = object, reduction.use = "pca", label.size = 6, ))
}
#' Plot Diffusion map
#'
#' Graphs the output of a Diffusion map analysis
#' Cells are colored by their identity class.
#'
#' This function is a wrapper for DimPlot. See ?DimPlot for a full list of possible
#' arguments which can be passed in here.
#'
#' @param object Seurat object
#' @param \dots Additional parameters to DimPlot, for example, which dimensions to plot.
#'
#' @export
<- (object, ) {
((object = object, reduction.use = "dm", label.size = 6, ))
}
#' Plot ICA map
#'
#' Graphs the output of a ICA analysis
#' Cells are colored by their identity class.
#'
#' This function is a wrapper for DimPlot. See ?DimPlot for a full list of possible
#' arguments which can be passed in here.
#'
#' @param object Seurat object
#' @param \dots Additional parameters to DimPlot, for example, which dimensions to plot.
#'
#' @export
#'
<- (object, ) {
((object = object, reduction.use = "ica", ))
}
#' Plot tSNE map
#'
#' Graphs the output of a tSNE analysis
#' Cells are colored by their identity class.
#'
#' This function is a wrapper for DimPlot. See ?DimPlot for a full list of possible
#' arguments which can be passed in here.
#'
#' @param object Seurat object
#' @param do.label FALSE by default. If TRUE, plots an alternate view where the center of each
#' cluster is labeled
#' @param pt.size Set the point size
#' @param label.size Set the size of the text labels
#' @param cells.use Vector of cell names to use in the plot.
#' @param colors.use Manually set the color palette to use for the points
#' @param \dots Additional parameters to DimPlot, for example, which dimensions to plot.
#'
#' @seealso DimPlot
#'
#' @export
#'
<- (
object,
do.label = ,
pt.size=1,
label.size=4,
cells.use = ,
colors.use = ,
) {
((
object = object,
reduction.use = "tsne",
cells.use = cells.use,
pt.size = pt.size,
do.label = do.label,
label.size = label.size,
cols.use = colors.use,
))
}
#' Quickly Pick Relevant Dimensions
#'
#' Plots the standard deviations (or approximate singular values if running PCAFast)
#' of the principle components for easy identification of an elbow in the graph.
#' This elbow often corresponds well with the significant dims and is much faster to run than
#' Jackstraw
#'
#'
#' @param object Seurat object
#' @param reduction.type Type of dimensional reduction to plot data for
#' @param dims.plot Number of dimensions to plot sd for
#' @param xlab X axis label
#' @param ylab Y axis label
#' @param title Plot title
#'
#' @return Returns ggplot object
#'
#' @export
#'
<- (
object,
reduction.type = "pca",
dims.plot = 20,
xlab = "",
ylab = "",
= ""
) {
data.use <- (
object = object,
reduction.type = reduction.type,
= "sdev"
)
if ((data.use) == 0) {
(("No standard deviation info stored for", reduction.type))
}
if ((x = data.use) < dims.plot) {
((
"The object only has information for",
(x = data.use),
"PCs."
))
dims.plot <- (x = data.use)
}
data.use <- data.use[1:dims.plot]
dims <- 1:(x = data.use)
data.plot <- (dims, data.use)
<- ggplot( = data.plot, mapping = aes(x = dims, y = data.use)) +
geom_point()
if (reduction.type == "pca") {
<- +
labs(y = "Standard Deviation of PC", x = "PC", = )
} (reduction.type == "ica"){
<- +
labs(y = "Standard Deviation of IC", x = "IC", = )
} {
<- +
labs(y = ylab, x = xlab, = )
}
()
}
#' Quickly Pick Relevant PCs
#'
#' Plots the standard deviations (or approximate singular values if running PCAFast)
#' of the principle components for easy identification of an elbow in the graph.
#' This elbow often corresponds well with the significant PCs and is much faster to run.
#'
#' @param object Seurat object
#' @param num.pc Number of PCs to plot
#'
#' @return Returns ggplot object
#'
#' @export
#'
<- (object, num.pc = 20) {
((
object = object,
reduction.type = "pca",
dims.plot = num.pc
))
}
#' View variable genes
#'
#' @param object Seurat object
#' @param do.text Add text names of variable genes to plot (default is TRUE)
#' @param cex.use Point size
#' @param cex.text.use Text size
#' @param do.spike FALSE by default. If TRUE, color all genes starting with ^ERCC a different color
#' @param pch.use Pch value for points
#' @param col.use Color to use
#' @param spike.col.use if do.spike, color for spike-in genes
#' @param plot.both Plot both the scaled and non-scaled graphs.
#' @param do.contour Draw contour lines calculated based on all genes
#' @param contour.lwd Contour line width
#' @param contour.col Contour line color
#' @param contour.lty Contour line type
#' @param x.low.cutoff Bottom cutoff on x-axis for identifying variable genes
#' @param x.high.cutoff Top cutoff on x-axis for identifying variable genes
#' @param y.cutoff Bottom cutoff on y-axis for identifying variable genes
#' @param y.high.cutoff Top cutoff on y-axis for identifying variable genes
#'
#' @importFrom stats cor loess smooth.spline
#' @importFrom grDevices col2rgb
#' @importFrom graphics axis points smoothScatter contour points text
#'
#' @export
#'
<- (
object,
do.text = ,
cex.use = 0.5,
cex.text.use = 0.5,
do.spike = ,
pch.use = 16,
col.use = "black",
spike.col.use = "red",
plot.both = ,
do.contour = ,
contour.lwd = 3,
contour.col = "white",
contour.lty = 2,
x.low.cutoff = 0.1,
x.high.cutoff = 8,
y.cutoff = 1,
y.high.cutoff =
) {
gene.mean <- object@hvg.info, 1]
gene.dispersion <- object@hvg.info, 2]
gene.dispersion.scaled <- object@hvg.info, 3]
(x = gene.mean) <- (x = gene.dispersion) <- (x = gene.dispersion.scaled) <- (x = object@)
pass.cutoff <- (x = gene.mean)[which(
x = (
(gene.mean > x.low.cutoff) & (gene.mean < x.high.cutoff)
) &
(gene.dispersion.scaled > y.cutoff) &
(gene.dispersion.scaled < y.high.cutoff)
)]
if (do.spike) {
spike.genes <- (x = ( = object@, code = "^ERCC"))
}
if (plot.both) {
(mfrow = (1, 2))
(
x = gene.mean,
y = gene.dispersion,
= pch.use,
cex = cex.use,
= col.use,
xlab = "Average expression",
ylab = "Dispersion",
nrpoints =
)
if (do.contour) {
data.kde <- kde2d(x = gene.mean, y = gene.dispersion)
(
x = data.kde,
add = ,
lwd = contour.lwd,
= contour.col,
lty = contour.lty
)
}
if (do.spike) {
(
x = gene.mean[spike.genes],
y = gene.dispersion[spike.genes],
= 16,
cex = cex.use,
= spike.col.use
)
}
if (do.text) {
(
x = gene.mean[pass.cutoff],
y = gene.dispersion[pass.cutoff],
= pass.cutoff,
cex = cex.text.use
)
}
}
(
x = gene.mean,
y = gene.dispersion.scaled,
= pch.use,
cex = cex.use,
= col.use,
xlab = "Average expression",
ylab = "Dispersion",
nrpoints =
)
if (do.contour) {
data.kde <- kde2d(x = gene.mean, y = gene.dispersion.scaled)
(
x = data.kde,
add = ,
lwd = contour.lwd,
= contour.col,
lty = contour.lty
)
}
if (do.spike) {
(
x = gene.mean[spike.genes],
y = gene.dispersion.scaled[spike.genes],
= 16,
cex = cex.use,
= spike.col.use,
nrpoints =
)
}
if (do.text) {
(
x = gene.mean[pass.cutoff],
y = gene.dispersion.scaled[pass.cutoff],
= pass.cutoff,
cex = cex.text.use
)
}
}
#' Highlight classification results
#'
#' This function is useful to view where proportionally the clusters returned from
#' classification map to the clusters present in the given object. Utilizes the FeaturePlot()
#' function to color clusters in object.
#'
#' @param object Seurat object on which the classifier was trained and
#' onto which the classification results will be highlighted
#' @param clusters vector of cluster ids (output of ClassifyCells)
#' @param ... additional parameters to pass to FeaturePlot()
#'
#' @return Returns a feature plot with clusters highlighted by proportion of cells
#' mapping to that cluster
#'
#' @export
#'
<- (object, clusters, ) {
cluster.dist <- (x = (out)) # What is out?
object@meta.data$Classification <- ((x = object@meta.data))
for (cluster 1:(x = cluster.dist)) {
cells.to.highlight <- (object, (cluster.dist[cluster]))
if ((x = cells.to.highlight) > 0) {
object@meta.data[cells.to.highlight, ]$Classification <- cluster.dist[cluster]
}
}
if ((( = "cols.use", x = (())))) {
((object, "Classification", ))
}
cols.use = ("#f6f6f6", "black")
((object, "Classification", cols.use = cols.use, ))
}
#' Plot phylogenetic tree
#'
#' Plots previously computed phylogenetic tree (from BuildClusterTree)
#'
#' @param object Seurat object
#' @param \dots Additional arguments for plotting the phylogeny
#'
#' @return Plots dendogram (must be precomputed using BuildClusterTree), returns no value
#'
#' @importFrom ape plot.phylo
#' @importFrom ape nodelabels
#'
#' @export
#'
<- (object, ) {
if ((x = object@cluster.tree) == 0) {
("Phylogenetic tree does not exist, build using BuildClusterTree")
}
data.tree <- object@cluster.tree[1]]
plot.phylo(x = data.tree, direction = "downwards", )
nodelabels()
}
#' Color tSNE Plot Based on Split
#'
#' Returns a tSNE plot colored based on whether the cells fall in clusters
#' to the left or to the right of a node split in the cluster tree.
#'
#' @param object Seurat object
#' @param node Node in cluster tree on which to base the split
#' @param color1 Color for the left side of the split
#' @param color2 Color for the right side of the split
#' @param color3 Color for all other cells
#' @inheritDotParams TSNEPlot -object
#' @return Returns a tSNE plot
#' @export
<- (
object,
node,
color1 = "red",
color2 = "blue",
color3 = "gray",
) {
tree <- object@cluster.tree[1]]
<- tree$edge[which(x = tree$edge,1] == node), ], 2]
all.children <- DFT(
tree = tree,
node = tree$edge,1][1],
only.children =
)
left.group <- DFT(tree = tree, node = [1], only.children = )
right.group <- DFT(tree = tree, node = [2], only.children = )
if (((x = left.group))) {
left.group <- [1]
}
if (((x = right.group))) {
right.group <- [2]
}
remaining.group <- (x = all.children, y = (left.group, right.group))
left.cells <- (object = object, ident = left.group)
right.cells <- (object = object, ident = right.group)
remaining.cells <- (object = object, ident = remaining.group)
object <- (
object = object,
cells.use = left.cells,
ident.use = "Left Split"
)
object <- (
object = object,
cells.use = right.cells,
ident.use = "Right Split"
)
object <- (
object = object,
cells.use = remaining.cells,
ident.use = "Not in Split"
)
colors.use = (color1, color3, color2)
((object = object, colors.use = colors.use, ))
}
#' Plot k-means clusters
#'
#' @param object A Seurat object
#' @param cells.use Cells to include in the heatmap
#' @param genes.cluster Clusters to include in heatmap
#' @param max.genes Maximum number of genes to include in the heatmap
#' @param slim.col.label Instead of displaying every cell name on the heatmap,
#' display only the identity class name once for each group
#' @param remove.key Removes teh color key from the plot
#' @param row.lines Color separations of clusters
#' @param ... Extra parameters to DoHeatmap
#'
#' @seealso \code{DoHeatmap}
#'
#' @export
#'
<- (
object,
cells.use = object@cell.names,
genes.cluster = ,
max.genes = 1e6,
slim.col.label = ,
remove.key = ,
row.lines = ,
) {
genes.cluster <- SetIfNull(
x = genes.cluster,
default = (x = object@@gene.kmeans.obj$cluster)
)
genes.use <- (
object = object,
cluster.num = genes.cluster,
max.genes = max.genes
)
cluster.lengths <- (
X = genes.cluster,
FUN = (x) {
((x = (object = object, cluster.num = x)))
}
)
#print(cluster.lengths)
# if (row.lines) {
# rowsep.use <- cumsum(x = cluster.lengths)
# } else {
# rowsep.use <- NA
# }
(
object = object,
cells.use = cells.use,
genes.use = genes.use,
slim.col.label = slim.col.label,
remove.key = remove.key,
# rowsep = rowsep.use,
)
}
#' Node Heatmap
#'
#' Takes an object, a marker list (output of FindAllMarkers), and a node
#' and plots a heatmap where genes are ordered vertically by the splits present
#' in the object@@cluster.tree slot.
#'
#' @param object Seurat object. Must have the cluster.tree slot filled (use BuildClusterTree)
#' @param marker.list List of marker genes given from the FindAllMarkersNode function
#' @param node Node in the cluster tree from which to start the plot, defaults to highest node in marker list
#' @param max.genes Maximum number of genes to keep for each division
#' @param ... Additional parameters to pass to DoHeatmap
#'
#' @importFrom dplyr %>% group_by filter top_n select
#'
#' @return Plots heatmap. No return value.
#'
#' @export
#'
<- (object, marker.list, node = , max.genes = 10, ) {
tree <- object@cluster.tree[1]]
node <- SetIfNull(x = node, default = (marker.list$cluster))
node.order <- (node, DFT(tree = tree, node = node))
marker.list$ <- (1:(x = marker.list))
marker.list %>% group_by(cluster) %>% (avg_diff > 0) %>%
top_n(max.genes, -) %>% select(gene, cluster) -> pos.genes
marker.list %>% group_by(cluster) %>% (avg_diff < 0) %>%
top_n(max.genes, -) %>% select(gene, cluster) -> neg.genes
gene.list <- ()
node.stack <- ()
for (n node.order) {
if (NodeHasChild(tree = tree, node = n)) {
gene.list <- (
gene.list,
(
(x = pos.genes, = cluster == n)$gene,
(x = neg.genes, = cluster == n)$gene
)
)
if (NodeHasOnlyChildren(tree = tree, node = n)) {
gene.list <- (
gene.list,
(x = neg.genes, = cluster == node.stack[length(node.stack)])$gene
)
node.stack <- node.stack-(x = node.stack)]
}
}
{
gene.list <- (gene.list, (x = pos.genes, = cluster == n)$gene)
node.stack <- (x = node.stack, values = n)
}
}
#gene.list <- rev(unique(rev(gene.list)))
descendants <- GetDescendants(tree = tree, node = node)
<- descendants!descendants %in% tree$edge, 1]]
all.children <- tree$edge,2]!tree$edge,2] %in% tree$edge, 1]]
(
object = object,
cells.use = (object = object, ident = ),
genes.use = gene.list,
slim.col.label = ,
remove.key = ,
)
}
#' Posterior Plot
#'
#' @param object A Seurat object
#' @param name Spatial code
#'
#' @seealso \code{SubsetColumn}
#' @seealso \code{VlnPlot}
#'
#' @export
#'
<- (object, ) {
post.names <- (x = SubsetColumn( = object@spatial@mix.probs, code = ))
(
object = object,
features.plot = post.names,
inc.first = ,
inc.final = ,
by.k =
)
}
