#' @title Slider Text Input Widget
#'
#' @description Constructs a slider widget with characters instead of numeric values.
#'
#' @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 choices Character vector to select a value from.
#' @param selected The initially selected value, if length > 1, create a range slider.
#' @param animate TRUE to show simple animation controls with default settings, for more details see \code{\link[shiny]{sliderInput}}.
#' @param grid Logical, show or hide ticks marks.
#' @param hide_min_max Hides min and max labels.
#' @param from_fixed Fix position of left (or single) handle.
#' @param to_fixed Fix position of right handle.
#' @param from_min Set minimum limit for left handle.
#' @param from_max Set the maximum limit for left handle.
#' @param to_min Set minimum limit for right handle.
#' @param to_max Set the maximum limit for right handle.
#' @param force_edges Slider will be always inside it's container.
#' @param width The width of the input, e.g. `400px`, or `100%`.
#' @param pre A prefix string to put in front of the value.
#' @param post A suffix string to put after the value.
#' @param dragRange See the same argument in \code{\link[shiny]{sliderInput}}.
#'
#' @seealso \link{updateSliderTextInput} to update value server-side.
#'
#' @return The value retrieved server-side is a character vector.
#' @export
#'
#' @importFrom htmltools validateCssUnit tagAppendChild htmlDependencies tags tagList
#' @importFrom shiny icon sliderInput animationOptions restoreInput
#' @importFrom jsonlite toJSON
#'
#' @examples
#' if (interactive()) {
#'
#' library("shiny")
#' library("shinyWidgets")
#'
#' ui <- fluidPage(
#' br(),
#' sliderTextInput(
#' inputId = "mySliderText",
#' label = "Month range slider:",
#' choices = month.name,
#' selected = month.name[c(4, 7)]
#' ),
#' verbatimTextOutput(outputId = "result")
#' )
#'
#' server <- function(input, output, session) {
#' output$result <- renderPrint(str(input$mySliderText))
#' }
#'
#' shinyApp(ui = ui, server = server)
#'
#' }
sliderTextInput <- function (inputId,
label,
choices,
selected = NULL,
animate = FALSE,
grid = FALSE,
hide_min_max = FALSE,
from_fixed = FALSE,
to_fixed = FALSE,
from_min = NULL,
from_max = NULL,
to_min = NULL,
to_max = NULL,
force_edges = FALSE,
width = NULL,
pre = NULL,
post = NULL,
dragRange = TRUE) {
selected <- shiny::restoreInput(id = inputId, default = selected)
choices_as_char <- inherits(choices, c("character", "factor"))
choices <- as.character(choices)
if (is.null(selected)) {
selected <- choices[1]
} else {
selected <- as.character(selected)
}
from <- match(x = selected[1], table = choices) - 1
if (is.na(from))
stop("Invalid 'selected' arguments, probably not an element of 'choices'.")
if (length(selected) > 1) {
to <- match(x = selected[2], table = choices) - 1
if (is.na(to))
stop("Invalid 'selected' arguments, probably not an element of 'choices'.")
} else {
to <- NULL
}
if (!is.null(from_min))
from_min <- match(x = from_min, table = choices) - 1
if (!is.null(from_max))
from_max <- match(x = from_max, table = choices) - 1
if (!is.null(to_min))
to_min <- match(x = to_min, table = choices) - 1
if (!is.null(to_max))
to_max <- match(x = to_max, table = choices) - 1
sliderProps <- dropNulls(list(
class = "js-range-slider",
class = "sw-slider-text",
id = inputId,
`data-type` = if (length(selected) > 1) "double",
`data-from` = from,
`data-skin` = "shiny",
`data-to` = if (length(selected) > 1) to,
`data-grid` = grid,
`data-prettify-enabled` = FALSE,
`data-force-edges` = force_edges,
`data-hide-min-max` = hide_min_max,
`data-prefix` = pre,
`data-postfix` = post,
`data-from-fixed` = from_fixed,
`data-to-fixed` = to_fixed,
`data-from-min` = from_min,
`data-from-max` = from_max,
`data-to-min` = to_min,
`data-to-max` = to_max,
`data-from-shadow` = !is.null(from_min) | !is.null(from_max),
`data-to-shadow` = !is.null(to_min) | !is.null(to_max),
`data-swvalues` = enc2native(jsonlite::toJSON(x = choices)),
`data-keyboard` = TRUE,
`data-drag-interval` = if (length(selected) > 1) dragRange,
`data-data-type` = if (choices_as_char) "text" else "num"
))
sliderProps <- lapply(sliderProps, function(x) {
if (identical(x, TRUE))
"true"
else if (identical(x, FALSE))
"false"
else x
})
sliderTag <- tags$div(
class = "form-group shiny-input-container",
style = css(width = validateCssUnit(width)),
label_input(inputId, label),
do.call(htmltools::tags$input, sliderProps)
)
if (identical(animate, TRUE))
animate <- animationOptions()
if (!is.null(animate) && !identical(animate, FALSE)) {
if (is.null(animate$playButton))
animate$playButton <- icon("play", lib = "glyphicon")
if (is.null(animate$pauseButton))
animate$pauseButton <- icon("pause", lib = "glyphicon")
sliderTag <- tagAppendChild(
sliderTag,
tags$div(
class = "slider-animate-container",
tags$a(
href = "#",
class = "slider-animate-button",
`data-target-id` = inputId,
`data-interval` = animate$interval,
`data-loop` = animate$loop,
tags$span(
class = "play",
animate$playButton
),
tags$span(
class = "pause",
animate$pauseButton
)
)
)
)
}
slider <- sliderInput(inputId = "id", label = "label", min = 1, max = 10, value = 5)
attachShinyWidgetsDep(sliderTag, extra_deps = htmlDependencies(slider))
}
#' @title Change the value of a slider text input on the client
#'
#' @description
#' Change the value of a slider text input on the client
#'
#' @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.
#' @param selected The values selected.
#' @param choices The new choices for the input.
#' @param from_fixed Fix the left handle (or single handle).
#' @param to_fixed Fix the right handle.
#'
#' @export
#'
#' @seealso \code{\link{sliderTextInput}}
#'
#' @examples
#' if (interactive()) {
#' library("shiny")
#' library("shinyWidgets")
#'
#' ui <- fluidPage(
#' br(),
#' sliderTextInput(
#' inputId = "mySlider",
#' label = "Pick a month :",
#' choices = month.abb,
#' selected = "Jan"
#' ),
#' verbatimTextOutput(outputId = "res"),
#' radioButtons(
#' inputId = "up",
#' label = "Update choices:",
#' choices = c("Abbreviations", "Full names")
#' )
#' )
#'
#' server <- function(input, output, session) {
#' output$res <- renderPrint(str(input$mySlider))
#'
#' observeEvent(input$up, {
#' choices <- switch(
#' input$up,
#' "Abbreviations" = month.abb,
#' "Full names" = month.name
#' )
#' updateSliderTextInput(
#' session = session,
#' inputId = "mySlider",
#' choices = choices
#' )
#' }, ignoreInit = TRUE)
#' }
#'
#' shinyApp(ui = ui, server = server)
#' }
updateSliderTextInput <- function (session = getDefaultReactiveDomain(),
inputId,
label = NULL,
selected = NULL,
choices = NULL,
from_fixed = NULL,
to_fixed = NULL) {
message <- dropNulls(list(
label = label, selected = selected, choices = choices,
from_fixed = from_fixed, to_fixed = to_fixed
))
session$sendInputMessage(inputId, message)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.