Nothing
#' @title Color Pickr
#'
#' @description A widget to pick color with different themes and options.
#'
#' @param inputId The \code{input} slot that will be used to access the value.
#' @param label Display label for the color pickr, or \code{NULL} for no label.
#' @param selected Default selected value.
#' @param swatches Optional color swatches. When \code{NULL}, swatches are disabled.
#' @param preview Display comparison between previous state and new color.
#' @param hue Display hue slider.
#' @param opacity Display opacity slider.
#' @param interaction List of parameters to show or hide components on the
#' bottom interaction bar. See link below for documentation.
#' @param theme Which theme you want to use. Can be 'classic', 'monolith' or 'nano'.
#' @param update When to update value server-side.
#' @param position Defines the position of the color-picker.
#' @param hideOnSave Hide color-picker after selecting a color.
#' @param useAsButton Show color-picker in a button instead of an input with value displayed.
#' @param inline Always show color-picker in page as a full element.
#' @param i18n List of translations for labels, see online documentation.
#' @param pickr_width Color-picker width (correspond to popup window).
#' @param width Color-picker width (correspond to input).
#'
#' @note Widget based on JS library pickr by \href{https://github.com/Simonwep}{Simonwep}.
#' See online documentation for more information: \url{https://github.com/Simonwep/pickr}.
#'
#' @return a color picker input widget that can be added to the UI of a shiny app.
#'
#' @seealso [updateColorPickr()] for updating from server.
#'
#' @export
#'
#'
#' @importFrom htmltools tags
#' @importFrom utils modifyList
#' @importFrom jsonlite toJSON
#'
#' @example examples/pickr-color.R
colorPickr <- function(inputId,
label,
selected = "#112446",
swatches = NULL,
preview = TRUE,
hue = TRUE,
opacity = FALSE,
interaction = NULL,
theme = c("classic", "monolith", "nano"),
update = c("save", "changestop", "change", "swatchselect"),
position = "bottom-middle",
hideOnSave = TRUE,
useAsButton = FALSE,
inline = FALSE,
i18n = NULL,
pickr_width = NULL,
width = NULL) {
selected <- restoreInput(id = inputId, default = selected)
theme <- match.arg(theme)
update <- match.arg(update)
if (is.null(interaction)) {
interaction <- list(
cancel = FALSE,
clear = TRUE,
save = TRUE,
hex = TRUE,
rgba = TRUE,
input = TRUE
)
} else if (is.list(interaction)) {
interaction <- modifyList(
x = list(
cancel = FALSE,
clear = TRUE,
save = TRUE,
hex = TRUE,
rgba = TRUE,
input = TRUE
),
val = interaction
)
}
if (isTRUE(inline)) {
hideOnSave <- FALSE
useAsButton <- TRUE
pickr_width <- width %||% pickr_width
}
if (!is.null(pickr_width)) {
pickr_width <- validateCssUnit(pickr_width)
}
config <- dropNulls(list(
update = update,
hideOnSave = isTRUE(hideOnSave),
width = pickr_width,
inline = isTRUE(inline),
options = dropNulls(list(
useAsButton = !isTRUE(useAsButton),
theme = theme,
default = selected,
swatches = swatches,
inline = inline,
showAlways = inline,
position = position,
components = dropNulls(list(
preview = preview,
opacity = opacity,
hue = hue,
interaction = interaction
)),
i18n = i18n
))
))
tags$div(
class = "form-group shiny-input-container",
style = css(width = validateCssUnit(width)),
tagAppendAttributes(
label_input(inputId, label),
style = if (isTRUE(useAsButton)) "vertical-align: bottom;"
),
tags$div(
id = inputId,
class = "pickr-color-container",
tags$input(
type = "text",
class = "form-control pickr-color",
readonly = "readonly"
),
tags$script(
type = "application/json",
`data-for` = inputId,
toJSON(config, auto_unbox = TRUE, json_verbatim = TRUE)
)
),
html_dependency_pickr()
)
}
#' Update color pickr server-side
#'
#' @param session The session object passed to function given to shinyServer.
#' @param inputId The id of the input object.
#' @param label The label to set for the input object.
#' @param value The value to set for the input object.
#' @param action Action to perform on color-picker: enable, disable, show or hide.
#' @param swatches Optional color swatches.
#'
#' @return No return value.
#'
#' @seealso [colorPickr()] for creating a widget in the UI.
#'
#' @export
#'
#' @example examples/updateColorPickr.R
updateColorPickr <- function(session = getDefaultReactiveDomain(),
inputId,
label = NULL,
value = NULL,
action = NULL,
swatches = NULL) {
if (!is.null(action)) {
action <- match.arg(action, c("disable", "enable", "hide", "show"))
}
message <- dropNulls(list(
value = value,
label = label,
action = action,
swatches = list1(swatches)
))
session$sendInputMessage(inputId, message)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.