edroaldo
commented
5 years ago 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 %>% groupby(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 notifications@github.com 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 https://github.com/edroaldo/cellrouter/issues/26, or mute the thread https://github.com/notifications/unsubscribe-auth/ACNJIR3CCKNQHAAWHKMHAH3PUPSIRANCNFSM4HLYRY3A .
-- Edroaldo
AMA111
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