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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
#' Generate viridis or other color code for continuous values
#'
#' @param x continuous vectors of values
#' @param alpha The alpha transparency, a number in \[0,1\],
#' @param begin The (corrected) hue in \[0,1\] at which the color map begins.
#' @param end The (corrected) hue in \[0,1\] at which the color map ends.
#' @param direction Sets the order of colors in the scale. If 1, the default,
#' colors are ordered from darkest to lightest. If -1, the order of colors is
#' reversed.
#' @param option A character string indicating the color map option to use.
#' Eight options are available: "magma" (or "A"), "inferno" (or "B"),
#' "plasma" (or "C"), "viridis" (or "D"), "cividis" (or "E"),
#' "rocket" (or "F"), "mako" (or "G") and "turbo" (or "H").
#' @param na_color color code for NA values
#' @param scale_from input range (vector of length two). If not given,
#' is calculated from the range of x
#' @param palette The palette to use as a character vector of colors. If
#' this is specified, parameters other than `x`, `na_color` and `scale_from`
#' are ignored.
#' @export
spec_color <- function(x, alpha = 1, begin = 0, end = 1,
direction = 1, option = "D",
na_color = "#BBBBBB", scale_from = NULL,
palette = viridisLite::viridis(
256, alpha, begin, end, direction, option
)) {
n <- length(palette)
if (is.null(scale_from)) {
x <- round(rescale(x, c(1, n)))
} else {
x <- round(rescale(x, to = c(1, n),
from = scale_from))
}
color_code <- palette[x]
color_code[is.na(color_code)] <- na_color
return(color_code)
}
html_color_ <- function(color) {
# HTML colors are a subset of R colors, not including
# numbered versions like darkgoldenrod2 (issue #726)
if (substr(color, 1, 1) != "#" &&
!grepl("[[:digit:]]", color) )
return(color)
# 2024-01-23 Hao: Move it to a try catch flavor to catch some exception cases.
tryCatch({
rgba_code <- col2rgb(color, alpha = TRUE)
rgba_code[4] <- round(rgba_code[4])
return(paste0("rgba(", paste(rgba_code, collapse = ", "), ")"))
},
error = function(e) {return(as.character(color))}
)
}
html_color <- function(colors) {
colors <- trimws(gsub("\\!important", "", as.character(colors)))
sapply(colors, html_color_)
}
latex_color_ <- function(color) {
if (substr(color, 1, 1) != "#") {
return(paste0("\\{", color, "\\}"))
} else {
color <- sub("#", "", color)
if (nchar(color) == 8) color <- substr(color, 1, 6)
return(paste0("\\[HTML\\]\\{", color, "\\}"))
}
}
latex_color__ <- function(color) {
if (substr(color, 1, 1) != "#") {
return(paste0("{", color, "}"))
} else {
color <- sub("#", "", color)
if (nchar(color) == 8) color <- substr(color, 1, 6)
return(paste0("[HTML]{", color, "}"))
}
}
latex_color <- function(colors, escape = TRUE) {
colors <- as.character(colors)
if (escape) {
return(sapply(colors, latex_color_))
} else {
return(sapply(colors, latex_color__))
}
}
#' Generate common font size for continuous values
#'
#' @param x continuous vectors of values
#' @param begin Smallest font size to be used. Default is 10.
#' @param end Largest font size. Default is 20.
#' @param na_font_size font size for NA values
#' @param scale_from input range (vector of length two). If not given,
#' is calculated from the range of x
#' @export
spec_font_size <- function(x, begin = 8, end = 16, na_font_size = 12,
scale_from = NULL) {
if (is.null(scale_from)) {
x <- round(rescale(x, c(begin, end)))
} else {
x <- round(rescale(x, to = c(begin, end),
from = scale_from))
}
x[is.na(x)] <- na_font_size
return(x)
}
#' Generate rotation angle for continuous values
#'
#' @param x continuous vectors of values
#' @param begin Smallest degree to rotate. Default is 0
#' @param end Largest degree to rotate. Default is 359.
#' @param scale_from input range (vector of length two). If not given,
#' is calculated from the range of x
#' @export
spec_angle <- function(x, begin, end, scale_from = NULL) {
if (is.null(scale_from)) {
x <- round(rescale(x, c(begin, end)))
} else {
x <- round(rescale(x, to = c(begin, end),
from = scale_from))
}
x[is.na(x)] <- 0
return(x)
}
#' Setup bootstrap tooltip
#'
#' @param title text for hovering message
#' @param position How the tooltip should be positioned. Possible values are
#' `right`(default), `top`, `bottom`, `left` & `auto`.
#'
#' @export
spec_tooltip <- function(title, position = "right") {
position <- match.arg(position, c("right", "bottom", "top", "left", "auto"),
several.ok = TRUE)
tooltip_options <- paste(
'data-toggle="tooltip" data-container="body"',
paste0('data-placement="', position, '"'),
# ifelse(as_html, 'data-html="true"', NULL),
paste0('title="', title, '"'))
tooltip_options_list <- list(
'data-toggle' = 'tooltip',
'data-container' = 'body',
'data-placement' = position,
'title' = if(is.null(title)) '' else title
)
class(tooltip_options) <- "ke_tooltip"
attr(tooltip_options, 'list') <- tooltip_options_list
return(tooltip_options)
}
#' Setup bootstrap popover
#'
#' @param content content for pop-over message
#' @param title title for pop-over message.
#' @param trigger Controls how the pop-over message should be triggered.
#' Possible values include `hover` (default), `click`, `focus` and `manual`.
#' @param position How the tooltip should be positioned. Possible values are
#' `right`(default), `top`, `bottom`, `left` & `auto`.
#'
#' @export
spec_popover <- function(content = NULL, title = NULL,
trigger = "hover", position = "right") {
trigger <- match.arg(trigger, c("hover", "click", "focus", "manual"),
several.ok = TRUE)
position <- match.arg(position, c("bottom", "top", "left", "right", "auto"),
several.ok = TRUE)
popover_options <- paste(
'data-toggle="popover" data-container="body"',
paste0('data-trigger="', trigger, '"'),
paste0('data-placement="', position, '"'),
ifelse(!is.null(title), paste0('title="', title, '"'), ""),
paste0('data-content="', content, '"'))
popover_options_list <- list(
'data-toggle' = 'popover',
'data-container' = 'body',
'data-trigger' = trigger,
'data-placement' = position,
'data-content' = content
)
if (!is.null(title)) {
popover_options_list['title'] <- title
}
class(popover_options) <- "ke_popover"
attr(popover_options, 'list') <- popover_options_list
return(popover_options)
}
#' Setup image path, size, etc
#'
#' @description Users can directly provide image file path to column spec.
#' However, if you need to specify the size of the image, you will need this
#' function.
#'
#' @param path file path(s)
#' @param width image width in pixel
#' @param height image height in pixel
#' @param res image resolution.
#' @param svg_text If you have the raw text for SVG. Put them here
#'
#' @export
spec_image <- function(path, width, height, res = 300, svg_text = NULL) {
if (length(path) > 1) {
return(lapply(path, function(p) {
return(spec_image(p, width, height, res, svg_text))
}))
}
if (!is.null(svg_text)) {
out <- list(path = NULL, dev = NULL, type = "image",
width = NULL, height = NULL, res = NULL,
svg_text = svg_text)
class(out) <- "kableExtraInlinePlots"
return(out)
}
out <- list(path = path, dev = "external", type = "image",
width = width, height = height, res = res,
svg_text = svg_text)
class(out) <- "kableExtraInlinePlots"
return(out)
}
|
