complexHeatmap: Make Complex Heatmaps

#####################################
# class and methods to map values to colors
#

# == title
# Class for Color Mapping
#
# == details
# The `ColorMapping-class` handles color mapping for discrete values and continuous values.
# Discrete values are mapped by setting a vector of colors and continuous values are mapped by setting
# a color mapping function.
#
# == methods
# The `ColorMapping-class` provides following methods:
#
# - `ColorMapping`: contructor methods.
# - `map_to_colors,ColorMapping-method`: mapping values to colors.
# - `color_mapping_legend,ColorMapping-method`: draw legend or get legend as an object.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
ColorMapping = setClass("ColorMapping",
	slots = list(
		colors  = "character", # a list of colors
		levels  = "ANY", # levels which colors correspond to
		col_fun = "function", # function to map values to colors
		type    = "character",  # continuous or discrete
		name    = "character",  # used to map to the dataset and taken as the title of the legend
		na_col  = "character"
	)
)

# == title
# Constructor Method for ColorMapping Class
#
# == param
# -name Name for this color mapping. The name is automatically generated if it is not specified.
# -colors Discrete colors.
# -levels Levels that correspond to ``colors``. If ``colors`` is name indexed,
#         ``levels`` can be ignored.
# -col_fun Color mapping function that maps continuous values to colors.
# -breaks Breaks for the continuous color mapping. If ``col_fun`` is
#         generated by `circlize::colorRamp2`, ``breaks`` is automatically inferred from the color mapping function.
# -na_col Colors for ``NA`` values.
#
# == detail
# ``colors`` and ``levels`` are used for discrete color mapping, ``col_fun`` and
# ``breaks`` are used for continuous color mapping.
#
# == value
# A `ColorMapping-class` object.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == examples
# cm = ColorMapping(colors = c("A" = "red", "B" = "black"))
# cm
# require(circlize)
# col_fun = colorRamp2(c(0, 1), c("white", "red"))
# cm = ColorMapping(col_fun = col_fun)
ColorMapping = function(name, colors = NULL, levels = NULL,
	col_fun = NULL, breaks = NULL, na_col = "#FFFFFF") {

	.Object = new("ColorMapping")

	if(missing(name)) {
		increase_color_mapping_index()
		name = paste0("color_mapping_", get_color_mapping_index())
	}
	if(!is.null(colors)) {
		if(is.null(levels)) {
			if(is.null(names(colors))) {
				stop_wrap("either provide `levels` or provide named `colors`.\n")
			}
			levels = names(colors)
		}
		if(length(colors) != length(levels)) {
			stop_wrap("length of colors and length of levels should be the same.\n")
		}
		colors = t(col2rgb(colors, alpha = TRUE))
		colors = rgb(colors[, 1:3, drop = FALSE], alpha = colors[, 4], maxColorValue = 255)
		.Object@colors = colors
		if(is.numeric(levels)) {
			.Object@levels = as.character(levels)
			#attr(.Object@levels, "numeric") = TRUE
		} else {
			.Object@levels = levels
		}
		names(.Object@colors) = levels
		.Object@type = "discrete"
	} else if(!is.null(col_fun)) {
		if(is.null(breaks)) {
			breaks = attr(col_fun, "breaks")
			if(is.null(breaks)) {
				stop_wrap("You should provide breaks.\n")
			}
		

			le1 = grid.pretty(range(breaks))
			le2 = pretty(breaks, n = 3)
			if(abs(length(le1) - 5) < abs(length(le2) - 5)) {
				le = le1
			} else {
				le = le2
			}
		} else {
			le = breaks
		}

		.Object@colors = col_fun(le)
		.Object@levels = le
		.Object@col_fun = col_fun
		.Object@type = "continuous"
	} else {
		stop_wrap("initialization failed. Either specify `colors` + `levels` or `col_fun` + `breaks`\n")
	}

	.Object@name = name
	na_col = t(col2rgb(na_col, alpha = TRUE))
	na_col = rgb(na_col[, 1:3, drop = FALSE], alpha = na_col[, 4], maxColorValue = 255)
	.Object@na_col = na_col[1]

	return(.Object)
}

# == title
# Print the ColorMapping Object
#
# == param
# -object A `ColorMapping-class` object.
#
# == value
# This function returns no value.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
setMethod(f = "show",
	signature = "ColorMapping",
	definition = function(object) {
	if(object@type == "discrete") {
		cat("Discrete color mapping:\n")
		cat("name:", object@name, "\n")
		cat("levels:\n")
		print(object@levels)
		cat("\n")
		cat("colors:\n")
		col = object@colors; names(col) = NULL
		print(col)
		cat("\n")
	} else if(object@type == "continuous") {
		cat("Continuous color mapping:\n")
		cat("name:", object@name, "\n")
		cat("default breaks:\n")
		print(object@levels)
		cat("\n")
		cat("colors:\n")
		col = object@colors; names(col) = NULL
		print(col)
		cat("\n")
	}
})

