Heatmaps with multiple metadata annotations #26
Comments
|
Sorry for my delayed response. I have been hopeful to release some updates
in cellrouter but still could not find the time. At the meantime, you can
use the function below, which should do what you want but I have not
extensively tested it. So, please, let me know how it goes.
This is how you can use it. You specify your metadata columns using the
parameter *column.ann2. *The colores on the top of the heatmap will not
match the ones from your tSNE analysis colored by the same metadata though.
I will fix this later but first, please let me know if the function works
in your hands.
Thanks!
*plotSignaturesHeatmap2(cellrouter, top, column.ann = 'population',
column.ann2=c('metadata1', 'metadata2', 'metadata3'), column.color =
'population_color', #num.cells = 150, threshold =
1.5, width = 20, height = 15, filename = filename)*
plotSignaturesHeatmap2 <- function(object, markers, column.ann,
column.ann2, column.color, num.cells=NULL, threshold=2, genes.show=NULL,
low='purple', intermediate='black',
high='yellow', order=NULL, width, height, filename){
if(is.null(num.cells)){
print('here')
cells.keep <- rownames(object@sampTab)
print(table(object@sampTab[[column.ann]]))
}else{
#cells.use <- object@sampTab %>% group_by_(column.ann) %>%
sample_n(size = num.cells, replace = TRUE)
cells.use <- split(object@sampTab, object@sampTab[[column.ann]])
cells.use <- lapply(cells.use, function(x){
if(nrow(x) < num.cells){
cells.use.x <- x[sample(rownames(x), size = nrow(x)),]
}else{
cells.use.xx <- x[sample(rownames(x), size = num.cells),]
}
})
cells.use.tmp <- do.call(rbind, cells.use)
cells.keep <- as.vector(cells.use.tmp$sample_id)
}
#data <- object@ndata[,cells.use]
matrix <- center_with_threshold(object@ndata[,cells.keep], threshold)
paletteLength <- 100
#myColor <- colorRampPalette(c("purple","black","yellow"))(paletteLength)
myColor <- colorRampPalette(c(low, intermediate, high))(paletteLength)
myBreaks <- c(seq(min(matrix), 0, length.out=ceiling(paletteLength/2) +
1),
seq(max(matrix)/paletteLength, max(matrix),
length.out=floor(paletteLength/2)))
library(data.table)
markers2 <- as.data.frame(markers)
#markers2 <- as.data.frame(markers)
#markers2 <- as.data.table(markers2)[, .SD[which.max(fc.column)], by=gene]
#markers2 <- as.data.frame(markers2)
#markers2 <- as.data.frame(markers)
#markers2 <- markers2[!duplicated(markers2$gene),] #need to make sure
there is no duplicated element...
sampTab <- object@sampTab
sampTab <- sampTab[cells.keep,]
if(column.ann == 'population'){
markers2 <- markers2[order(as.numeric(markers2$population)),]
rownames(markers2) <- as.vector(markers2$gene)
sampTab <- sampTab[order(as.numeric(sampTab$population)),]
}else if(!is.null(order)){
markers2 <- markers2[order(factor(markers2$population, levels=order)),]
sampTab <- sampTab[order(factor(sampTab[[column.ann]], levels=order)),]
}else{
markers2 <- markers2[order(as.character(markers2$population)),]
rownames(markers2) <- as.vector(markers2$gene)
sampTab <- sampTab[order(as.character(sampTab[[column.ann]])),]
}
#clusters <- as.vector(object@sampTab$population)
#clusters <- as.vector(sampTab[[column.ann]])
#names(clusters) <- rownames(sampTab)
#clusters <- clusters[order(clusters)]
ann_col <- sampTab[, c(column.ann,
column.ann2)]#data.frame(population=as.vector(clusters), stringsAsFactors =
FALSE)
#rownames(ann_col) <- names(clusters)
ann_row <- data.frame(signature=as.vector(markers2$population),
stringsAsFactors = FALSE)
rownames(ann_row) <- as.vector(markers2$gene)
if(!is.null(order)){
ann_col$population <- factor(ann_col$population, levels=order)
ann_row$signature <- factor(ann_row$signature, levels=order)
}
#colors <- cRampClust(cluster.vector, 8)
#names(colors) <- cluster.vector
colors <- unique(sampTab[[column.color]])
names(colors) <- unique(as.vector(sampTab[[column.ann]]))
color_lists <- list(population=colors, signature=colors)
#replicate_row <- as.vector(unlist(lapply(split(ann_row,
ann_row$signature), nrow)))
#colors_row <- rep(colors, times=replicate_row)
#replicate_col <- as.vector(unlist(lapply(split(ann_col,
ann_col$population), nrow)))
#colors_col <- rep(colors, times=replicate_col)
index <- getIndexes(ann_col, ann_row, order.columns =
unique(ann_col$population), order.rows = unique(ann_row$signature))
if(is.null(genes.show)){
genes.show <- markers2 %>% group_by(population) %>% top_n(5, fc)
genes.show <- as.vector(genes.show$gene)
selected <- as.vector(markers2$gene)
selected[!(selected %in% genes.show)] <- ""
}else{
selected <- as.vector(markers2$gene)
selected[!(selected %in% genes.show)] <- ""
}
pheatmap(matrix[rownames(ann_row),rownames(ann_col)], cluster_rows=FALSE,
cluster_cols=FALSE, color = myColor, breaks=myBreaks, fontsize=15,
#gaps_row = index$rowsep,
gaps_col = index$colsep, annotation_col = ann_col,
annotation_row = ann_row, annotation_colors = color_lists,
labels_row = selected,
labels_col = rep("", ncol(matrix)), width=width, height=height,
filename=filename)
gc(verbose = FALSE)
}
…On Thu, May 9, 2019 at 5:04 AM AMA111 ***@***.***> wrote:
Dear Developer,
I would like to ask if there is a a way of plotting multiple annotations
(Cluster info, cell type, other ) from the metadata to the top of the heat
map after doing DE analysis .. Like this one:
[image: image]
<https://user-images.githubusercontent.com/29317258/57441307-f29c0100-7249-11e9-8980-7075d01d5745.png>
Thank you in advance!
Best,
Abdelrahman
—
You are receiving this because you are subscribed to this thread.
Reply to this email directly, view it on GitHub
<#26>, or mute the thread
<https://github.com/notifications/unsubscribe-auth/ACNJIR3CCKNQHAAWHKMHAH3PUPSIRANCNFSM4HLYRY3A>
.
--
Edroaldo
|
|
Hey,
|
Dear Developer,
I would like to ask if there is a a way of plotting multiple annotations (Cluster info, cell type, other ) from the metadata to the top of the heat map after doing DE analysis .. Like this one:
Thank you in advance!
Best,
Abdelrahman
The text was updated successfully, but these errors were encountered: