# == title
# Make oncoPrint
#
# == param
# -mat a character matrix which encodes mulitple alterations or a list of matrix for which every matrix contains binary
# value representing the alteration is present or absent. When it is a list, the names of the list represent alteration types.
# You can use `unify_mat_list` to make all matrix having same row names and column names.
# -get_type If different alterations are encoded in the matrix, this self-defined function
# determines how to extract them. Only work when ``mat`` is a matrix.
# -alter_fun a single function or a list of functions which define how to add graphics for different alterations.
# If it is a list, the names of the list should cover all alteration types.
# -alter_fun_is_vectorized Whether ``alter_fun`` is implemented vectorized. Internally the function will guess.
# -col a vector of color for which names correspond to alteration types.
# -top_annotation Annotation put on top of the oncoPrint. By default it is barplot which shows the number of genes having the alteration in each sample.
# -right_annotation Annotation put on the right of hte oncoPrint. By default it is barplto which shows the number of samples having the alteration in each gene.
# -show_pct whether show percent values on the left of the oncoprint
# -pct_gp graphic paramters for percent row annotation
# -pct_digits digits for percent values
# -pct_side side of pct
# -show_row_names Whether show row names?
# -row_names_side side of the row names
# -row_names_gp Graphic parameters of row names.
# -row_order row order
# -column_order column order
# -remove_empty_columns if there is no alteration in that sample, whether remove it on the heatmap
# -remove_empty_rows if there is no alteration in that sample, whether remove it on the heatmap
# -show_column_names Whether show column names?
# -heatmap_legend_param pass to `Heatmap`
# -... pass to `Heatmap`, so can set ``bottom_annotation`` here.
#
# == details
# The 'memo sort' method is from https://gist.github.com/armish/564a65ab874a770e2c26 . Thanks to
# B. Arman Aksoy for contributing the code.
#
# For more explanation, please go to the vignette.
#
# == value
# A `Heatmap-class` object which means you can add other heatmaps or annotations to it.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
oncoPrint = function(mat,
get_type = function(x) x,
alter_fun,
alter_fun_is_vectorized = NULL,
col,
top_annotation = HeatmapAnnotation(column_barplot = anno_oncoprint_barplot()),
right_annotation = rowAnnotation(row_barplot = anno_oncoprint_barplot(
axis_param = list(side = "top", labels_rot = 0))),
bottom_annotation = NULL,
show_pct = TRUE,
pct_gp = gpar(fontsize = 10),
pct_digits = 0,
pct_side = "left",
show_row_names = TRUE,
row_names_side = "right",
row_names_gp = pct_gp,
row_order = NULL,
column_order = NULL,
remove_empty_columns = FALSE,
remove_empty_rows = FALSE,
show_column_names = FALSE,
heatmap_legend_param = list(title = "Alterations"),
...) {
arg_list = list(...)
arg_names = names(arg_list)
oe = environment(anno_oncoprint_barplot)
environment(anno_oncoprint_barplot) = environment()
on.exit(environment(anno_oncoprint_barplot) <- oe)
# convert mat to mat_list
if(inherits(mat, "data.frame")) {
mat = as.matrix(mat)
}
if(inherits(mat, "matrix")) {
all_type = unique(unlist(lapply(mat, get_type)))
all_type = all_type[!is.na(all_type)]
all_type = all_type[grepl("\\S", all_type)]
mat_list = lapply(all_type, function(type) {
m = sapply(mat, function(x) type %in% get_type(x))
dim(m) = dim(mat)
dimnames(m) = dimnames(mat)
m
})
names(mat_list) = all_type
} else if(inherits(mat, "list")) {
mat_list = mat
all_type = names(mat_list)
mat_list = lapply(mat_list, function(x) {
if(!is.matrix(x)) {
stop("Expect a list of matrix (not data frames).")
}
oattr = attributes(x)
x = as.logical(x)
attributes(x) = oattr
x
})
if(length(unique(sapply(mat_list, nrow))) > 1) {
stop("All matrix in 'mat_list' should have same number of rows.")
}
if(length(unique(sapply(mat_list, ncol))) > 1) {
stop("All matrix in 'mat_list' should have same number of columns.")
}
} else {
stop("Incorrect type of 'mat'")
}
cat("All mutation types:", paste(all_type, collapse = ", "), "\n")
# type as the third dimension
arr = array(FALSE, dim = c(dim(mat_list[[1]]), length(all_type)), dimnames = c(dimnames(mat_list[[1]]), list(all_type)))
for(i in seq_along(all_type)) {
arr[, , i] = mat_list[[i]]
}
oncoprint_row_order = function() {
order(rowSums(count_matrix), n_mut, decreasing = TRUE)
}
oncoprint_column_order = function() {
scoreCol = function(x) {
score = 0
for(i in 1:length(x)) {
if(x[i]) {
score = score + 2^(length(x)-i*1/x[i])
}
}
return(score)
}
scores = apply(count_matrix[row_order, ,drop = FALSE], 2, scoreCol)
order(scores, decreasing=TRUE)
}
if(missing(alter_fun)) {
if(length(mat_list) == 1) {
af = list(
background = function(x, y, w, h, j, i) {
grid.rect(x, y, w, h, gp = gpar(fill = "#CCCCCC", col = NA))
},
function(x, y, w, h, j, i) {
grid.rect(x, y, w*0.9, h*0.9, gp = gpar(fill = "red", col = NA))
}
)
alter_fun_is_vectorized = TRUE
names(af) = c("background", names(mat_list))
col = "red"
} else if(length(mat_list) == 2) {
af = list(
background = function(x, y, w, h, j, i) {
grid.rect(x, y, w, h, gp = gpar(fill = "#CCCCCC", col = NA))
},
function(x, y, w, h, j, i) {
grid.rect(x, y, w*0.9, h*0.9, gp = gpar(fill = "red", col = NA))
},
function(x, y, w, h, j, i) {
grid.rect(x, y, w*0.9, h*0.4, gp = gpar(fill = "blue", col = NA))
}
)
alter_fun_is_vectorized = TRUE
names(af) = c("background", names(mat_list))
col = c("red", "blue")
} else {
stop("`alter_fun` should be specified.")
}
names(col) = names(mat_list)
warning("Using default `alter_fun` graphics and reset `col`.")
}
if(is.list(alter_fun)) {
# validate the list first
if(is.null(alter_fun$background)) alter_fun$background = function(x, y, w, h) grid.rect(x, y, w, h, gp = gpar(fill = "#CCCCCC", col = NA))
sdf = setdiff(all_type, names(alter_fun))
if(length(sdf) > 0) {
stop(paste0("You should define graphic function for: ", paste(sdf, collapse = ", ")))
}
alter_fun = alter_fun[unique(c("background", intersect(names(alter_fun), all_type)))]
if(is.null(alter_fun_is_vectorized)) {
alter_fun_is_vectorized = guess_alter_fun_is_vectorized(alter_fun)
}
if(alter_fun_is_vectorized) {
layer_fun = function(j, i, x, y, w, h, fill) {
alter_fun$background(x, y, w, h)
for(nm in all_type) {
m = arr[, , nm]
l = pindex(m, i, j)
if(sum(l)) {
alter_fun[[nm]](x[l], y[l], w[l], h[l])
}
}
}
cell_fun = NULL
} else {
layer_fun = NULL
cell_fun = function(j, i, x, y, w, h, fill) {
alter_fun$background(x, y, w, h)
for(nm in all_type) {
if(arr[i, j, nm]) {
alter_fun[[nm]](x, y, w, h)
}
}
}
}
} else if(is.function(alter_fun)) {
if(length(formals(alter_fun)) == 5) {
af = function(x, y, w, h, v, j, i) alter_fun(x, y, w, h, v)
} else {
af = alter_fun
}
if(is.null(alter_fun_is_vectorized)) {
alter_fun_is_vectorized = FALSE
}
if(alter_fun_is_vectorized) {
layer_fun = function(j, i, x, y, w, h, fill) {
v = pindex(arr, i, j)
af(x, y, w, h, v, j, i)
}
cell_fun = NULL
} else {
layer_fun = NULL
cell_fun = function(j, i, x, y, w, h, fill) {
v = arr[i, j, ]
af(x, y, w, h, v, j, i)
}
}
} else {
stop("You need to set `alter_fun`.")
}
col = col[intersect(names(col), all_type)]
count_matrix = apply(arr, c(1, 2), sum)
n_mut = rowSums(apply(arr, 1:2, any))
if(is.null(row_order)) {
row_order = oncoprint_row_order()
}
if(is.null(column_order)) {
column_order = oncoprint_column_order()
}
if(is.null(row_order)) row_order = seq_len(nrow(count_matrix))
if(is.null(column_order)) column_order = seq_len(ncol(count_matrix))
if(is.character(column_order)) {
column_order = structure(seq_len(dim(arr)[2]), names = dimnames(arr)[[2]])[column_order]
}
names(column_order) = as.character(column_order)
if(remove_empty_columns) {
l = rowSums(apply(arr, c(2, 3), sum)) > 0
arr = arr[, l, , drop = FALSE]
column_order = structure(seq_len(sum(l)), names = which(l))[as.character(intersect(column_order, which(l)))]
}
if(remove_empty_rows) {
l = rowSums(apply(arr, c(1, 3), sum)) > 0
arr = arr[l, , , drop = FALSE]
row_order = structure(seq_len(sum(l)), names = which(l))[as.character(intersect(row_order, which(l)))]
}
# validate col
sdf = setdiff(all_type, names(col))
if(length(sdf) > 0) {
stop(paste0("You should define colors for:", paste(sdf, collapse = ", ")))
}
# for each gene, percent of samples that have alterations
pct_num = rowSums(apply(arr, 1:2, any)) / ncol(mat_list[[1]])
pct = paste0(round(pct_num * 100, digits = pct_digits), "%")
### now the annotations
err = try(top_annotation <- eval(substitute(top_annotation)), silent = TRUE)
if(inherits(err, "try-error")) {
stop_wrap("find an error when executing top_annotation. ")
}
right_annotation = eval(substitute(right_annotation))
if("left_annotation" %in% arg_names) {
stop("'left_annotation' are not allowed to specify, you can add...")
}
left_annotation = NULL
if(show_pct) {
left_annotation = rowAnnotation(pct = anno_text(pct, just = "right", location = unit(1, "npc"), gp = pct_gp),
show_annotation_name = FALSE)
}
if(show_row_names) {
ha_row_names = rowAnnotation(rownames = anno_text(dimnames(arr)[[1]], gp = pct_gp, just = "left", location = unit(0, "npc")),
show_annotation_name = FALSE)
right_annotation = c(ha_row_names, right_annotation, gap = unit(2, "mm"))
}
#####################################################################
# the main matrix
pheudo = c(all_type, rep(NA, nrow(arr)*ncol(arr) - length(all_type)))
dim(pheudo) = dim(arr)[1:2]
dimnames(pheudo) = dimnames(arr)[1:2]
if(length(arg_list)) {
if(any(arg_names %in% c("rect_gp", "cluster_rows", "cluster_columns", "cell_fun"))) {
stop("'rect_gp', 'cluster_rows', 'cluster_columns', 'cell_fun' are not allowed to use in `oncoPrint()`.")
}
}
ht = Heatmap(pheudo, col = col,
rect_gp = gpar(type = "none"),
cluster_rows = FALSE, cluster_columns = FALSE,
row_order = row_order, column_order = column_order,
cell_fun = cell_fun, layer_fun = layer_fun,
top_annotation = top_annotation,
left_annotation = left_annotation,
right_annotation = right_annotation,
show_row_names = FALSE,
show_column_names = show_column_names,
heatmap_legend_param = heatmap_legend_param,
...
)
return(ht)
}
# == title
# Unify a list of matrix
#
# == param
# -mat_list a list of matrix, all of them should have dimension names
# -default default values for the newly added rows and columns
#
# == details
# All matrix will be unified to have same row names and column names
#
# == value
# A list of matrix
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
unify_mat_list = function(mat_list, default = 0) {
common_rn = unique(unlist(lapply(mat_list, rownames)))
common_cn = unique(unlist(lapply(mat_list, colnames)))
mat_list2 = lapply(seq_along(mat_list), function(i) {
mat = matrix(default, nrow = length(common_rn), ncol = length(common_cn))
dimnames(mat) = list(common_rn, common_cn)
mat[rownames(mat_list[[i]]), colnames(mat_list[[i]])] = mat_list[[i]]
mat
})
names(mat_list2) = names(mat_list)
return(mat_list2)
}
# == title
# Barplot annotation for oncoPrint
#
# == param
# -type A vector of the alteration types in your data. It can be a subset of all alteration types if you don't want to show them all.
# -which Is ti a row annotation or a column annotation?
# -width Wisth of the annotation.
# -height Height of the annotation.
# -border Whether draw the border?
# -... Other parameters passed to `anno_barplot`.
#
# == detail
# This annotation function should always use with `oncoPrint`.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
anno_oncoprint_barplot = function(type = all_type, which = c("column", "row"),
width = NULL, height = NULL, border = FALSE, ...) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
anno_size = anno_width_and_height(which, width, height, unit(2, "cm"))
# get variables fron oncoPrint() function
pf = parent.env(environment())
arr = pf$arr
all_type = pf$all_type
col = pf$col
type = type
all_type = intersect(all_type, type)
if(length(all_type) == 0) {
stop_wrap("find no overlap, check your `type` argument.")
}
arr = arr[, , all_type, drop = FALSE]
col = col[all_type]
if(which == "column") {
count = apply(arr, c(2, 3), sum)
fun = anno_barplot(count, gp = gpar(fill = col, col = NA), which = "column",
baseline = 0, height = anno_size$height, border = border, ...)
} else {
count = apply(arr, c(1, 3), sum)
fun = anno_barplot(count, gp = gpar(fill = col, col = NA), which = "row",
baseline = 0, width = anno_size$width, border = border, ...)
}
fun@show_name = FALSE
return(fun)
}
guess_alter_fun_is_vectorized = function(alter_fun) {
n = 50
if(is.list(alter_fun)) {
x = 1:n
y = 1:n
w = unit(1:n, "mm")
h = unit(1:n, "mm")
dev.null()
oe = try({
for(i in seq_along(alter_fun)) {
alter_fun[[i]](x, y, w, h)
}
}, silent = TRUE)
dev.off2()
if(inherits(oe, "try-error")) {
return(FALSE)
} else {
return(TRUE)
}
} else {
return(FALSE)
}
}
