forked from GabrielHoffman/dreamlet
-
Notifications
You must be signed in to change notification settings - Fork 0
/
plotHeatmap.R
126 lines (107 loc) · 3.44 KB
/
plotHeatmap.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
#' Plot heatmap
#'
#' Plot heatmap
#'
#' @param x fractions for each gene
#' @param genes name of genes to plot
#' @param color color of heatmap
#' @param assays array of assays to plot
#' @param useFillScale default TRUE. add scale_fill_gradient() to plot
#'
#' @return heatmap
#'
#' @export
#' @docType methods
#' @rdname plotHeatmap-methods
setGeneric(
"plotHeatmap",
function(x, genes = rownames(x), color = "darkblue", assays = colnames(x), useFillScale = TRUE) {
standardGeneric("plotHeatmap")
}
)
#' @examples
#' library(muscat)
#' library(SingleCellExperiment)
#'
#' data(example_sce)
#'
#' # create pseudobulk for each sample and cell cluster
#' pb <- aggregateToPseudoBulk(example_sce,
#' assay = "counts",
#' cluster_id = "cluster_id",
#' sample_id = "sample_id",
#' verbose = FALSE
#' )
#'
#' # Compute cell type specificity of each gene
#' df <- cellTypeSpecificity(pb)
#'
#' # For each cell type, get most specific gene
#' genes <- rownames(df)[apply(df, 2, which.max)]
#'
#' # heatmap of 5 genes that are most cell type specific
#' dreamlet::plotHeatmap(df, genes = genes)
#' @export
#' @importFrom reshape2 melt
#' @rdname plotHeatmap-methods
#' @aliases plotHeatmap,cellSpecificityValues,cellSpecificityValues-method
setMethod(
"plotHeatmap", "cellSpecificityValues",
function(x, genes = rownames(x), color = "darkblue", assays = colnames(x), useFillScale = TRUE) {
fig <- dreamlet::plotHeatmap(as.matrix(x)[, -1], genes, color, assays, useFillScale = FALSE)
fig <- fig +
ggtitle("Cell type specificity scores")
if (useFillScale) {
fig <- fig + scale_fill_gradient(name = "Fraction of\nexpression", low = "white", high = color, limits = c(0, 1))
}
fig
}
)
#' @export
#' @rdname plotHeatmap-methods
#' @aliases plotHeatmap,data.frame,data.frame-method
setMethod(
"plotHeatmap", "data.frame",
function(x, genes = rownames(x), color = "darkblue", assays = colnames(x), useFillScale = TRUE) {
dreamlet::plotHeatmap(as.matrix(x), genes, color, assays, useFillScale = useFillScale)
}
)
#' @export
#' @importFrom reshape2 melt
#' @rdname plotHeatmap-methods
#' @aliases plotHeatmap,matrix,matrix-method
setMethod(
"plotHeatmap", "matrix",
function(x, genes = rownames(x), color = "darkblue", assays = colnames(x), useFillScale = TRUE) {
genes <- genes[!is.na(genes)]
# intersect preserving order from assays
assays <- intersect(assays, colnames(x))
if (length(assays) == 0) stop("No valid assays selected")
x <- x[, assays, drop = FALSE]
# subset based on specified genes
x <- x[rownames(x) %in% unique(genes), , drop = FALSE]
# pass R CMD check
value <- variable <- gene <- NA
df <- data.frame(gene = rownames(x), x, check.names = FALSE)
df_melt <- reshape2::melt(df, id.vars = "gene")
df_melt$gene <- factor(df_melt$gene, unique(genes))
df_melt$variable <- factor(df_melt$variable, assays)
df_melt <- droplevels(df_melt)
ratio <- nlevels(df_melt$gene) / nlevels(df_melt$variable)
# heatmap of cell type specificity
fig <- ggplot(df_melt, aes(variable, gene, fill = value)) +
geom_tile() +
theme_classic() +
theme(
aspect.ratio = ratio,
plot.title = element_text(hjust = 0.5),
axis.text.x = element_text(angle = 60, vjust = 1, hjust = 1)
) +
xlab("") +
ylab("")
if (useFillScale) {
fig <- fig + scale_fill_gradient(name = "value", low = "white", high = color)
}
fig
}
)