# == title
# Map Values to Colors
#
# == param
# -object A `ColorMapping-class` object.
# -x Input values.
#
# == details
# It maps a vector of values to a vector of colors.
#
# This function provides a uniform way for discrete and continuous color mapping.
#
# == value
# A vector of colors.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == example
# cm = ColorMapping(colors = c("A" = "red", "B" = "black"))
# map_to_colors(cm, sample(c("A", "B"), 10, replace = TRUE))
# require(circlize)
# col_fun = colorRamp2(c(0, 1), c("white", "red"))
# cm = ColorMapping(col_fun = col_fun)
# map_to_colors(cm, runif(10))
setMethod(f = "map_to_colors",
	signature = "ColorMapping",
	definition = function(object, x) {

	if(is.factor(x)) x = as.vector(x)
	original_attr = attributes(x)
	x2 = vector(length = length(x))

	if(object@type == "discrete") {
		x[grepl("^\\s*$", x)] = NA
		lna = is.na(x)

		if(is.numeric(x)) x = as.character(x)
		if(any(! x[!lna] %in% object@levels)) {
			msg = paste0(object@name, ": cannot map colors to some of the levels:\n", paste(setdiff(x[!lna], object@levels), sep = ", ", collapse = ", "))
			stop_wrap(msg)
		}

		x2[lna] = object@na_col
		x2[!lna] = object@colors[ x[!lna] ]
	} else {
		lna = is.na(x)
		x2[lna] = object@na_col
		x2[!lna] = object@col_fun(x[!lna])
	}

	# keep original attributes, such as dimension
	attributes(x2) = original_attr
	return(x2)
})


# == title
# Draw Legend Based on Color Mapping
#
# == param
# -object A `ColorMapping-class` object.
# -plot Whether to plot or just return the legend object?
# -... Pass to `draw,Legends-method`.
# -color_bar "continous" or "discrete". It controls whether to show the discrete legend for the continuous color mapping.
# -title Title of the legend, by default it is the name of the legend.
# -title_gp Graphical parameters for legend title.
# -title_position Position of the title. See `Legend` for all possible values.
# -grid_height Height of each legend grid. Pass to `Legend`.
# -grid_width Width of each legend grid. Pass to `Legend`.
# -border Color for legend grid borders. Pass to `Legend`.
# -at Break values of the legend. By default it is the levels in the `ColorMapping-class` object.
# -labels Labels corresponding to break values.
# -labels_gp Graphcial parameters for legend labels.
# -labels_rot Rotation of labels.
# -nrow Pass to `Legend`. It controls the layout of legend grids if they are arranged in multiple rows or columns.
# -ncol Pass to `Legend`. It controls the layout of legend grids if they are arranged in multiple rows or columns.
# -by_row Pass to `Legend`. It controls the order of legend grids if they are arranged in multiple rows or columns.
# -legend_height Height of the legend body. It only works when ``color_bar`` is ``continuous`` and ``direction`` is ``vertical``. Pass to `Legend`.
# -legend_width Width of the legend body. It only works when ``color_bar`` is ``continuous`` and ``direction`` is ``horizontal``. Pass to `Legend`.
# -legend_direction When ``color_bar`` is ``continuous``, whether the legend is vertical or horizontal? Pass to `Legend`.
# -param All the legend-related parameters can be specified as a single list.
#
# == details
# The legend is constructed by `Legend`. 
#
# == value
# A `Legends-class` object.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
setMethod(f = "color_mapping_legend",
	signature = "ColorMapping",
	definition = function(object,
	plot = TRUE, ...,
	
	color_bar = object@type,
	
	title = object@name,
	title_gp = gpar(fontsize = 10, fontface = "bold"),
	title_position = "topleft",
	grid_height = unit(4, "mm"),
	grid_width = unit(4, "mm"),
	border = NULL,
	at = object@levels,
	labels = at,
	labels_gp = gpar(fontsize = 10),
	labels_rot = 0,
	nrow = NULL,
	ncol = 1,
	by_row = FALSE,
	legend_height = NULL, 
	legend_width = NULL,
	legend_direction = c("vertical", "horizontal"),

	param = NULL) {

	e = environment()
	if(!is.null(param)) {
		for(nm in names(param)) {
			if(nm == "direction") {
				assign("legend_direction", param[[nm]], envir = e)
			} else {
				assign(nm, param[[nm]], envir = e)
			}
		}
	}

	title_gp = check_gp(title_gp)
	labels_gp = check_gp(labels_gp)

	if(object@type == "discrete" && color_bar == "continuous") {
		stop_wrap("'color_bar' can only be set to 'discrete' only if the color mapping is discrete")
	}

	# get labels
	if(length(at) != length(labels)) {
		stop_wrap("Length of 'at' should be same as length of 'labels'.")
	}
	# if it is character color mapping, remove items in `at` which are not in the available optinos
	if(color_bar == "discrete" && is.character(at)) {
		l = which(at %in% object@levels)
		at = at[l]
		labels = labels[l]
	}

	if(color_bar == "discrete") {
		if(object@type == "continuous") {
			at = rev(at)
			labels = rev(labels)
		}
		gf = Legend(at = at, labels = labels, title = title, title_gp = title_gp, grid_height = grid_height,
			grid_width = grid_width, border = border, labels_gp = labels_gp, direction = legend_direction, nrow = nrow, ncol = ncol,
			legend_gp = gpar(fill = map_to_colors(object, at)), title_position = title_position, by_row = by_row)

	} else {

		gf = Legend(at = at, labels = labels, col_fun = object@col_fun, title = title, title_gp = title_gp, grid_height = grid_height,
			grid_width = grid_width, border = border, labels_gp = labels_gp, labels_rot = labels_rot, direction = legend_direction,
			legend_width = legend_width, legend_height = legend_height, title_position = title_position, by_row = by_row)

	}

	if(plot) {
		draw(gf, ...)
	}

	return(invisible(gf))
})