mirror of
https://github.com/rstudio/shiny.git
synced 2026-01-14 01:18:07 -05:00
262 lines
9.3 KiB
R
262 lines
9.3 KiB
R
#' Slider Input Widget
|
|
#'
|
|
#' Constructs a slider widget to select a numeric value from a range.
|
|
#'
|
|
#' @inheritParams textInput
|
|
#' @param min The minimum value (inclusive) that can be selected.
|
|
#' @param max The maximum value (inclusive) that can be selected.
|
|
#' @param value The initial value of the slider. A numeric vector of length one
|
|
#' will create a regular slider; a numeric vector of length two will create a
|
|
#' double-ended range slider. A warning will be issued if the value doesn't
|
|
#' fit between \code{min} and \code{max}.
|
|
#' @param step Specifies the interval between each selectable value on the
|
|
#' slider (if \code{NULL}, a heuristic is used to determine the step size). If
|
|
#' the values are dates, \code{step} is in days; if the values are times
|
|
#' (POSIXt), \code{step} is in seconds.
|
|
#' @param round \code{TRUE} to round all values to the nearest integer;
|
|
#' \code{FALSE} if no rounding is desired; or an integer to round to that
|
|
#' number of digits (for example, 1 will round to the nearest 10, and -2 will
|
|
#' round to the nearest .01). Any rounding will be applied after snapping to
|
|
#' the nearest step.
|
|
#' @param format Deprecated.
|
|
#' @param locale Deprecated.
|
|
#' @param ticks \code{FALSE} to hide tick marks, \code{TRUE} to show them
|
|
#' according to some simple heuristics.
|
|
#' @param animate \code{TRUE} to show simple animation controls with default
|
|
#' settings; \code{FALSE} not to; or a custom settings list, such as those
|
|
#' created using \code{\link{animationOptions}}.
|
|
#' @param sep Separator between thousands places in numbers.
|
|
#' @param pre A prefix string to put in front of the value.
|
|
#' @param post A suffix string to put after the value.
|
|
#' @param dragRange This option is used only if it is a range slider (with two
|
|
#' values). If \code{TRUE} (the default), the range can be dragged. In other
|
|
#' words, the min and max can be dragged together. If \code{FALSE}, the range
|
|
#' cannot be dragged.
|
|
#' @param timeFormat Only used if the values are Date or POSIXt objects. A time
|
|
#' format string, to be passed to the Javascript strftime library. See
|
|
#' \url{https://github.com/samsonjs/strftime} for more details. The allowed
|
|
#' format specifications are very similar, but not identical, to those for R's
|
|
#' \code{\link[base]{strftime}} function. For Dates, the default is \code{"\%F"}
|
|
#' (like \code{"2015-07-01"}), and for POSIXt, the default is \code{"\%F \%T"}
|
|
#' (like \code{"2015-07-01 15:32:10"}).
|
|
#' @param timezone Only used if the values are POSIXt objects. A string
|
|
#' specifying the time zone offset for the displayed times, in the format
|
|
#' \code{"+HHMM"} or \code{"-HHMM"}. If \code{NULL} (the default), times will
|
|
#' be displayed in the browser's time zone. The value \code{"+0000"} will
|
|
#' result in UTC time.
|
|
#' @inheritParams selectizeInput
|
|
#' @family input elements
|
|
#' @seealso \code{\link{updateSliderInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' sliderInput("obs", "Number of observations:",
|
|
#' min = 0, max = 1000, value = 500
|
|
#' ),
|
|
#' plotOutput("distPlot")
|
|
#' )
|
|
#'
|
|
#' # Server logic
|
|
#' server <- function(input, output) {
|
|
#' output$distPlot <- renderPlot({
|
|
#' hist(rnorm(input$obs))
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' # Complete app with UI and server components
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
sliderInput <- function(inputId, label, min, max, value, step = NULL,
|
|
round = FALSE, format = NULL, locale = NULL,
|
|
ticks = TRUE, animate = FALSE, width = NULL, sep = ",",
|
|
pre = NULL, post = NULL, timeFormat = NULL,
|
|
timezone = NULL, dragRange = TRUE)
|
|
{
|
|
if (!missing(format)) {
|
|
shinyDeprecated(msg = "The `format` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
|
|
version = "0.10.2.2")
|
|
}
|
|
if (!missing(locale)) {
|
|
shinyDeprecated(msg = "The `locale` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
|
|
version = "0.10.2.2")
|
|
}
|
|
|
|
value <- restoreInput(id = inputId, default = value)
|
|
|
|
# If step is NULL, use heuristic to set the step size.
|
|
findStepSize <- function(min, max, step) {
|
|
if (!is.null(step)) return(step)
|
|
|
|
range <- max - min
|
|
# If short range or decimals, use continuous decimal with ~100 points
|
|
if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
|
|
step <- pretty(c(min, max), n = 100)
|
|
step[2] - step[1]
|
|
} else {
|
|
1
|
|
}
|
|
}
|
|
|
|
if (inherits(min, "Date")) {
|
|
if (!inherits(max, "Date") || !inherits(value, "Date"))
|
|
stop("`min`, `max`, and `value must all be Date or non-Date objects")
|
|
dataType <- "date"
|
|
|
|
if (is.null(timeFormat))
|
|
timeFormat <- "%F"
|
|
|
|
} else if (inherits(min, "POSIXt")) {
|
|
if (!inherits(max, "POSIXt") || !inherits(value, "POSIXt"))
|
|
stop("`min`, `max`, and `value must all be POSIXt or non-POSIXt objects")
|
|
dataType <- "datetime"
|
|
|
|
if (is.null(timeFormat))
|
|
timeFormat <- "%F %T"
|
|
|
|
} else {
|
|
dataType <- "number"
|
|
}
|
|
|
|
step <- findStepSize(min, max, step)
|
|
|
|
if (dataType %in% c("date", "datetime")) {
|
|
# For Dates, this conversion uses midnight on that date in UTC
|
|
to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
|
|
|
|
# Convert values to milliseconds since epoch (this is the value JS uses)
|
|
# Find step size in ms
|
|
step <- to_ms(max) - to_ms(max - step)
|
|
min <- to_ms(min)
|
|
max <- to_ms(max)
|
|
value <- to_ms(value)
|
|
}
|
|
|
|
range <- max - min
|
|
|
|
# Try to get a sane number of tick marks
|
|
if (ticks) {
|
|
n_steps <- range / step
|
|
|
|
# Make sure there are <= 10 steps.
|
|
# n_ticks can be a noninteger, which is good when the range is not an
|
|
# integer multiple of the step size, e.g., min=1, max=10, step=4
|
|
scale_factor <- ceiling(n_steps / 10)
|
|
n_ticks <- n_steps / scale_factor
|
|
|
|
} else {
|
|
n_ticks <- NULL
|
|
}
|
|
|
|
sliderProps <- dropNulls(list(
|
|
class = "js-range-slider",
|
|
id = inputId,
|
|
`data-type` = if (length(value) > 1) "double",
|
|
`data-min` = formatNoSci(min),
|
|
`data-max` = formatNoSci(max),
|
|
`data-from` = formatNoSci(value[1]),
|
|
`data-to` = if (length(value) > 1) formatNoSci(value[2]),
|
|
`data-step` = formatNoSci(step),
|
|
`data-grid` = ticks,
|
|
`data-grid-num` = n_ticks,
|
|
`data-grid-snap` = FALSE,
|
|
`data-prefix` = pre,
|
|
`data-postfix` = post,
|
|
`data-keyboard` = TRUE,
|
|
`data-keyboard-step` = step / (max - min) * 100,
|
|
`data-drag-interval` = dragRange,
|
|
# The following are ignored by the ion.rangeSlider, but are used by Shiny.
|
|
`data-data-type` = dataType,
|
|
`data-time-format` = timeFormat,
|
|
`data-timezone` = timezone
|
|
))
|
|
|
|
if (sep == "") {
|
|
sliderProps$`data-prettify-enabled` <- "0"
|
|
} else {
|
|
sliderProps$`data-prettify-separator` <- sep
|
|
}
|
|
|
|
# Replace any TRUE and FALSE with "true" and "false"
|
|
sliderProps <- lapply(sliderProps, function(x) {
|
|
if (identical(x, TRUE)) "true"
|
|
else if (identical(x, FALSE)) "false"
|
|
else x
|
|
})
|
|
|
|
sliderTag <- div(class = "form-group shiny-input-container",
|
|
style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
|
|
if (!is.null(label)) controlLabel(inputId, label),
|
|
do.call(tags$input, sliderProps)
|
|
)
|
|
|
|
# Add animation buttons
|
|
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,
|
|
span(class = 'play', animate$playButton),
|
|
span(class = 'pause', animate$pauseButton)
|
|
)
|
|
)
|
|
)
|
|
}
|
|
|
|
dep <- list(
|
|
htmlDependency("ionrangeslider", "2.1.2", c(href="shared/ionrangeslider"),
|
|
script = "js/ion.rangeSlider.min.js",
|
|
# ion.rangeSlider also needs normalize.css, which is already included in
|
|
# Bootstrap.
|
|
stylesheet = c("css/ion.rangeSlider.css",
|
|
"css/ion.rangeSlider.skinShiny.css")
|
|
),
|
|
htmlDependency("strftime", "0.9.2", c(href="shared/strftime"),
|
|
script = "strftime-min.js"
|
|
)
|
|
)
|
|
|
|
attachDependencies(sliderTag, dep)
|
|
}
|
|
|
|
hasDecimals <- function(value) {
|
|
truncatedValue <- round(value)
|
|
return (!identical(value, truncatedValue))
|
|
}
|
|
|
|
#' @rdname sliderInput
|
|
#'
|
|
#' @param interval The interval, in milliseconds, between each animation step.
|
|
#' @param loop \code{TRUE} to automatically restart the animation when it
|
|
#' reaches the end.
|
|
#' @param playButton Specifies the appearance of the play button. Valid values
|
|
#' are a one-element character vector (for a simple text label), an HTML tag
|
|
#' or list of tags (using \code{\link{tag}} and friends), or raw HTML (using
|
|
#' \code{\link{HTML}}).
|
|
#' @param pauseButton Similar to \code{playButton}, but for the pause button.
|
|
#' @export
|
|
animationOptions <- function(interval=1000,
|
|
loop=FALSE,
|
|
playButton=NULL,
|
|
pauseButton=NULL) {
|
|
list(interval=interval,
|
|
loop=loop,
|
|
playButton=playButton,
|
|
pauseButton=pauseButton)
|
|
}
|