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
226
227
228
229
230
231
232
233
234
235
|
#' Create a colour input control
#'
#' Create an input control to select a colour.
#'
#' A colour input allows users to select a colour by clicking on the desired
#' colour, or by entering a valid colour in the input box. Colours can be
#' specified as either names ("blue"), HEX codes ("#0000FF"), RGB codes
#' ("rgb(0, 0, 255)"), or HSL codes ("hsl(240, 100, 50)"). Use
#' \code{allowTransparent = TRUE} to allow selecting semi-transparent colours.
#' The return value is a HEX value by default, but you can use the
#' \code{returnName = TRUE} parameter to get an R colour name instead
#' (only when an R colour exists for the selected colour).
#'
#' When \code{allowTransparent = TRUE}, the user can type into the input field
#' any RGBA value, HSLA value, or 8-digit HEX with alpha channel You can also use
#' any of these values as the \code{value} argument as the initial value of the
#' input.
#'
#' @param inputId The \code{input} slot that will be used to access the value.
#' @param label Display label for the control, or `\code{NULL} for no label.
#' @param value Initial value (can be a colour name or HEX code)
#' @param showColour Whether to show the chosen colour as text inside the input,
#' as the background colour of the input, or both (default).
#' @param palette The type of colour palette to allow the user to select colours
#' from. \code{square} (default) shows a square colour palette that allows the
#' user to choose any colour, while \code{limited} only gives the user a
#' predefined list of colours to choose from.
#' @param allowedCols A list of colours that the user can choose from. Only
#' applicable when \code{palette == "limited"}. The \code{limited} palette
#' uses a default list of 40 colours if \code{allowedCols} is not defined. If
#' the colour specified in \code{value} is not in the list, the default colour
#' will revert to black.
#' @param allowTransparent If \code{TRUE}, enables a slider to choose an alpha
#' (transparency) value for the colour. When a colour with opacity is
#' chosen, the return value is an 8-digit HEX code.
#' @param returnName If \code{TRUE}, then return the name of an R colour instead
#' of a HEX value when possible.
#' @param closeOnClick If \code{TRUE}, then the colour selection panel will close
#' immediately after selecting a colour.
#' @param width The width of the input, e.g. `"400px"` or `"100%"`
#' @seealso \code{\link[colourpicker]{updateColourInput}}
#' \code{\link[colourpicker]{colourPicker}}
#' @examples
#' if (interactive()) {
#' # Example 1
#' library(shiny)
#' shinyApp(
#' ui = fluidPage(
#' colourInput("col", "Choose colour", "red"),
#' plotOutput("plot")
#' ),
#' server = function(input, output, session) {
#' output$plot <- renderPlot({
#' plot(1:10, col = input$col)
#' })
#' }
#' )
#'
#' # Example 2
#' library(shiny)
#' shinyApp(
#' ui = fluidPage(
#' strong("Selected colour:", textOutput("value", inline = TRUE)),
#' colourInput("col", "Choose colour", "red"),
#' h3("Update colour input"),
#' textInput("text", "New colour: (colour name or HEX value)"),
#' selectInput("showColour", "Show colour",
#' c("both", "text", "background")),
#' selectInput("palette", "Colour palette",
#' c("square", "limited")),
#' checkboxInput("allowTransparent", "Allow transparent", FALSE),
#' checkboxInput("returnName", "Return R colour name", FALSE),
#' actionButton("btn", "Update")
#' ),
#' server = function(input, output, session) {
#' observeEvent(input$btn, {
#' updateColourInput(session, "col",
#' value = input$text, showColour = input$showColour,
#' allowTransparent = input$allowTransparent,
#' palette = input$palette,
#' returnName = input$returnName)
#' })
#' output$value <- renderText(input$col)
#' }
#' )
#' }
#' @note See \href{https://daattali.com/shiny/colourInput/}{https://daattali.com/shiny/colourInput/}
#' for a live demo.
#' @export
colourInput <- function(inputId, label, value = "white",
showColour = c("both", "text", "background"),
palette = c("square", "limited"),
allowedCols = NULL, allowTransparent = FALSE,
returnName = FALSE, closeOnClick = FALSE,
width = NULL) {
# sanitize the arguments
showColour <- match.arg(showColour)
palette <- match.arg(palette)
value <- restoreInput(id = inputId, default = value)
# declare dependencies
deps <- list(
htmltools::htmlDependency(
name = "colourpicker-binding",
version = as.character(utils::packageVersion("colourpicker")),
package = "colourpicker",
src = "srcjs",
script = "input_binding_colour.js"
),
htmltools::htmlDependency(
name = "colourpicker-lib",
version = "1.6",
package = "colourpicker",
src = "www/shared/colourpicker",
script = "js/colourpicker.min.js",
stylesheet = "css/colourpicker.min.css"
)
)
# build the colour input tag
inputTag <-
shiny::tags$input(
id = inputId, type = "text",
class = "form-control shiny-colour-input",
`data-init-value` = value,
`data-show-colour` = showColour,
`data-palette` = palette
)
if (!is.null(allowedCols)) {
allowedCols <- jsonlite::toJSON(allowedCols)
inputTag <- shiny::tagAppendAttributes(
inputTag,
`data-allowed-cols` = allowedCols)
}
if (returnName) {
inputTag <- shiny::tagAppendAttributes(
inputTag,
`data-return-name` = "true")
}
if (allowTransparent) {
inputTag <- shiny::tagAppendAttributes(
inputTag,
`data-allow-alpha` = "true")
}
if (closeOnClick) {
inputTag <- shiny::tagAppendAttributes(
inputTag,
`data-close-on-click` = "true")
}
inputTag <-
shiny::div(
class = "form-group shiny-input-container",
style = htmltools::css(width = htmltools::validateCssUnit(width)),
`data-shiny-input-type` = "colour",
label %AND% shiny::tags$label(label, class = "control-label", `for` = inputId),
inputTag
)
htmltools::attachDependencies(inputTag, deps)
}
#' Change the value of a colour input
#'
#' Change the value of a colour input on the client.
#'
#' The update function sends a message to the client, telling it to change
#' the settings of a colour input object.\cr
#' This function works similarly to the update functions provided by shiny.\cr
#' Any argument with \code{NULL} values will be ignored.
#'
#' @inheritParams colourInput
#' @param session The \code{session} object passed to function given to \code{shinyServer}.
#' @param inputId The id of the colour input object.
#' @param label The label to set for the input object.
#' @param value The value to set for the input object.
#' @seealso \code{\link[colourpicker]{colourInput}}
#' @examples
#' if (interactive()) {
#' library(shiny)
#' shinyApp(
#' ui = fluidPage(
#' div("Selected colour:", textOutput("value", inline = TRUE)),
#' colourInput("col", "Choose colour", "red"),
#' h3("Update colour input"),
#' textInput("text", "New colour: (colour name or HEX value)"),
#' selectInput("showColour", "Show colour",
#' c("both", "text", "background")),
#' checkboxInput("allowTransparent", "Allow transparent", FALSE),
#' checkboxInput("returnName", "Return R colour name", FALSE),
#' actionButton("btn", "Update")
#' ),
#' server = function(input, output, session) {
#' observeEvent(input$btn, {
#' updateColourInput(session, "col",
#' value = input$text, showColour = input$showColour,
#' allowTransparent = input$allowTransparent,
#' returnName = input$returnName)
#' })
#' output$value <- renderText(input$col)
#' }
#' )
#' }
#' @note See \href{https://daattali.com/shiny/colourInput/}{https://daattali.com/shiny/colourInput/}
#' for a live demo.
#' @export
updateColourInput <- function(session, inputId, label = NULL, value = NULL,
showColour = NULL, palette = NULL, allowedCols = NULL,
allowTransparent = NULL,
returnName = NULL, closeOnClick = NULL) {
message <- dropNulls(list(
label = label, value = value,
showColour = showColour,
palette = palette,
allowedCols = allowedCols,
allowAlpha = allowTransparent,
returnName = returnName,
closeOnClick = closeOnClick
))
session$sendInputMessage(inputId, message)
}
# copied from shiny since it's not exported
dropNulls <- function(x) {
x[!vapply(x, is.null, FUN.VALUE=logical(1))]
}
# copied from shiny since it's not exported
`%AND%` <- function(x, y) {
if (!is.null(x) && !isTRUE(is.na(x)))
if (!is.null(y) && !isTRUE(is.na(y)))
return(y)
return(NULL)
}
|
