-
Notifications
You must be signed in to change notification settings - Fork 300
/
utils.R
221 lines (189 loc) · 6.07 KB
/
utils.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
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
#' Assert that a tag has specified properties
#' @param tag A tag object.
#' @param type The type of a tag, like "div", "a", "span".
#' @param class An HTML class.
#' @param allowUI If TRUE (the default), allow dynamic outputs generated by
#' \code{\link[shiny]{uiOutput}} or \code{\link[shiny]{htmlOutput}}. When a
#' dynamic output is provided, \code{tagAssert} won't try to validate the the
#' contents.
#' @keywords internal
tagAssert <- function(tag, type = NULL, class = NULL, allowUI = TRUE) {
if (!inherits(tag, "shiny.tag")) {
print(tag)
stop("Expected an object with class 'shiny.tag'.")
}
# Skip dynamic output elements
if (allowUI &&
(hasCssClass(tag, "shiny-html-output") ||
hasCssClass(tag, "shinydashboard-menu-output"))) {
return()
}
if (!is.null(type) && tag$name != type) {
stop("Expected tag to be of type ", type)
}
if (!is.null(class)) {
if (is.null(tag$attribs$class)) {
stop("Expected tag to have class '", class, "'")
} else {
tagClasses <- strsplit(tag$attribs$class, " ")[[1]]
if (!(class %in% tagClasses)) {
stop("Expected tag to have class '", class, "'")
}
}
}
}
# Given the name of an icon, like "fa-dashboard" or "glyphicon-user",
# return CSS classnames, like "fa fa-dashboard" or "glyphicon glyphicon-user".
getIconClass <- function(icon) {
iconGroup <- sub("^((glyphicon)|(fa))-.*", "\\1", icon)
paste(iconGroup, icon)
}
# Returns TRUE if a color is a valid color defined in AdminLTE, throws error
# otherwise.
validateColor <- function(color) {
if (color %in% validColors) {
return(TRUE)
}
stop("Invalid color: ", color, ". Valid colors are: ",
paste(validColors, collapse = ", "), ".")
}
#' Valid colors
#'
#' These are valid colors for various dashboard components. Valid colors are
#' listed below.
#'
#' \itemize{
#' \item \code{red}
#' \item \code{yellow}
#' \item \code{aqua}
#' \item \code{blue}
#' \item \code{light-blue}
#' \item \code{green}
#' \item \code{navy}
#' \item \code{teal}
#' \item \code{olive}
#' \item \code{lime}
#' \item \code{orange}
#' \item \code{fuchsia}
#' \item \code{purple}
#' \item \code{maroon}
#' \item \code{black}
#' }
#'
#' @usage NULL
#' @format NULL
#'
#' @keywords internal
validColors <- c("red", "yellow", "aqua", "blue", "light-blue", "green",
"navy", "teal", "olive", "lime", "orange", "fuchsia",
"purple", "maroon", "black")
# Returns TRUE if a status is valid; throws error otherwise.
validateStatus <- function(status) {
if (status %in% validStatuses) {
return(TRUE)
}
stop("Invalid status: ", status, ". Valid statuses are: ",
paste(validStatuses, collapse = ", "), ".")
}
#' Valid statuses
#'
#' These status strings correspond to colors as defined in Bootstrap's CSS.
#' Although the colors can vary depending on the particular CSS selector, they
#' generally appear as follows:
#'
#' \itemize{
#' \item \code{primary} Blue (sometimes dark blue)
#' \item \code{success} Green
#' \item \code{info} Blue
#' \item \code{warning} Orange
#' \item \code{danger} Red
#' }
#'
#' @usage NULL
#' @format NULL
#'
#' @keywords internal
validStatuses <- c("primary", "success", "info", "warning", "danger")
"%OR%" <- function(a, b) if (!is.null(a)) a else b
# Return TRUE if a shiny.tag object has a CSS class, FALSE otherwise.
hasCssClass <- function(tag, class) {
if (is.null(tag$attribs) || is.null(tag$attribs$class))
return(FALSE)
classes <- strsplit(tag$attribs$class, " +")[[1]]
return(class %in% classes)
}
# Make sure a tab name is valid (there's no "." in it).
validateTabName <- function(name) {
if (grepl(".", name, fixed = TRUE)) {
stop("tabName must not have a '.' in it.")
}
}
# This is like a==b, except that if a or b is NULL or an empty vector, it won't
# return logical(0). If a AND b are NULL/length-0, this will return TRUE; if
# just one of them is NULL/length-0, this will FALSE. This is for use in
# conditionals where `if(logical(0))` would cause an error. Similar to using
# identical(a,b), but less stringent about types: `equals(1, 1L)` is TRUE, but
# `identical(1, 1L)` is FALSE.
equals <- function(a, b) {
alen <- length(a)
blen <- length(b)
if (alen==0 && blen==0) {
return(TRUE)
}
if (alen > 1 || blen > 1) {
stop("Can only compare objects of length 0 or 1")
}
if (alen==0 || blen==0) {
return(FALSE)
}
a == b
}
# Return TRUE if a tag object matches a specific id, and/or tag name, and/or
# class, and or other arbitrary tag attributes. Put the args after ... so that
# caller must use named arguments.
tagMatches <- function(item, ..., id = NULL, name = NULL, class = NULL) {
dots <- list(...)
if (!inherits(item, "shiny.tag")) {
return(FALSE)
}
if (!is.null(id) && !equals(item$attribs$id, id)) {
return(FALSE)
}
if (!is.null(name) && !equals(item$name, name)) {
return(FALSE)
}
if (!is.null(class)) {
if (is.null(item$attribs$class)) {
return(FALSE)
}
classes <- strsplit(item$attribs$class, " ")[[1]]
if (! class %in% classes) {
return(FALSE)
}
}
for (i in seq_along(dots)) {
arg <- dots[[i]]
argName <- names(dots)[[i]]
if (!equals(item$attribs[[argName]], arg)) {
return(FALSE)
}
}
TRUE
}
# This function takes a DOM element/tag object and reccurs within it until
# it finds a child which has an attribute called `attr` and with value `val`
# (and returns TRUE). If it finds an element with an attribute called `attr`
# whose value is NOT `val`, it returns FALSE. If it exhausts all children
# and it doesn't find an element with an attribute called `attr`, it also
# returns FALSE
findAttribute <- function(x, attr, val) {
if (is.atomic(x)) return(FALSE) # exhausted this branch of the tree
if (!is.null(x$attribs[[attr]])) { # found attribute called `attr`
if (identical(x$attribs[[attr]], val)) return(TRUE)
else return(FALSE)
}
if (length(x$children) > 0) { # recursion
return(any(unlist(lapply(x$children, findAttribute, attr, val))))
}
return(FALSE) # found no attribute called `attr`
}