/
colors.R
136 lines (101 loc) · 2.81 KB
/
colors.R
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
#' Color tools and palettes for epicontacts
#'
#' These functions are used for defining palettes or colors in the
#' \code{epicontacts} package. They include:
#'
#' \itemize{
#'
#' \item \code{cases_pal}: discrete color palette used for cases (comes from the
#' \code{dibbler} package)
#'
#' \item \code{spectral}: continuous color palette (comes from the
#' \code{adegenet} package)
#'
#' \item \code{transp}: makes colors transparent (comes from the
#' \code{adegenet} package)
#'
#' \item \code{fac2col}: translates a character or a factor to a color using a
#' palette (comes from the \code{adegenet} package)
#'
#' }
#'
#'
#' @export
#'
#' @rdname colors
#'
#' @author Thibaut Jombart \email{thibautjombart@@gmail.com}
#'
#' @param n An integer indicating the number of colors.
#'
#' @examples
#'
#' barplot(1:5, col = cases_pal(5))
#' barplot(1:50, col = cases_pal(50))
#'
#' @param col A color vector to which transparency should be added.
#'
#' @param alpha The threshold to be used for transparency: 0 for full
#' transparency, and 1 for full opacity.
transp <- function(col, alpha = .5){
res <- apply(grDevices::col2rgb(col), 2,
function(c)
grDevices::rgb(c[1]/255, c[2]/255, c[3]/255, alpha))
return(res)
}
#' @export
#' @rdname colors
edges_pal <- function(n){
if(!is.numeric(n)) stop("n is not a number")
colors <- c("#cc6666", "#ff8566", "#ffb366","#33cccc",
"#85e0e0", "#adc2eb", "#9f9fdf","#666699")
return(transp(grDevices::colorRampPalette(colors)(n), .7))
}
#' @export
#' @rdname colors
cases_pal <- function(n){
if (!is.numeric(n)) {
stop("n is not a number")
}
n <- as.integer(n)
colors <- c("#ccddff", "#79d2a6", "#ffb3b3",
"#a4a4c1", "#ffcc00", "#ff9f80",
"#ccff99", "#df9fbf", "#ffcc99",
"#cdcdcd")
if (n < length(colors)) {
return(colors[seq_len(n)])
} else {
return(grDevices::colorRampPalette(colors)(n))
}
}
#' @export
#' @rdname colors
spectral <- grDevices::colorRampPalette(
c("#D53E4F","#F46D43","#FDAE61",
"#FEE08B","#FFFFBF","#E6F598",
"#ABDDA4","#66C2A5","#3288BD"))
#' @export
#' @rdname colors
#'
#' @param x A character or a factor to be converted to colors.
#'
#' @param pal A color palette.
#'
#' @param NA_col The color to be used for NA values.
#'
#' @param legend A logical indicating if legend info should be added to the
#' output. If TRUE, the output will be a list, with colors in the
#' \code{$color} component.
#'
fac2col <- function (x, pal = cases_pal, NA_col = "lightgrey", legend = FALSE){
x <- factor(x)
lev <- levels(x)
nlev <- length(lev)
col <- pal(nlev)
res <- rep(NA_col, length(x))
res[!is.na(x)] <- col[as.integer(x[!is.na(x)])]
if (legend) {
res <- list(color = res, leg_col = col, leg_lab = lev)
}
return(res)
}