add circos.heatmap()

NAMESPACE

@@ -14,6 +14,7 @@ export("chordDiagramFromMatrix")
 export("circlize")
 export("circos.arrow")
 export("circos.axis")
+export("circos.boxplot")
 export("circos.clear")
 export("circos.dendrogram")
 export("circos.genomicAxis")
@@ -31,6 +32,8 @@ export("circos.genomicRect")
 export("circos.genomicText")
 export("circos.genomicTrack")
 export("circos.genomicTrackPlotRegion")
+export("circos.heatmap")
+export("circos.heatmap.initialize")
 export("circos.info")
 export("circos.initialize")
 export("circos.initializeWithIdeogram")
@@ -53,6 +56,7 @@ export("circos.trackText")
 export("circos.triangle")
 export("circos.update")
 export("circos.updatePlotRegion")
+export("circos.violin")
 export("circos.xaxis")
 export("circos.yaxis")
 export("col2value")
@@ -109,6 +113,7 @@ importFrom("grDevices", rgb)
 importFrom("grid", grid.pretty)
 importFrom("methods", as)
 importFrom("shape", Arrowhead)
+importFrom("stats", "as.dendrogram", "dist", "hclust", "order.dendrogram")
 importFrom("stats", rnorm)
 importFrom("stats", runif)
 importFrom("utils", download.file)

NEWS

@@ -8,6 +8,9 @@ Changes in version 0.4.10
 * `get.cell.meta.data()`: add `cell.width` and `cell.height` arguments.
 * `circos.genomicTrackPlotRegion()`: when input is a data frame list and column.index
    is a vector, reduce the one-column data frame to a vector.
+* add `add.track.meta.data()` and `add.sector.meta.data()` too add user-defined cell meta data.
+* add `circos.heatmap()` to draw multi-track heatmaps.
+* add `circos.boxplot()` and `circos.violin()`.
 
 Changes in version 0.4.9
 -----------------------------------------------------------------------

R/circos.heatmap.R

