1#' Slider Input Widget 2#' 3#' Constructs a slider widget to select a number, date, or date-time from a 4#' range. 5#' 6#' @inheritParams textInput 7#' @param min,max The minimum and maximum values (inclusive) that can be 8#' selected. 9#' @param value The initial value of the slider, either a number, a date 10#' (class Date), or a date-time (class POSIXt). A length one vector will 11#' create a regular slider; a length two vector will create a double-ended 12#' range slider. Must lie between `min` and `max`. 13#' @param step Specifies the interval between each selectable value on the 14#' slider. Either `NULL`, the default, which uses a heuristic to determine the 15#' step size or a single number. If the values are dates, `step` is in days; 16#' if the values are date-times, `step` is in seconds. 17#' @param round `TRUE` to round all values to the nearest integer; 18#' `FALSE` if no rounding is desired; or an integer to round to that 19#' number of digits (for example, 1 will round to the nearest 10, and -2 will 20#' round to the nearest .01). Any rounding will be applied after snapping to 21#' the nearest step. 22#' @param ticks `FALSE` to hide tick marks, `TRUE` to show them 23#' according to some simple heuristics. 24#' @param animate `TRUE` to show simple animation controls with default 25#' settings; `FALSE` not to; or a custom settings list, such as those 26#' created using [animationOptions()]. 27#' @param sep Separator between thousands places in numbers. 28#' @param pre A prefix string to put in front of the value. 29#' @param post A suffix string to put after the value. 30#' @param dragRange This option is used only if it is a range slider (with two 31#' values). If `TRUE` (the default), the range can be dragged. In other 32#' words, the min and max can be dragged together. If `FALSE`, the range 33#' cannot be dragged. 34#' @param timeFormat Only used if the values are Date or POSIXt objects. A time 35#' format string, to be passed to the Javascript strftime library. See 36#' <https://github.com/samsonjs/strftime> for more details. The allowed 37#' format specifications are very similar, but not identical, to those for R's 38#' [base::strftime()] function. For Dates, the default is `"%F"` 39#' (like `"2015-07-01"`), and for POSIXt, the default is `"%F %T"` 40#' (like `"2015-07-01 15:32:10"`). 41#' @param timezone Only used if the values are POSIXt objects. A string 42#' specifying the time zone offset for the displayed times, in the format 43#' `"+HHMM"` or `"-HHMM"`. If `NULL` (the default), times will 44#' be displayed in the browser's time zone. The value `"+0000"` will 45#' result in UTC time. 46#' @inheritParams selectizeInput 47#' @family input elements 48#' @seealso [updateSliderInput()] 49#' 50#' @examples 51#' ## Only run examples in interactive R sessions 52#' if (interactive()) { 53#' options(device.ask.default = FALSE) 54#' 55#' ui <- fluidPage( 56#' sliderInput("obs", "Number of observations:", 57#' min = 0, max = 1000, value = 500 58#' ), 59#' plotOutput("distPlot") 60#' ) 61#' 62#' # Server logic 63#' server <- function(input, output) { 64#' output$distPlot <- renderPlot({ 65#' hist(rnorm(input$obs)) 66#' }) 67#' } 68#' 69#' # Complete app with UI and server components 70#' shinyApp(ui, server) 71#' } 72#' 73#' @section Server value: 74#' A number, date, or date-time (depending on the class of `value`), or 75#' in the case of slider range, a vector of two numbers/dates/date-times. 76#' 77#' @export 78sliderInput <- function(inputId, label, min, max, value, step = NULL, 79 round = FALSE, ticks = TRUE, animate = FALSE, 80 width = NULL, sep = ",", pre = NULL, post = NULL, 81 timeFormat = NULL, timezone = NULL, dragRange = TRUE) { 82 validate_slider_value(min, max, value, "sliderInput") 83 84 dataType <- getSliderType(min, max, value) 85 86 if (is.null(timeFormat)) { 87 timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL) 88 } 89 90 # Restore bookmarked values here, after doing the type checking, because the 91 # restored value will be a character vector instead of Date or POSIXct, and we can do 92 # the conversion to correct type next. 93 value <- restoreInput(id = inputId, default = value) 94 95 if (is.character(value)) { 96 # If we got here, the value was restored from a URL-encoded bookmark. 97 if (dataType == "date") { 98 value <- as.Date(value, format = "%Y-%m-%d") 99 } else if (dataType == "datetime") { 100 # Date-times will have a format like "2018-02-28T03:46:26Z" 101 value <- as.POSIXct(value, format = "%Y-%m-%dT%H:%M:%SZ", tz = "UTC") 102 } 103 } 104 105 step <- findStepSize(min, max, step) 106 107 if (dataType %in% c("date", "datetime")) { 108 # For Dates, this conversion uses midnight on that date in UTC 109 to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x)) 110 111 # Convert values to milliseconds since epoch (this is the value JS uses) 112 # Find step size in ms 113 step <- to_ms(max) - to_ms(max - step) 114 min <- to_ms(min) 115 max <- to_ms(max) 116 value <- to_ms(value) 117 } 118 119 range <- max - min 120 121 # Try to get a sane number of tick marks 122 if (ticks) { 123 n_steps <- range / step 124 125 # Make sure there are <= 10 steps. 126 # n_ticks can be a noninteger, which is good when the range is not an 127 # integer multiple of the step size, e.g., min=1, max=10, step=4 128 scale_factor <- ceiling(n_steps / 10) 129 n_ticks <- n_steps / scale_factor 130 131 } else { 132 n_ticks <- NULL 133 } 134 135 sliderProps <- dropNulls(list( 136 class = "js-range-slider", 137 id = inputId, 138 `data-skin` = "shiny", 139 `data-type` = if (length(value) > 1) "double", 140 `data-min` = formatNoSci(min), 141 `data-max` = formatNoSci(max), 142 `data-from` = formatNoSci(value[1]), 143 `data-to` = if (length(value) > 1) formatNoSci(value[2]), 144 `data-step` = formatNoSci(step), 145 `data-grid` = ticks, 146 `data-grid-num` = n_ticks, 147 `data-grid-snap` = FALSE, 148 `data-prettify-separator` = sep, 149 `data-prettify-enabled` = (sep != ""), 150 `data-prefix` = pre, 151 `data-postfix` = post, 152 `data-keyboard` = TRUE, 153 # This value is only relevant for range sliders; for non-range sliders it 154 # causes problems since ion.RangeSlider 2.1.2 (issue #1605). 155 `data-drag-interval` = if (length(value) > 1) dragRange, 156 # The following are ignored by the ion.rangeSlider, but are used by Shiny. 157 `data-data-type` = dataType, 158 `data-time-format` = timeFormat, 159 `data-timezone` = timezone 160 )) 161 162 # Replace any TRUE and FALSE with "true" and "false" 163 sliderProps <- lapply(sliderProps, function(x) { 164 if (identical(x, TRUE)) "true" 165 else if (identical(x, FALSE)) "false" 166 else x 167 }) 168 169 sliderTag <- div(class = "form-group shiny-input-container", 170 style = css(width = validateCssUnit(width)), 171 shinyInputLabel(inputId, label), 172 do.call(tags$input, sliderProps) 173 ) 174 175 # Add animation buttons 176 if (identical(animate, TRUE)) 177 animate <- animationOptions() 178 179 if (!is.null(animate) && !identical(animate, FALSE)) { 180 if (is.null(animate$playButton)) 181 animate$playButton <- icon('play', lib = 'glyphicon') 182 if (is.null(animate$pauseButton)) 183 animate$pauseButton <- icon('pause', lib = 'glyphicon') 184 185 sliderTag <- tagAppendChild( 186 sliderTag, 187 tags$div(class='slider-animate-container', 188 tags$a(href='#', 189 class='slider-animate-button', 190 'data-target-id'=inputId, 191 'data-interval'=animate$interval, 192 'data-loop'=animate$loop, 193 span(class = 'play', animate$playButton), 194 span(class = 'pause', animate$pauseButton) 195 ) 196 ) 197 ) 198 } 199 200 attachDependencies(sliderTag, ionRangeSliderDependency()) 201} 202 203 204ionRangeSliderDependency <- function() { 205 list( 206 # ion.rangeSlider also needs normalize.css, which is already included in Bootstrap. 207 htmlDependency( 208 "ionrangeslider-javascript", version_ion_range_slider, 209 src = c(href = "shared/ionrangeslider"), 210 script = "js/ion.rangeSlider.min.js" 211 ), 212 htmlDependency( 213 "strftime", version_strftime, 214 src = c(href = "shared/strftime"), 215 script = "strftime-min.js" 216 ), 217 bslib::bs_dependency_defer(ionRangeSliderDependencyCSS) 218 ) 219} 220 221ionRangeSliderDependencyCSS <- function(theme) { 222 if (!is_bs_theme(theme)) { 223 return(htmlDependency( 224 "ionrangeslider-css", 225 version_ion_range_slider, 226 src = c(href = "shared/ionrangeslider"), 227 stylesheet = "css/ion.rangeSlider.css" 228 )) 229 } 230 231 bslib::bs_dependency( 232 input = list( 233 list(accent = "$component-active-bg"), 234 sass::sass_file( 235 system.file(package = "shiny", "www/shared/ionrangeslider/scss/shiny.scss") 236 ) 237 ), 238 theme = theme, 239 name = "ionRangeSlider", 240 version = version_ion_range_slider, 241 cache_key_extra = shinyPackageVersion() 242 ) 243} 244 245hasDecimals <- function(value) { 246 truncatedValue <- round(value) 247 return (!identical(value, truncatedValue)) 248} 249 250# If step is NULL, use heuristic to set the step size. 251findStepSize <- function(min, max, step) { 252 if (!is.null(step)) return(step) 253 254 range <- max - min 255 # If short range or decimals, use continuous decimal with ~100 points 256 if (range < 2 || hasDecimals(min) || hasDecimals(max)) { 257 # Workaround for rounding errors (#1006): the intervals between the items 258 # returned by pretty() can have rounding errors. To avoid this, we'll use 259 # pretty() to find the min, max, and number of steps, and then use those 260 # values to calculate the step size. 261 pretty_steps <- pretty(c(min, max), n = 100) 262 n_steps <- length(pretty_steps) - 1 263 264 # Fix for #2061: Windows has low-significance digits (like 17 digits out) 265 # even at the boundaries of pretty()'s output. Use signif(digits = 10), 266 # which should be way way less significant than any data we'd want to keep. 267 # It might make sense to use signif(steps[2] - steps[1], 10) instead, but 268 # for now trying to make the minimal change. 269 signif(digits = 10, (max(pretty_steps) - min(pretty_steps)) / n_steps) 270 271 } else { 272 1 273 } 274} 275 276# Throw a warning if ever `value` is not in the [`min`, `max`] range 277validate_slider_value <- function(min, max, value, fun) { 278 if (length(min) != 1 || is_na(min) || 279 length(max) != 1 || is_na(max) || 280 length(value) < 1 || length(value) > 2 || any(is.na(value))) 281 { 282 stop(call. = FALSE, 283 sprintf("In %s(): `min`, `max`, and `value` cannot be NULL, NA, or empty.", fun) 284 ) 285 } 286 287 if (min(value) < min) { 288 warning(call. = FALSE, 289 sprintf( 290 "In %s(): `value` should be greater than or equal to `min` (value = %s, min = %s).", 291 fun, paste(value, collapse = ", "), min 292 ) 293 ) 294 } 295 296 if (max(value) > max) { 297 warning( 298 noBreaks. = TRUE, call. = FALSE, 299 sprintf( 300 "In %s(): `value` should be less than or equal to `max` (value = %s, max = %s).", 301 fun, paste(value, collapse = ", "), max 302 ) 303 ) 304 } 305} 306 307 308#' @rdname sliderInput 309#' 310#' @param interval The interval, in milliseconds, between each animation step. 311#' @param loop `TRUE` to automatically restart the animation when it 312#' reaches the end. 313#' @param playButton Specifies the appearance of the play button. Valid values 314#' are a one-element character vector (for a simple text label), an HTML tag 315#' or list of tags (using [tag()] and friends), or raw HTML (using 316#' [HTML()]). 317#' @param pauseButton Similar to `playButton`, but for the pause button. 318#' @export 319animationOptions <- function(interval=1000, 320 loop=FALSE, 321 playButton=NULL, 322 pauseButton=NULL) { 323 list(interval=interval, 324 loop=loop, 325 playButton=playButton, 326 pauseButton=pauseButton) 327} 328