|
1
|
1
|
new file mode 100644
|
|
...
|
...
|
@@ -0,0 +1,487 @@
|
|
|
1
|
+#' Plot heatmap of using data stored in SingleCellExperiment Object
|
|
|
2
|
+#' @rdname plotSCEHeatmap
|
|
|
3
|
+#' @param inSCE \linkS4class{SingleCellExperiment} inherited object.
|
|
|
4
|
+#' @param useAssay character. A string indicating the assay name that
|
|
|
5
|
+#' provides the expression level to plot. Only for \code{plotSCEHeatmap}.
|
|
|
6
|
+#' @param useReducedDim character. A string indicating the reducedDim name that
|
|
|
7
|
+#' provides the expression level to plot. Only for \code{plotSCEDimReduceHeatmap}.
|
|
|
8
|
+#' @param doLog Logical scalar. Whether to do \code{log(assay + 1)}
|
|
|
9
|
+#' transformation on the assay indicated by \code{useAssay}. Default
|
|
|
10
|
+#' \code{FALSE}.
|
|
|
11
|
+#' @param featureIndex A vector that can subset the input SCE object by rows
|
|
|
12
|
+#' (features). Alternatively, it can be a vector identifying features in
|
|
|
13
|
+#' another feature list indicated by \code{featureIndexBy}. Default \code{NULL}.
|
|
|
14
|
+#' @param cellIndex A vector that can subset the input SCE object by columns
|
|
|
15
|
+#' (cells). Alternatively, it can be a vector identifying cells in another
|
|
|
16
|
+#' cell list indicated by \code{featureIndexBy}. Default \code{NULL}.
|
|
|
17
|
+#' @param scale Whether to perform z-score scaling on each row. Default
|
|
|
18
|
+#' \code{TRUE}.
|
|
|
19
|
+#' @param trim A 2-element numeric vector. Values outside of this range will be
|
|
|
20
|
+#' trimmed to their nearst bound. Default \code{c(-2, 2)}
|
|
|
21
|
+#' @param featureIndexBy A single character specifying a column name of
|
|
|
22
|
+#' \code{rowData(inSCE)}, or a vector of the same length as \code{nrow(inSCE)},
|
|
|
23
|
+#' where we search for the non-rowname feature indices. Not applicable for
|
|
|
24
|
+#' \code{plotSCEDimReduceHeatmap}. Default \code{"rownames"}.
|
|
|
25
|
+#' @param cellIndexBy A single character specifying a column name of
|
|
|
26
|
+#' \code{colData(inSCE)}, or a vector of the same length as \code{ncol(inSCE)},
|
|
|
27
|
+#' where we search for the non-rowname cell indices. Default \code{"rownames"}.
|
|
|
28
|
+#' @param rowDataName character. The column name(s) in \code{rowData} that need
|
|
|
29
|
+#' to be added to the annotation. Not applicable for
|
|
|
30
|
+#' \code{plotSCEDimReduceHeatmap}. Default \code{NULL}.
|
|
|
31
|
+#' @param colDataName character. The column name(s) in \code{colData} that need
|
|
|
32
|
+#' to be added to the annotation. Default \code{NULL}.
|
|
|
33
|
+#' @param aggregateRow Feature variable for aggregating the heatmap by row. Can
|
|
|
34
|
+#' be a vector or a \code{rowData} column name for feature variable. Multiple
|
|
|
35
|
+#' variables are allowed. Default \code{NULL}.
|
|
|
36
|
+#' @param aggregateCol Cell variable for aggregating the heatmap by column. Can
|
|
|
37
|
+#' be a vector or a \code{colData} column name for cell variable. Multiple
|
|
|
38
|
+#' variables are allowed. Default \code{NULL}.
|
|
|
39
|
+#' @param featureAnnotations \code{data.frame}, with \code{rownames} containing
|
|
|
40
|
+#' all the features going to be plotted. Character columns should be factors.
|
|
|
41
|
+#' Default \code{NULL}.
|
|
|
42
|
+#' @param cellAnnotations \code{data.frame}, with \code{rownames} containing
|
|
|
43
|
+#' all the cells going to be plotted. Character columns should be factors.
|
|
|
44
|
+#' Default \code{NULL}.
|
|
|
45
|
+#' @param featureAnnotationColor A named list. Customized color settings for
|
|
|
46
|
+#' feature labeling. Should match the entries in the \code{featureAnnotations}
|
|
|
47
|
+#' or \code{rowDataName}. For each entry, there should be a list/vector of
|
|
|
48
|
+#' colors named with categories. Default \code{NULL}.
|
|
|
49
|
+#' @param cellAnnotationColor A named list. Customized color settings for
|
|
|
50
|
+#' cell labeling. Should match the entries in the \code{cellAnnotations} or
|
|
|
51
|
+#' \code{colDataName}. For each entry, there should be a list/vector of colors
|
|
|
52
|
+#' named with categories. Default \code{NULL}.
|
|
|
53
|
+#' @param palette Choose from \code{"ggplot"}, \code{"celda"} or \code{"random"}
|
|
|
54
|
+#' to generate unique category colors.
|
|
|
55
|
+#' @param heatmapPalette Choose from \code{"sequential"}, \code{"diverging"} or supply custom palette with colorScheme
|
|
|
56
|
+#' to generate unique category colors. Default is \code{"sequential"}
|
|
|
57
|
+#' @param addCellSummary Add summary barplots to column annotation. Supply the name of the column in colData as a character. This option will add summary for categorical variables
|
|
|
58
|
+#' as stacked barplots.
|
|
|
59
|
+#' @param rowSplitBy character. Do semi-heatmap based on the grouping of
|
|
|
60
|
+#' this(these) annotation(s). Should exist in either \code{rowDataName} or
|
|
|
61
|
+#' \code{names(featureAnnotations)}. Default \code{NULL}.
|
|
|
62
|
+#' @param colSplitBy character. Do semi-heatmap based on the grouping of
|
|
|
63
|
+#' this(these) annotation(s). Should exist in either \code{colDataName} or
|
|
|
64
|
+#' \code{names(cellAnnotations)}. Default \code{NULL}.
|
|
|
65
|
+#' @param rowLabel Use a logical for whether to display all the feature names,
|
|
|
66
|
+#' a single character to display a column of \code{rowData(inSCE)} annotation,
|
|
|
67
|
+#' a vector of the same length as full/subset \code{nrow(inSCE)} to display
|
|
|
68
|
+#' customized info. Default \code{FALSE}.
|
|
|
69
|
+#' @param colLabel Use a logical for whether to display all the cell names, a
|
|
|
70
|
+#' single character to display a column of \code{colData(inSCE)} annotation,
|
|
|
71
|
+#' a vector of the same length as full/subset \code{ncol(inSCE)} to display
|
|
|
72
|
+#' customized info. Default \code{FALSE}.
|
|
|
73
|
+#' @param rowLabelSize A number for the font size of feature names. Default
|
|
|
74
|
+#' \code{8}
|
|
|
75
|
+#' @param colLabelSize A number for the font size of cell names. Default
|
|
|
76
|
+#' \code{8}
|
|
|
77
|
+#' @param rowDend Whether to display row dendrogram. Default \code{TRUE}.
|
|
|
78
|
+#' @param colDend Whether to display column dendrogram. Default \code{TRUE}.
|
|
|
79
|
+#' @param title The main title of the whole plot. Default \code{NULL}.
|
|
|
80
|
+#' @param rowTitle The subtitle for the rows. Default \code{"Genes"}.
|
|
|
81
|
+#' @param colTitle The subtitle for the columns. Default \code{"Cells"}.
|
|
|
82
|
+#' @param rowGap A numeric value or a \code{\link[grid]{unit}} object. For the
|
|
|
83
|
+#' gap size between rows of the splitted heatmap. Default
|
|
|
84
|
+#' \code{grid::unit(0, 'mm')}.
|
|
|
85
|
+#' @param colGap A numeric value or a \code{\link[grid]{unit}} object. For the
|
|
|
86
|
+#' gap size between columns of the splitted heatmap. Default
|
|
|
87
|
+#' \code{grid::unit(0, 'mm')}.
|
|
|
88
|
+#' @param border A logical scalar. Whether to show the border of the heatmap or
|
|
|
89
|
+#' splitted heatmaps. Default \code{TRUE}.
|
|
|
90
|
+#' @param colorScheme function. A function that generates color code by giving
|
|
|
91
|
+#' a value. Can be generated by \code{\link[circlize]{colorRamp2}}.
|
|
|
92
|
+#' Default \code{NULL}.
|
|
|
93
|
+#' @param ... Other arguments passed to \code{\link[ComplexHeatmap]{Heatmap}}.
|
|
|
94
|
+#' @examples
|
|
|
95
|
+#' data(scExample, package = "singleCellTK")
|
|
|
96
|
+#' plotSCEHeatmap(sce[1:3,1:3], useAssay = "counts")
|
|
|
97
|
+#' @return A \code{\link[ggplot2]{ggplot}} object.
|
|
|
98
|
+#' @export
|
|
|
99
|
+#' @author Yichen Wang
|
|
|
100
|
+#' @importFrom scuttle aggregateAcrossCells aggregateAcrossFeatures
|
|
|
101
|
+#' @importFrom SingleCellExperiment SingleCellExperiment
|
|
|
102
|
+#' @importFrom SummarizedExperiment colData assayNames<-
|
|
|
103
|
+#' @importFrom stringr str_replace_all str_c
|
|
|
104
|
+#' @importFrom stats prcomp quantile
|
|
|
105
|
+#' @importFrom dplyr select arrange group_by count ungroup mutate one_of desc
|
|
|
106
|
+#' @importFrom tidyr spread
|
|
|
107
|
+#' @importFrom grid gpar
|
|
|
108
|
+plotSCEHeatmap <- function(inSCE, useAssay = 'logcounts', useReducedDim = NULL,
|
|
|
109
|
+ doLog = FALSE, featureIndex = NULL, cellIndex = NULL,
|
|
|
110
|
+ scale = TRUE, trim = c(-2,2),
|
|
|
111
|
+ featureIndexBy = 'rownames',
|
|
|
112
|
+ cellIndexBy = 'rownames',
|
|
|
113
|
+ rowDataName = NULL, colDataName = NULL,
|
|
|
114
|
+ aggregateRow = NULL, aggregateCol = NULL,
|
|
|
115
|
+ featureAnnotations = NULL, cellAnnotations = NULL,
|
|
|
116
|
+ featureAnnotationColor = NULL,
|
|
|
117
|
+ cellAnnotationColor = NULL,
|
|
|
118
|
+ palette = c("ggplot", "celda", "random"),
|
|
|
119
|
+ heatmapPalette = c("sequential","diverging"),
|
|
|
120
|
+ addCellSummary = NULL,
|
|
|
121
|
+ rowSplitBy = NULL, colSplitBy = NULL,
|
|
|
122
|
+ rowLabel = FALSE, colLabel = FALSE,
|
|
|
123
|
+ rowLabelSize = 6, colLabelSize = 6,
|
|
|
124
|
+ rowDend = TRUE, colDend = TRUE,
|
|
|
125
|
+ title = NULL, rowTitle = 'Features',
|
|
|
126
|
+ colTitle = 'Cells',
|
|
|
127
|
+ rowGap = grid::unit(0, 'mm'),
|
|
|
128
|
+ colGap = grid::unit(0, 'mm'),
|
|
|
129
|
+ border = FALSE, colorScheme = NULL, ...){
|
|
|
130
|
+ palette<-match.arg(palette)
|
|
|
131
|
+ heatmapPalette<-match.arg(heatmapPalette)
|
|
|
132
|
+ # STAGE 1: Create clean SCE object with only needed information ####
|
|
|
133
|
+ ## .selectSCEMatrix, .manageCellVar and .manageFeatureVar perform checks
|
|
|
134
|
+ useMat <- .selectSCEMatrix(inSCE, useAssay = useAssay,
|
|
|
135
|
+ useReducedDim = useReducedDim,
|
|
|
136
|
+ returnMatrix = TRUE, cellAsCol = TRUE)
|
|
|
137
|
+ useAssay <- useMat$names$useAssay
|
|
|
138
|
+ useReducedDim <- useMat$names$useReducedDim
|
|
|
139
|
+ useData <- ifelse(!is.null(useAssay), useAssay, useReducedDim)
|
|
|
140
|
+ ### cell annotation
|
|
|
141
|
+ oldColData <- colData(inSCE)
|
|
|
142
|
+ colDataName <- unique(c(colDataName, aggregateCol))
|
|
|
143
|
+ colDataAnns <- lapply(colDataName, function(x) .manageCellVar(inSCE, x))
|
|
|
144
|
+ if (length(colDataName) > 0)
|
|
|
145
|
+ colDataAnns <- data.frame(colDataAnns, row.names = colnames(inSCE))
|
|
|
146
|
+ else
|
|
|
147
|
+ colDataAnns <- data.frame(row.names = colnames(inSCE))
|
|
|
148
|
+ colnames(colDataAnns) <- colDataName
|
|
|
149
|
+ cellAnnotations <- .mergeAnnotationDF(colDataAnns, cellAnnotations)
|
|
|
150
|
+ if (!is.null(colSplitBy) &&
|
|
|
151
|
+ any(!colSplitBy %in% colnames(cellAnnotations)))
|
|
|
152
|
+ stop('Specified `colSplitBy` variables not found.')
|
|
|
153
|
+ if (isTRUE(colLabel)) {
|
|
|
154
|
+ colLabelName <- colnames(inSCE)
|
|
|
155
|
+ } else if (isFALSE(colLabel)) {
|
|
|
156
|
+ colLabelName <- NULL
|
|
|
157
|
+ } else {
|
|
|
158
|
+ colLabelName <- .manageCellVar(inSCE, colLabel)
|
|
|
159
|
+ colLabel <- TRUE
|
|
|
160
|
+ }
|
|
|
161
|
+ ### feature annotation
|
|
|
162
|
+ rowDataAnns <- data.frame(row.names = rownames(useMat$mat))
|
|
|
163
|
+ if (!is.null(useAssay)) {
|
|
|
164
|
+ # When using reducedDim, no rowData can be applied
|
|
|
165
|
+ rowDataName <- unique(c(rowDataName, aggregateRow))
|
|
|
166
|
+ rowDataAnns <- lapply(rowDataName, function(x) .manageFeatureVar(inSCE, x))
|
|
|
167
|
+ if (length(rowDataName) > 0)
|
|
|
168
|
+ rowDataAnns <- data.frame(rowDataAnns, row.names = rownames(inSCE))
|
|
|
169
|
+ else
|
|
|
170
|
+ rowDataAnns <- data.frame(row.names = rownames(inSCE))
|
|
|
171
|
+ colnames(rowDataAnns) <- rowDataName
|
|
|
172
|
+ }
|
|
|
173
|
+ # But customized featureAnnotations should work
|
|
|
174
|
+ featureAnnotations <- .mergeAnnotationDF(rowDataAnns, featureAnnotations)
|
|
|
175
|
+ if (!is.null(rowSplitBy) &&
|
|
|
176
|
+ any(!rowSplitBy %in% colnames(featureAnnotations)))
|
|
|
177
|
+ stop('Specified `rowSplitBy` variables not found.')
|
|
|
178
|
+ if (isTRUE(rowLabel)) {
|
|
|
179
|
+ rowLabelName <- rownames(useMat$mat)
|
|
|
180
|
+ } else if (isFALSE(rowLabel)) {
|
|
|
181
|
+ rowLabelName <- NULL
|
|
|
182
|
+ } else {
|
|
|
183
|
+ if (!is.null(useAssay)) {
|
|
|
184
|
+ rowLabelName <- .manageFeatureVar(inSCE, rowLabel)
|
|
|
185
|
+ rowLabel <- TRUE
|
|
|
186
|
+ } else {
|
|
|
187
|
+ # Using customized rowLabel for reducedDim
|
|
|
188
|
+ if (length(rowLabel) != nrow(useMat$mat))
|
|
|
189
|
+ stop("Length of `rowLabel` does not match nrow of specified ",
|
|
|
190
|
+ "`useReducedDim`")
|
|
|
191
|
+ rowLabelName <- rowLabel
|
|
|
192
|
+ rowLabel <- TRUE
|
|
|
193
|
+ }
|
|
|
194
|
+ }
|
|
|
195
|
+ ### create SCE object
|
|
|
196
|
+ SCE <- SingleCellExperiment(assay = list(useMat$mat),
|
|
|
197
|
+ colData = cellAnnotations,
|
|
|
198
|
+ rowData = featureAnnotations)
|
|
|
199
|
+ assayNames(SCE) <- useData
|
|
|
200
|
+
|
|
|
201
|
+ .minmax<-function(mat){
|
|
|
202
|
+ min_max<- function(x) {
|
|
|
203
|
+ new_x = (x - min(x))/ (max(x) - min(x))
|
|
|
204
|
+ return(new_x)}
|
|
|
205
|
+ new_mat<-as.matrix(apply(mat,FUN = min_max,MARGIN = 2))
|
|
|
206
|
+ return(new_mat)
|
|
|
207
|
+ }
|
|
|
208
|
+
|
|
|
209
|
+ # STAGE 2: Subset SCE object as needed ####
|
|
|
210
|
+ # Manage cell subsetting
|
|
|
211
|
+ if(is.null(cellIndex)){
|
|
|
212
|
+ cellIndex <- seq(ncol(SCE))
|
|
|
213
|
+ } else if (is.character(cellIndex)) {
|
|
|
214
|
+ # cellIndexBy not necessarily included in new "SCE"
|
|
|
215
|
+ cellIndex <- retrieveSCEIndex(inSCE, cellIndex, axis = "col",
|
|
|
216
|
+ by = cellIndexBy)
|
|
|
217
|
+ } else if (is.logical(cellIndex)) {
|
|
|
218
|
+ if (length(cellIndex) != ncol(inSCE)) {
|
|
|
219
|
+ stop("Logical index length does not match ncol(inSCE)")
|
|
|
220
|
+ }
|
|
|
221
|
+ cellIndex <- which(cellIndex)
|
|
|
222
|
+ }
|
|
|
223
|
+ # Manage feature subsetting
|
|
|
224
|
+ if(is.null(featureIndex)){
|
|
|
225
|
+ featureIndex <- seq(nrow(SCE))
|
|
|
226
|
+ } else if (is.character(featureIndex)) {
|
|
|
227
|
+ if (!is.null(useAssay))
|
|
|
228
|
+ featureIndex <- retrieveSCEIndex(inSCE, featureIndex, axis = "row",
|
|
|
229
|
+ by = featureIndexBy)
|
|
|
230
|
+ else
|
|
|
231
|
+ # When using reducedDim, can only go with "PC" names
|
|
|
232
|
+ # or customized "by"
|
|
|
233
|
+ featureIndex <- retrieveSCEIndex(SCE, featureIndex, axis = "row",
|
|
|
234
|
+ by = featureIndexBy)
|
|
|
235
|
+ } else if (is.logical(featureIndex)) {
|
|
|
236
|
+ if (length(featureIndex) != nrow(SCE)) {
|
|
|
237
|
+ stop("Logical index length does not match nrow(inSCE)")
|
|
|
238
|
+ }
|
|
|
239
|
+ featureIndex <- which(featureIndex)
|
|
|
240
|
+ }
|
|
|
241
|
+ colnames(SCE) <- colLabelName
|
|
|
242
|
+ rownames(SCE) <- rowLabelName
|
|
|
243
|
+ SCE <- SCE[featureIndex, cellIndex]
|
|
|
244
|
+ ### Scaling should be done before aggregating
|
|
|
245
|
+ if (isTRUE(doLog)) assay(SCE) <- log1p(assay(SCE))
|
|
|
246
|
+ if(isTRUE(scale)) scale <- "zscore"
|
|
|
247
|
+ if ((scale == "zscore")) {
|
|
|
248
|
+ assay(SCE) <- as.matrix(scale(assay(SCE)))
|
|
|
249
|
+ } else if (scale == "min_max") {
|
|
|
250
|
+ assay(SCE) <- as.matrix(.minmax(assay(SCE)))
|
|
|
251
|
+ }
|
|
|
252
|
+
|
|
|
253
|
+
|
|
|
254
|
+ # STAGE 3: Aggregate As needed ####
|
|
|
255
|
+ if (!is.null(aggregateCol)) {
|
|
|
256
|
+ # TODO: whether to also aggregate numeric variable that users want
|
|
|
257
|
+ # Might need to use "coldata.merge" in aggregate function
|
|
|
258
|
+ colIDS <- colData(SCE)[, aggregateCol]
|
|
|
259
|
+ origRowData <- rowData(SCE)
|
|
|
260
|
+ SCE <- aggregateAcrossCells(SCE, ids = colIDS,
|
|
|
261
|
+ use.assay.type = useData,
|
|
|
262
|
+ store.number = NULL, statistics = "mean")
|
|
|
263
|
+ # TODO: `aggregateAcrossCells` produce duplicated variables in colData
|
|
|
264
|
+ # and unwanted "ncell" variable even if I set `store.number = NULL`.
|
|
|
265
|
+ colData(SCE) <- colData(SCE)[,c(aggregateCol),drop=FALSE] ##change
|
|
|
266
|
+ newColnames <- do.call(paste, c(colData(SCE), list(sep = "_")))
|
|
|
267
|
+ colnames(SCE) <- newColnames
|
|
|
268
|
+ rowData(SCE) <- origRowData
|
|
|
269
|
+ }
|
|
|
270
|
+ if (!is.null(aggregateRow)) {
|
|
|
271
|
+ # `aggregateAcrossFeatures` doesn't work by with multi-var
|
|
|
272
|
+ # Remake one single variable vector
|
|
|
273
|
+ rowIDS <- rowData(SCE)[, aggregateRow, drop = FALSE]
|
|
|
274
|
+ rowIDS <- do.call(paste, c(rowIDS, list(sep = "_")))
|
|
|
275
|
+ origColData <- colData(SCE)
|
|
|
276
|
+ SCE <- aggregateAcrossFeatures(SCE, ids = rowIDS, average = TRUE,
|
|
|
277
|
+ use.assay.type = useData)
|
|
|
278
|
+ colData(SCE) <- origColData
|
|
|
279
|
+ }
|
|
|
280
|
+ # STAGE 4: Other minor preparation for plotting ####
|
|
|
281
|
+
|
|
|
282
|
+ # Create a function that sorts the matrix by PC1
|
|
|
283
|
+ .orderMatrix<-function(mat){
|
|
|
284
|
+ # Adding extra character to rownames because presence of some char gets a "." if I don't
|
|
|
285
|
+ mat2<-data.frame(t(mat))
|
|
|
286
|
+ rownames(mat2)<-stringr::str_c("K_",rownames(mat2))
|
|
|
287
|
+ pca_mat<-stats::prcomp(mat2,center = TRUE, scale. = FALSE)
|
|
|
288
|
+ kl<-dplyr::arrange(data.frame(pca_mat$x)["PC1"],desc(PC1))
|
|
|
289
|
+ mat<-data.frame(t(mat2)) %>% dplyr::select(rownames(kl))
|
|
|
290
|
+ colnames(mat)<-stringr::str_replace_all(colnames(mat),"K_","")
|
|
|
291
|
+ return(as.matrix(mat))
|
|
|
292
|
+ }
|
|
|
293
|
+
|
|
|
294
|
+ # Prepare
|
|
|
295
|
+ if(useAssay == "reducedDim"){
|
|
|
296
|
+ mat <- assay(SCE)
|
|
|
297
|
+ mat <- .orderMatrix(mat)
|
|
|
298
|
+
|
|
|
299
|
+ } else{
|
|
|
300
|
+ mat<- assay(SCE)
|
|
|
301
|
+ }
|
|
|
302
|
+
|
|
|
303
|
+
|
|
|
304
|
+
|
|
|
305
|
+ if (!is.null(trim) & scale == "zscore") {
|
|
|
306
|
+ assay(SCE) <- trimCounts(assay(SCE), trim)
|
|
|
307
|
+ }
|
|
|
308
|
+
|
|
|
309
|
+
|
|
|
310
|
+ if (is.null(colorScheme)) {
|
|
|
311
|
+ if (isFALSE(scale)){
|
|
|
312
|
+ if (heatmapPalette == "sequential"){
|
|
|
313
|
+ colorScheme <- circlize::colorRamp2(quantile(mat,na.rm=TRUE),
|
|
|
314
|
+ c('white', "#fecc5c",'#fdae61',"#f03b20","#bd0026"))
|
|
|
315
|
+ }
|
|
|
316
|
+ else if (heatmapPalette == "diverging"){
|
|
|
317
|
+ colorScheme <- circlize::colorRamp2(c(min(mat),
|
|
|
318
|
+ (max(mat) + min(mat))/2,
|
|
|
319
|
+ max(mat)),
|
|
|
320
|
+ c('blue', 'white', 'red'))
|
|
|
321
|
+ }
|
|
|
322
|
+ }
|
|
|
323
|
+ else if (scale == "zscore"){
|
|
|
324
|
+ colorScheme <- circlize::colorRamp2(quantile(assay(SCE), na.rm = TRUE),
|
|
|
325
|
+ c('#2c7bb6','#abd9e9','#ffffbf','#fdae61','#d7191c'))
|
|
|
326
|
+ }
|
|
|
327
|
+ else if (scale == "min_max"){
|
|
|
328
|
+ if(heatmapPalette == "sequential"){
|
|
|
329
|
+ colorScheme <- circlize::colorRamp2(c(0,0.3,0.6,0.8,1),
|
|
|
330
|
+ c('white', "#fecc5c",'#fdae61',"#f03b20","#bd0026"))
|
|
|
331
|
+
|
|
|
332
|
+ }
|
|
|
333
|
+ else if (heatmapPalette == "diverging") {
|
|
|
334
|
+ colorScheme <- circlize::colorRamp2(c(0,0.3,0.6,0.8,1),
|
|
|
335
|
+ c('#2c7bb6','#abd9e9','#ffffbf','#fdae61','#d7191c'))
|
|
|
336
|
+ }
|
|
|
337
|
+ }
|
|
|
338
|
+ } else {
|
|
|
339
|
+ if (!is.function(colorScheme))
|
|
|
340
|
+ stop('`colorScheme` must be a function generated by ',
|
|
|
341
|
+ 'circlize::colorRamp2')
|
|
|
342
|
+ breaks <- attr(colorScheme, 'breaks')
|
|
|
343
|
+ if (breaks[1] != min(trim) || breaks[length(breaks)] != max(trim))
|
|
|
344
|
+ stop('Breaks of `colorScheme` do not match with `trim`.')
|
|
|
345
|
+ }
|
|
|
346
|
+ ### Generate HeatmapAnnotation object
|
|
|
347
|
+ ca <- NULL
|
|
|
348
|
+ cellAnnotationColor <- .heatmapAnnColor(SCE, slot = "colData",
|
|
|
349
|
+ custom = cellAnnotationColor,
|
|
|
350
|
+ palette = palette)
|
|
|
351
|
+ if(dim(cellAnnotations)[2] > 0)
|
|
|
352
|
+ if(is.null(addCellSummary)){
|
|
|
353
|
+ ca <- ComplexHeatmap::HeatmapAnnotation(df = colData(SCE),
|
|
|
354
|
+ col = cellAnnotationColor)
|
|
|
355
|
+ }
|
|
|
356
|
+ else if (!addCellSummary %in% colnames(oldColData)){
|
|
|
357
|
+ stop(addCellSummary,
|
|
|
358
|
+ "' not found in colData")
|
|
|
359
|
+ }
|
|
|
360
|
+ else if (addCellSummary %in% colnames(oldColData)){
|
|
|
361
|
+ oldColData %>%
|
|
|
362
|
+ as.data.frame() %>%
|
|
|
363
|
+ group_by(!!!rlang::syms(aggregateCol),!!!rlang::syms(addCellSummary)) %>%
|
|
|
364
|
+ count() %>%
|
|
|
365
|
+ ungroup() %>%
|
|
|
366
|
+ group_by(!!! rlang::syms(aggregateCol)) %>%
|
|
|
367
|
+ mutate(sum = sum(n)) %>%
|
|
|
368
|
+ mutate(value = n/sum) %>%
|
|
|
369
|
+ dplyr::select(-n,sum) %>%
|
|
|
370
|
+ spread(one_of(addCellSummary),value) %>%
|
|
|
371
|
+ ungroup() %>%
|
|
|
372
|
+ dplyr::select(-one_of(aggregateCol),-sum) -> boxdata
|
|
|
373
|
+
|
|
|
374
|
+
|
|
|
375
|
+ boxdata[is.na(boxdata)] <- 0
|
|
|
376
|
+ boxdata<-as.matrix(boxdata)
|
|
|
377
|
+ ca <- ComplexHeatmap::HeatmapAnnotation(addCellSummary = anno_barplot(boxdata,
|
|
|
378
|
+ gp = gpar(fill = 2:5)),
|
|
|
379
|
+ annotation_label = addCellSummary,
|
|
|
380
|
+ col = cellAnnotationColor)
|
|
|
381
|
+ }
|
|
|
382
|
+ ra <- NULL
|
|
|
383
|
+ featureAnnotationColor <- .heatmapAnnColor(SCE, slot = "rowData",
|
|
|
384
|
+ custom = featureAnnotationColor,
|
|
|
385
|
+ palette = palette)
|
|
|
386
|
+ if(ncol(rowData(SCE)) > 0)
|
|
|
387
|
+ ra <- ComplexHeatmap::rowAnnotation(df = rowData(SCE),
|
|
|
388
|
+ col = featureAnnotationColor)
|
|
|
389
|
+ ### Set split variable
|
|
|
390
|
+ cs <- NULL
|
|
|
391
|
+ if (!is.null(colSplitBy)) cs <- colData(SCE)[colSplitBy]
|
|
|
392
|
+ rs <- NULL
|
|
|
393
|
+ if (!is.null(rowSplitBy)) rs <- rowData(SCE)[rowSplitBy]
|
|
|
394
|
+ ###
|
|
|
395
|
+ if (!is.null(colGap)) {
|
|
|
396
|
+ if (!inherits(colGap, "unit"))
|
|
|
397
|
+ stop("`colGap` has to be 'unit' object. Try `grid::unit(", colGap,
|
|
|
398
|
+ ", 'mm')`.")
|
|
|
399
|
+ }
|
|
|
400
|
+ else colGap <- grid::unit(0, 'mm')
|
|
|
401
|
+ if (!is.null(rowGap)) {
|
|
|
402
|
+ if (!inherits(rowGap, "unit"))
|
|
|
403
|
+ stop("`rowGap` has to be 'unit' object. Try `grid::unit(", rowGap,
|
|
|
404
|
+ ", 'mm')`.")
|
|
|
405
|
+ }
|
|
|
406
|
+ else rowGap <- grid::unit(0, 'mm')
|
|
|
407
|
+
|
|
|
408
|
+ if (!is.null(useAssay)) name <- useAssay
|
|
|
409
|
+ else name <- useReducedDim
|
|
|
410
|
+ hm <- ComplexHeatmap::Heatmap(mat, name = name, left_annotation = ra,
|
|
|
411
|
+ top_annotation = ca, col = colorScheme,
|
|
|
412
|
+ row_split = rs, column_split = cs,
|
|
|
413
|
+ row_title = rowTitle, column_title = colTitle,
|
|
|
414
|
+ show_row_names = rowLabel,
|
|
|
415
|
+ row_names_gp = grid::gpar(fontsize = rowLabelSize),
|
|
|
416
|
+ show_row_dend = rowDend,
|
|
|
417
|
+ row_dend_reorder = TRUE,
|
|
|
418
|
+ cluster_columns = FALSE,
|
|
|
419
|
+ show_column_names = colLabel,
|
|
|
420
|
+ column_names_gp = grid::gpar(fontsize = colLabelSize),
|
|
|
421
|
+ row_gap = rowGap, column_gap = colGap,
|
|
|
422
|
+ border = border,
|
|
|
423
|
+ ...)
|
|
|
424
|
+ return(hm)
|
|
|
425
|
+}
|
|
|
426
|
+
|
|
|
427
|
+.mergeAnnotationDF <- function(origin, external) {
|
|
|
428
|
+ if (!is.null(external)) {
|
|
|
429
|
+ external <- external[match(rownames(origin), rownames(external)), ,drop = FALSE]
|
|
|
430
|
+ origin <- cbind(origin, external)
|
|
|
431
|
+ }
|
|
|
432
|
+ return(origin)
|
|
|
433
|
+}
|
|
|
434
|
+
|
|
|
435
|
+.heatmapAnnColor <- function(inSCE, slot = c("colData", "rowData"),
|
|
|
436
|
+ custom = NULL, palette = palette) {
|
|
|
437
|
+ slot <- match.arg(slot)
|
|
|
438
|
+ if (!is.null(custom) && !is.list(custom))
|
|
|
439
|
+ stop("'cellAnnotationColor' or 'featureAnnotationColor' must be a list.")
|
|
|
440
|
+ if (is.null(custom)) custom <- list()
|
|
|
441
|
+ if (slot == "colData") data <- SummarizedExperiment::colData(inSCE)
|
|
|
442
|
+ if (slot == "rowData") data <- SummarizedExperiment::rowData(inSCE)
|
|
|
443
|
+ todoNames <- colnames(data)
|
|
|
444
|
+ todoNames <- todoNames[!todoNames %in% names(custom)]
|
|
|
445
|
+ newColor <- lapply(todoNames, function(n) {
|
|
|
446
|
+ var <- data[[n]]
|
|
|
447
|
+ if (is.factor(var)) categories <- levels(var)
|
|
|
448
|
+ else categories <- unique(var)
|
|
|
449
|
+ colors <- discreteColorPalette(length(categories), palette = palette)
|
|
|
450
|
+ names(colors) <- categories
|
|
|
451
|
+ return(colors)
|
|
|
452
|
+ })
|
|
|
453
|
+ names(newColor) <- todoNames
|
|
|
454
|
+ custom <- c(custom, newColor)
|
|
|
455
|
+ return(custom)
|
|
|
456
|
+}
|
|
|
457
|
+# Test
|
|
|
458
|
+#logcounts(sceBatches) <- log1p(counts(sceBatches))
|
|
|
459
|
+#plotSCEHeatmap2(sceBatches, "logcounts",
|
|
|
460
|
+# featureIndex = c("GCG1", "COX11", "INS1", "ND41"),
|
|
|
461
|
+# featureIndexBy = rowData(sceBatches)$feature_name,
|
|
|
462
|
+# cellIndex = c("reads.16087_", "Sample_1073_",
|
|
|
463
|
+# "reads.29330_", "Sample_801_"),
|
|
|
464
|
+# cellIndexBy = paste0(colnames(sceBatches), "_"),
|
|
|
465
|
+# rowLabel = "feature_name", rowDend = FALSE,
|
|
|
466
|
+# cluster_rows = FALSE, colLabel = TRUE, cluster_columns = FALSE,
|
|
|
467
|
+# colDataName = c("batch", "cell_type"), aggregateCol = c("cell_type", "batch"))
|
|
|
468
|
+#sce <-plotSCEHeatmap2(sceBatches, aggregateCol = "batch")
|
|
|
469
|
+#plotSCEHeatmap2(sceBatches, aggregateCol = c("cell_type", "batch"))
|
|
|
470
|
+#plotFindMarkerHeatmap(sce, log2fcThreshold = 0, minClustExprPerc = 0.4,
|
|
|
471
|
+# maxCtrlExprPerc = 0.5)
|
|
|
472
|
+#plotFindMarkerHeatmap(sce, log2fcThreshold = 0, minClustExprPerc = 0.4,
|
|
|
473
|
+# maxCtrlExprPerc = 0.5,
|
|
|
474
|
+# aggregateRow = "marker")
|
|
|
475
|
+#plotSCEDimReduceColData(sce, "cluster", "UMAP")
|
|
|
476
|
+CellVarColor <- function(inSCE, var,
|
|
|
477
|
+ palette = c("ggplot", "random", "celda"),
|
|
|
478
|
+ seed = 12345, ...) {
|
|
|
479
|
+ var <- .manageCellVar(inSCE, var = var)
|
|
|
480
|
+ palette <- match.arg(palette)
|
|
|
481
|
+ if (is.factor(var)) uniqVar <- levels(var)
|
|
|
482
|
+ else uniqVar <- unique(var)
|
|
|
483
|
+ colors <- discreteColorPalette(length(uniqVar), palette = palette, seed = seed, ...)
|
|
|
484
|
+ names(colors) <- uniqVar
|
|
|
485
|
+ return(colors)
|
|
|
486
|
+}
|
|
|
487
|
+
|