@@ -0,0 +1,323 @@
+
+# returns a list of named data frames
+circos.heatmap.format.input = function(x, split) {
+	if(is.atomic(x) && !is.matrix(x)) x = matrix(x, ncol = 1)
+	if(is.data.frame(x)) x = as.matrix(x)
+
+	subset_list = NULL
+	if(is.matrix(x)) {
+		if(is.null(split)) {
+			if(is.circos.heatmap.cached()) {
+				# qqcat("use the cached split\n")
+				env = circos.par("__tempenv__")
+				split = env$circos.heatmap.split
+			}
+		}
+		if(is.null(split)) {
+			mat_list = list(mat = x)
+			subset_list = list(mat = 1:nrow(x))
+		} else {
+			mat_list = lapply(split(seq_len(nrow(x)), split), function(ind) x[ind, , drop = FALSE])
+			subset_list = split(seq_len(nrow(x)), split)
+		}
+	} else {
+		mat_list = x
+	}
+
+	n = length(mat_list)
+	if(is.null(names(mat_list))) {
+		names(mat_list) = paste0("mat", 1:n)
+	}
+
+	attr(mat_list, "subset_list") = subset_list
+	mat_list
+}
+
+is.circos.heatmap.cached = function() {
+	env = circos.par("__tempenv__")
+	identical(env$circos.heatmap.initialized, TRUE)
+}
+
+# == title
+# Initialize circular heatmaps
+#
+# == param
+# -x A matrix or a list of matrices. If the value is a vector, it is converted
+#    into a one-column matrix.
+# -split A categorical variable. If the ``x`` is a matrix, it splits the matrix into a list of matrices.
+# -cluster whether to apply clustering on rows.
+# -clustering.method Clustering method, pass to `stats::hclust`.
+# -distance.method Distance method, pass to `stats::dist`.
+# 
+circos.heatmap.initialize = function(x, split = NULL, cluster = TRUE, 
+	clustering.method = "complete", distance.method = "euclidean") {
+
+	mat_list = circos.heatmap.format.input(x, split)
+	n = length(mat_list)
+	subset_list = attr(mat_list, "subset_list")
+
+	# qqcat("initialize the circular plot with @{n} matrices.\n")
+	circos.initialize(names(mat_list), xlim = cbind(rep(0, n), sapply(mat_list, nrow)))
+
+	if(is.character(mat_list[[1]])) cluster = FALSE
+
+	env = circos.par("__tempenv__")
+	if(cluster) {
+		# qqcat("perform clustering.\n")
+		dend_list = lapply(mat_list, function(m) as.dendrogram(hclust(dist(m, method = distance.method), method = clustering.method)))
+		for(se in get.all.sector.index()) {
+			add.sector.meta.data("row_dend", dend_list[[se]], sector.index = se)
+			add.sector.meta.data("dend", dend_list[[se]], sector.index = se)
+			add.sector.meta.data("row_order", order.dendrogram(dend_list[[se]]), sector.index = se)
+			add.sector.meta.data("order", order.dendrogram(dend_list[[se]]), sector.index = se)
+			if(!is.null(subset_list)) {
+				add.sector.meta.data("subset", subset_list[[se]], sector.index = se)
+			}
+		}
+		env$circos.heatmap.cluster = TRUE
+	} else {
+		# qqcat("use the natural order.\n")
+		for(se in get.all.sector.index()) {
+			add.sector.meta.data("row_order", 1:nrow(mat_list[[se]]), sector.index = se)
+			add.sector.meta.data("order", 1:nrow(mat_list[[se]]), sector.index = se)
+			if(!is.null(subset_list)) {
+				add.sector.meta.data("subset", subset_list[[se]], sector.index = se)
+			}
+		}
+		env$circos.heatmap.cluster = FALSE
+	}
+	env$circos.heatmap.split = split
+	env$circos.heatmap.initialized = TRUE
+
+}
+
+# e.g. to check number of rows, split varaible, ...
+circos.heatmap.validate = function(mat_list) {
+
+	# assume the heatmap is already initialized
+	env = circos.par("__tempenv__")
+	order_list = lapply(env$sector.meta.data, function(x) {
+		x$row_order
+	})
+
+	if(!identical(unname(sapply(mat_list, nrow)), unname(sapply(order_list, length)))) {
+		stop_wrap("The numbers of total rows and in each group are different from the cached values. Maybe you should 1. provide the matrix with the same number of rows as the previous ones, 2. don't set `split` because only the cached one is used, or 3. apply `circos.clear()` if you are making a new plot.")
+	}
+}
+
+# == title
+# Make circular heatmaps
+#
+# == param
+# -x A matrix or a list of matrices. If the value is a vector, it is converted
+#    into a one-column matrix.
+# -split A categorical variable. If the ``x`` is a matrix, it splits the matrix into a list of matrices.
+# -col If the values in the matrices are continuous, the color should be a color mapping generated by 
+#      `colorRamp2`. If the values are characters, the color should be a named color vector.
+# -na.col Color for ``NA`` values.
+# -ignore_white Whether to draw the white color?
+# -default.par By default `circos.par` is set as ``cell.padding = c(0, 0, 0, 0), track.margin = c(0.02, 0), gap.degree = 2``.
+#     Set this value to ``FALSE`` to use your own `circos.par`.
+# -cluster whether to apply clustering on rows.
+# -clustering.method Clustering method, pass to `stats::hclust`.
+# -distance.method Distance method, pass to `stats::dist`.
+# -dend.side Side of the dendrograms relative to the heatmap track.
+# -dend.track.height Track height of the dendrograms.
+# -rownames.side Side of the row names relative to the heatmap track.
+# -rownames.cex Cex of row names.
+# -rownames.font Font of row names.
+# -... Pass to `circos.track` which draws the heatmap track.
+# 
+# == example
+# set.seed(123)
+# mat = matrix(rnorm(1000), nr = 100)
+# rownames(mat) = paste0("R", 1:100)
+# split = rep(letters[1:5], times = 10)
+#
+# circos.clear()
+# circos.heatmap(mat, split = split,
+#     col = colorRamp2(c(-2, 0, 2), c("blue", "white", "red")))
+#
+# row_mean = rowMeans(mat)
+# circos.track(ylim = range(row_mean), panel.fun = function(x, y) {
+#     y = row_mean[split == CELL_META$sector.index]
+#     y = y[CELL_META$row_order]
+#     circos.lines(CELL_META$cell.xlim, c(0, 0), lty = 2, col = "grey")
+#     circos.points(seq_along(y) - 0.5, y, col = ifelse(y > 0, "red", "blue"))
+# }, cell.padding = c(0.02, 0, 0.02, 0))
+# circos.clear()
+#
+# circos.clear()
+# circos.heatmap.initialize(mat, split = split)
+# row_mean = rowMeans(mat)
+# circos.track(ylim = range(row_mean), panel.fun = function(x, y) {
+#     y = row_mean[split == CELL_META$sector.index]
+#     y = y[CELL_META$row_order]
+#     circos.lines(CELL_META$cell.xlim, c(0, 0), lty = 2, col = "grey")
+#     circos.points(seq_along(y) - 0.5, y, col = ifelse(y > 0, "red", "blue"))
+# }, cell.padding = c(0.02, 0, 0.02, 0))
+# circos.heatmap(mat, col = colorRamp2(c(-2, 0, 2), c("blue", "white", "red")))
+# circos.clear()
+#
+circos.heatmap = function(x, split = NULL, col, na.col = "grey", 
+	ignore_white = TRUE, default.par = TRUE,
+	cluster = TRUE, clustering.method = "complete", distance.method = "euclidean",
+	dend.side = c("none", "outside", "inside"), dend.track.height = 0.1,
+	rownames.side = c("none", "outside", "inside"), 
+	rownames.cex = 0.5,
+	rownames.font = par("font"),
+	...) {
+
+	mat_list = circos.heatmap.format.input(x, split)
+
+	if(is.circos.initialized()) {
+		circos.heatmap.validate(mat_list)
+	} else {
+		if(default.par) {
+			circos.par(cell.padding = c(0, 0, 0, 0), track.margin = c(0.02, 0), gap.degree = 2)
+		}
+		circos.heatmap.initialize(x, split = split, cluster = cluster, 
+			clustering.method = clustering.method, distance.method = distance.method)
+	}
+
+	env = circos.par("__tempenv__")
+	# qqcat("making the heatmap\n")
+
+	dend.side = match.arg(dend.side)
+	rownames.side = match.arg(rownames.side)
+	if(dend.side == rownames.side && dend.side %in% c("inside", "outside")) {
+		stop_wrap("dendrograms and row names cannot be on the same side.")
+	}
+
+	if(!env$circos.heatmap.cluster) {
+		dend.side = "none"
+	}
+
+	if(dend.side == "outside") {
+		dend_list = lapply(env$sector.meta.data, function(x) {
+			x$row_dend
+		})
+		max_height = max(sapply(dend_list, function(x) attr(x, "height")))
+		circos.track(ylim = c(0, max_height), bg.border = NA, track.height = dend.track.height,
+		    panel.fun = function(x, y) {
+		        sector.numeric.index = get.cell.meta.data("sector.numeric.index")
+		        dend = dend_list[[sector.numeric.index]]
+		        circos.dendrogram(dend, max_height = max_height, facing = "inside")
+		})
+	}
+
+	if(rownames.side == "outside") {
+		rownames_list = lapply(mat_list, rownames)
+		if(!all(sapply(rownames_list, is.null))) {
+			rownames_track_height = max(strwidth(unlist(rownames_list), cex = rownames.cex, font = rownames.font))
+			circos.track(ylim = c(0, 1), bg.border = NA, track.height = rownames_track_height, 
+				panel.fun = function(x, y) {
+					sector.numeric.index = CELL_META$sector.numeric.index
+				    m = mat_list[[sector.numeric.index]]
+				    od = CELL_META$row_order
+				    nr = nrow(m)
+
+				    if(!is.null(rownames(m))) {
+				    	circos.text(1:nr - 0.5, rep(0, nr), rownames(m)[od], cex = rownames.cex, 
+				    		font = rownames.font, facing = "clockwise", niceFacing = TRUE, adj = c(0, 0.5))
+				    }
+
+				})
+		}
+	}
+
+	nr = nrow(mat_list[[1]])
+	nc = ncol(mat_list[[1]])
+
+	if(missing(col)) {
+		stop_wrap("You should provide user-defined colors. If the values are continuous in the matrix, please set a color mapping function generated by `colorRamp2()`. If the values are characters, please set a named color vector.")
+	}
+
+	if(is.function(col)) {
+		col_fun = col
+	} else {
+		col_fun = function(x) {
+			attr = attributes(x)
+			v = col[x]
+			v[is.na(v)] = na.col
+			attributes(v) = attr
+			v
+		}
+	}
+
+	circos.track(ylim = c(0, nc), bg.border = NA, panel.fun = function(x, y) {
+
+	    sector.numeric.index = CELL_META$sector.numeric.index
+	    m = mat_list[[sector.numeric.index]]
+	    od = CELL_META$row_order
+
+	    m2 = m[od, , drop = FALSE]
+	    col_mat = col_fun(m2)
+	    if(!grepl("#\\w\\w\\w\\w\\w\\w", col_mat[1])) {
+	    	col_mat_attr = attributes(col_mat)
+	    	col_mat = as.vector(col_mat)
+	    	col_rgb = col2rgb(col_mat, alpha = TRUE)
+	    	col_mat = rgb(col_rgb[1, ], col_rgb[2, ], col_rgb[3, ], alpha = col_rgb[4, ], maxColorValue = 255)
+	    	attributes(col_mat) = col_mat_attr
+	    }
+	    nr = nrow(m2)
+	    nc = ncol(m2)
+
+	    for(i in 1:nc) {
+	    	if(ignore_white) {
+	    		l = grepl("#FFFFFF", col_mat[, i])  # white colors
+	    		if(all(l)) {
+	    			# no nothing
+	    		} else {
+	    			# qqcat("@{sum(l)} white rectangles are not drawn.\n")
+	    			circos.rect(
+	    				(1:nr - 1)[!l], 
+	    				(rep(nc - i, nr))[!l], 
+			            (1:nr)[!l], 
+			            (rep(nc - i + 1, nr))[!l], 
+			            border = col_mat[, i][!l], 
+			            col = col_mat[, i][!l])
+	    		}
+	    	} else {
+		        circos.rect(1:nr - 1, rep(nc - i, nr), 
+		            1:nr, rep(nc - i + 1, nr), 
+		            border = col_mat[, i], col = col_mat[, i])
+		       }
+	    }
+
+	}, ...)
+
+
+	if(dend.side == "inside") {
+		dend_list = lapply(env$sector.meta.data, function(x) {
+			x$row_dend
+		})
+		max_height = max(sapply(dend_list, function(x) attr(x, "height")))
+		circos.track(ylim = c(0, max_height), bg.border = NA, track.height = dend.track.height,
+		    panel.fun = function(x, y) {
+		        sector.numeric.index = get.cell.meta.data("sector.numeric.index")
+		        dend = dend_list[[sector.numeric.index]]
+		        circos.dendrogram(dend, max_height = max_height, facing = "outside")
+		})
+	}
+
+	if(rownames.side == "inside") {
+		rownames_list = lapply(mat_list, rownames)
+		if(!all(sapply(rownames_list, is.null))) {
+			rownames_track_height = max(strwidth(unlist(rownames_list), cex = rownames.cex, font = rownames.font))
+			circos.track(ylim = c(0, 1), bg.border = NA, track.height = rownames_track_height, 
+				panel.fun = function(x, y) {
+					sector.numeric.index = CELL_META$sector.numeric.index
+				    m = mat_list[[sector.numeric.index]]
+				    od = CELL_META$row_order
+				    nr = nrow(m)
+
+				    if(!is.null(rownames(m))) {
+				    	circos.text(1:nr - 0.5, rep(1, nr), rownames(m)[od], cex = rownames.cex, 
+				    		font = rownames.font, facing = "clockwise", niceFacing = TRUE, adj = c(1, 0.5))
+				    }
+
+				})
+		}
+	}
+}