R/gridtext.R

In jokergoo/ComplexHeatmap: Make Complex Heatmaps

# `[.grob` = function(x, i) {
# 	x2 = x
# 	for(nm in SUBSETABLE_FIELDS[[ intersect(names(SUBSETABLE_FIELDS), class(x)) ]]) {
# 		if(inherits(x2[[nm]], "gpar")) {
# 			# change to the class defined here
# 			class(x2[[nm]]) = "gpar"
# 		}

# 		if(length(x2[[nm]]) > 1) {
# 			x2[[nm]] = x2[[nm]][i]
# 		}
# 	}
# 	x2
# }

# `[.gpar` = function(x, i) {
# 	lapply(x, function(y) {
# 		if(length(y) > 1) {
# 			y[i]
# 		} else {
# 			y
# 		}
# 	})
# }

# SUBSETABLE_FIELDS = list(
# 	"text" = c("label", "x", "y", "gp"),
# 	"richtext_grob" = c("gp", "children", "childrenOrder")
# )

# length.text = function(x) {
# 	length(x$label)
# }

# length.richtext_grob = function(x) {
# 	length(x$children)
# }

# update_xy = function (gb, x, y, ...) {
# 	UseMethod("update_xy")
# }

# update_xy.text = function(gb, x, y, ...) {
# 	n = length(gb$label)
# 	if(!missing(x)) {
# 		if(n > 1 & length(x) > 1 && n != length(x)) {
# 			stop_wrap("Length of `x` should be the same as the length of labels.")
# 		}
# 		gb$x = x
# 	}
# 	if(!missing(y)) {
# 		if(n > 1 & length(y) > 1 && n != length(y)) {
# 			stop_wrap("Length of `y` should be the same as the length of labels.")
# 		}
# 		gb$y = y
# 	}
# 	gb
# }

# update_xy.richtext_grob = function(gb, x, y, ...) {
# 	n = length(gb$children)

# 	if(!missing(x)) {
# 		if(n > 1 & length(x) > 1 && n != length(x)) {
# 			stop_wrap("Length of `x` should be the same as the length of labels.")
# 		}
# 		for(i in 1:n) {
# 			if(length(x) == 1) {
# 				gb$children[[i]]$vp$x = x
# 			} else {
# 				gb$children[[i]]$vp$x = x[i]
# 			}
# 		}
# 	}
# 	if(!missing(y)) {
# 		if(n > 1 & length(y) > 1 && n != length(y)) {
# 			stop_wrap("Length of `y` should be the same as the length of labels.")
# 		}
# 		for(i in 1:n) {
# 			if(length(y) == 1) {
# 				gb$children[[i]]$vp$y = y
# 			} else {
# 				gb$children[[i]]$vp$y = y[i]
# 			}
# 		}
# 	}
# 	gb
# }

# textGrob = function(label, ...) {
# 	if(inherits(label, "grob")) {
# 		return(label)
# 	} else {
# 		grid::textGrob(label, ...)
# 	}
# }

# grid.text = function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"), ...) {
# 	if(inherits(label, "grob")) {
# 		gb = label
# 		gb = update_xy(gb, x, y)
# 		grid.draw(gb)
# 	} else {
# 		grid::grid.text(label, x, y, ...)
# 	}
# }

