File: colorlegend.r

package info (click to toggle)
r-bioc-destiny 3.4.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye
  • size: 11,800 kB
  • sloc: cpp: 174; javascript: 141; sh: 12; python: 6; makefile: 2
file content (141 lines) | stat: -rw-r--r-- 4,875 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
#' Color legend
#' 
#' Creates a color legend for a vector used to color a plot. It will use the current \code{\link[grDevices]{palette}()} or the specified \code{pal} as reference.
#' 
#' When passed a factor or integer vector, it will create a discrete legend, whereas a double vector will result in a continuous bar.
#' 
#' @param col          Vector of factor, integer, or double used to determine the ticks.
#' @param pal          If \code{col} is double, pal is used as a continuous palette, else as categorical one
#' @param log          Use logarithmic scale?
#' @param posx         Left and right borders of the color bar relative to plot area (Vector of length 2; 0-1)
#' @param posy         Bottom and top borders of color bar relative to plot area (Vector of length 2; 0-1)
#' @param main         Legend title
#' @param cex_main     Size of legend title font (default: subtitle font size \code{\link{par}('cex.sub')})
#' @param cex_axis     Size of ticks/category labels (default: axis font size \code{\link{par}('cex.axis')})
#' @param col_main     Color of legend title (default: subtitle color \code{\link{par}('col.sub')})
#' @param col_lab      Color of tick or category labels (default: axis color \code{\link{par}('col.lab')})
#' @param steps        Number of labels in case of a continuous axis. If 0 or FALSE, draw no ticks
#' @param steps_color  Number of gradient samples in case of continuous axis
#' @param digit        Number of digits for continuous axis labels
#' @param left         logical. If TRUE, invert posx
#' @param ...          Additional parameters for the \link[graphics]{text} call used for labels
#' @param cex.main,cex.axis,col.main,col.lab  For compatibility with \code{\link{par}}
#' 
#' @return This function is called for the side effect of adding a colorbar to a plot and returns nothing/NULL.
#' 
#' @examples
#' color_data <- 1:6
#' par(mar = par('mar') + c(0, 0, 0, 3))
#' plot(sample(6), col = color_data)
#' colorlegend(color_data)
#' 
#' @importFrom graphics par rect segments text
#' @importFrom grDevices colorRampPalette palette
#' @export
colorlegend <- function(
	col, pal = palette(), log = FALSE,
	posx = c(.9, .93), posy = c(.05, .9),
	main = NULL, cex_main = par('cex.sub'),
	cex_axis = par('cex.axis'),
	col_main = par('col.sub'), col_lab = par('col.lab'),
	steps = 5, steps_color = 100,
	digit = 2, left = FALSE,
	...,
	cex.main = NULL,
	cex.axis = NULL,
	col.main = NULL,
	col.lab = NULL) {
	draw_ticks <- as.logical(steps)
	if (!draw_ticks) steps <- 2L
	if (!is.null(cex.main)) cex_main <- cex.main
	if (!is.null(cex.axis)) cex_axis <- cex.axis
	if (!is.null(col.main)) col_main <- col.main
	if (!is.null(col.lab))  col_lab  <- col.lab
	
	zval <-
		if      (is.double(col)) seq(min(col, na.rm = TRUE), max(col, na.rm = TRUE), length.out = steps)
		else if (is.factor(col)) factor(levels(col))
		else                     sort(unique(col))
	
	zval_num <-
		if      (is.integer(zval)) seq_along(zval)
		else if (is.numeric(zval)) zval
		else if (is.factor(zval) || is.character(zval)) seq_along(zval)
		else                       as.integer(zval)
	
	zlim <-
		if (is.double(col)) range(zval_num)
		else c(min(zval_num) - .5, max(zval_num) + .5)
	
	par(new = TRUE)
	omar <- nmar <- par('mar')
	nmar[c(2, 4)] <- 0
	par(mar = nmar)
	
	emptyplot()
	
	pars <- par('usr')
	dx <- pars[[2]] - pars[[1]]
	xmin <- pars[[1]] + posx[[1]] * dx
	xmax <- pars[[1]] + posx[[2]] * dx
	dy <- pars[[4]] - pars[[3]]
	ymin <- pars[[3]] + posy[[1]] * dy
	ymax <- pars[[3]] + posy[[2]] * dy
	
	if (log) {
		zlim <- log10(zlim)
		zval <- log10(zval)
	}
	zmin <- zlim[[1]]
	zmax <- zlim[[2]]
	
	if (is.double(col)) {
		pal_fun <- if (is.function(pal)) pal else colorRampPalette(pal)
		batches <- pal_fun(steps_color)
		Y <- seq(ymin, ymax, length.out = length(batches) + 1)
	} else {
		idx_c <- seq(min(zval_num), max(zval_num))
		idx_c[!(idx_c %in% zval_num)] <- NA
		
		batches <- pal[idx_c]
		Y <- seq(ymin, ymax, length.out = length(idx_c) + 1)
	}
	
	rect(xmin, Y[-length(Y)], xmax, Y[-1], col = batches, border = NA)
	rect(xmin, ymin, xmax, ymax, border = col_lab)
	
	dx <- xmax - xmin
	dy <- ymax - ymin
	if (left) {
		Dx <- -dx
		pos <- 2
		xpos <- xmin + Dx * .5
	}
	else {
		Dx <- +dx
		pos <- 4
		xpos <- xmax + Dx * .5
	}
	
	zval_txt <- if (is.double(col)) formatC(zval, digits = digit, format = 'fg') else zval
	
	Ypos <- ymin + (zval_num - zmin)/(zmax - zmin) * dy
	if (draw_ticks) {
		if (is.double(col))
			segments(xmax, Ypos, xpos + Dx * .25, Ypos, col = col_lab)
		text(xpos, Ypos, zval_txt, pos = pos, col = col_lab, cex = cex_axis, ...)
	}
	
	if (!is.null(main)) {
		for (i in length(main):1)
			text(x = mean(c(xmin, xmax)),
					 y = ymax + .05 * (length(main) - i + 1),
					 labels = main[i],
					 adj = c(.5, .5),
					 cex = cex_main,
					 col = col_main)
	}
	par(new = FALSE)
	par(mar = omar)
	invisible()
}