# == title
# Mark the text for the rendering by gridtext package
#
# == param
# -x Text labels. The value can be a vector.
# -... Other parameters passed to `gridtext::richtext_grob`.
#
# == details
# Text marked by `gt_render` will be rendered by `gridtext::richtext_grob` function.
#
# == example
# if(requireNamespace("gridtext")) {
# mat = matrix(rnorm(100), 10)
# rownames(mat) = letters[1:10]
# ht = Heatmap(mat, 
# 	column_title = gt_render("Some <span style='color:blue'>blue text **in bold.**</span><br>And *italics text.*<br>And some <span style='font-size:18pt; color:black'>large</span> text.", r = unit(2, "pt"), padding = unit(c(2, 2, 2, 2), "pt")),
# 	column_title_gp = gpar(box_fill = "orange"),
# 	row_labels = gt_render(letters[1:10], padding = unit(c(2, 10, 2, 10), "pt")),
# 	row_names_gp = gpar(box_col = "red"),
# 	row_km = 2, 
# 	row_title = gt_render(c("title1", "title2")), 
# 	row_title_gp = gpar(box_fill = "yellow"),
# 	heatmap_legend_param = list(
# 		title = gt_render("<span style='color:orange'>**Legend title**</span>"), 
# 		title_gp = gpar(box_fill = "grey"),
# 		at = c(-3, 0, 3), 
# 		labels = gt_render(c("*negative* three", "zero", "*positive* three"))
# 	))
# ht = rowAnnotation(
# 	foo = anno_text(gt_render(sapply(LETTERS[1:10], strrep, 10), align_widths = TRUE), 
# 	                gp = gpar(box_col = "blue", box_lwd = 2), 
# 	                just = "right", 
# 	                location = unit(1, "npc")
# 	)) + ht
# draw(ht)
#
# }
gt_render = function(x, ...) {
	if(!requireNamespace("gridtext")) {
		stop_wrap("gridtext package needs to be installed.")
	}
	param = list(...)
	class(x) = "gridtext"
	attr(x, "param") = param
	return(x)
}

# == title
# Subset method of gridtext class
#
# == param
# -x A vector of labels generated by `gt_render`.
# -index Index
#
# == details
# Internally used.
"[.gridtext" = function(x, index) {
	cl = class(x)
	param = attr(x, "param")
	class(x) = NULL
	x = x[index]
	class(x) = cl
	attr(x, "param") = param
	x
}

grid.text = function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"), ...) {
	if(inherits(label, "gridtext")) {
		# cat("draw text by gridtext:\n")
		# print(label)
		# cat("\n")
		grid.draw(richtext_grob2(label, x, y, ...))
	} else {
		grid::grid.text(label, x, y, ...)
	}
}

textGrob = function(label, ...) {
	if(inherits(label, "gridtext")) {
		richtext_grob2(label, ...)
	} else {
		grid::textGrob(label, ...)
	}
}

normalize_just = function(x) {
	if(is.character(x)) {
		x[x == "centre"] = "center"
		if(identical(x, "center")) {
			return(c(0.5, 0.5))
		} else if(identical(x, c("center", "center"))) {
			return(c(0.5, 0.5))
		} else if(identical(x, c("left", "center"))) {
			return(c(0, 0.5))
		} else if(identical(x, c("right", "center"))) {
			return(c(1, 0.5))
		} else if(identical(x, c("center", "top"))) {
			return(c(0.5, 1))
		} else if(identical(x, c("center", "bottom"))) {
			return(c(0.5, 0))
		} else if(identical(x, c("left", "bottom"))) {
			return(c(0, 0))
		} else if(identical(x, c("left", "top"))) {
			return(c(0, 1))
		} else if(identical(x, c("right", "bottom"))) {
			return(c(1, 0))
		} else if(identical(x, c("right", "top"))) {
			return(c(1, 1))
		} else if(identical(x, c("left"))) {
			return(c(0, 0.5))
		} else if(identical(x, c("right"))) {
			return(c(1, 0.5))
		} else if(identical(x, c("bottom"))) {
			return(c(0.5, 0))
		} else if(identical(x, c("top"))) {
			return(c(0.5, 1))
		}
	}
	if(length(x) == 1) x = c(x, x)
	return(x)
}

# argument from grid.text directly pass to richtext_grob, so some argument need
# to be adjusted, e.g. those not supported in richtext_grob
richtext_grob2 = function(label, ...) {
	param0 = attr(label, "param")
	param = list(text = label, ...)
	for(nm in names(param0)) {
		param[[nm]] = param0[[nm]]
	}
	if("just" %in% names(param)) {
		j = normalize_just(param$just)
		param$just = NULL
		param$hjust = j[1]
		param$vjust = j[2]
	}
	if("gp" %in% names(param)) {
		gp = param$gp
		l_box = grepl("^box_", names(gp))
		if(any(l_box)) {
			class(gp) = "list"
			box_gp = gp[l_box]
			gp[l_box] = NULL
			names(box_gp) = gsub("^box_", "", names(box_gp))
			class(gp) = "gpar"
			class(box_gp) = "gpar"
			param$gp = gp
			param$box_gp = box_gp
		}
	}
	do.call(gridtext::richtext_grob, param)
}