github/shiny
1
1
Fork 0
mirror of https://github.com/rstudio/shiny.git synced 2026-01-10 07:28:01 -05:00
Code Issues Packages Projects Releases Wiki Activity

Add a warning message when value < min | value > max in sliderInput (#3194)

Browse Source 
Co-authored-by: Carson Sievert <cpsievert1@gmail.com>
Co-authored-by: colin <colin@thinkr.fr>
Co-authored-by: Colin Fay <contact@colinfay.me>
This commit is contained in:
Winston Chang
2020-12-08 10:55:18 -06:00
committed by GitHub
parent 24a1ef9594
commit bbf9bee28e
5 changed files with 186 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
NEWS.md
View File

@@ -76,6 +76,8 @@ shiny 1.5.0.9000
* Fixed a bug that `textAreaInput()` doesn't work as expected for relative `width` (thanks to @shrektan). (#2049)
* Closed #2910, #2909, #1552: `sliderInput()` warns if the `value` is outside of `min` and `max`, and errors if `value` is `NULL` or `NA`. (#3194)
### Library updates
* Removed html5shiv and respond.js, which were used for IE 8 and IE 9 compatibility. (#2973)

33
R/input-slider.R
View File

@@ -89,6 +89,8 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
version = "0.10.2.2")
}
validate_slider_value(min, max, value, "sliderInput")
dataType <- getSliderType(min, max, value)
if (is.null(timeFormat)) {
@@ -296,6 +298,37 @@ findStepSize <- function(min, max, step) {
}
}
# Throw a warning if ever `value` is not in the [`min`, `max`] range
validate_slider_value <- function(min, max, value, fun) {
if (length(min) != 1 || is_na(min) ||
length(max) != 1 || is_na(max) ||
length(value) < 1 || length(value) > 2 || any(is.na(value)))
{
stop(call. = FALSE,
sprintf("In %s(): `min`, `max`, and `value` cannot be NULL, NA, or empty.", fun)
)
}
if (min(value) < min) {
warning(call. = FALSE,
sprintf(
"In %s(): `value` should be greater than or equal to `min` (value = %s, min = %s).",
fun, paste(value, collapse = ", "), min
)
)
}
if (max(value) > max) {
warning(
noBreaks. = TRUE, call. = FALSE,
sprintf(
"In %s(): `value` should be less than or equal to `max` (value = %s, max = %s).",
fun, paste(value, collapse = ", "), max
)
)
}
}
#' @rdname sliderInput
#'

55
tests/testthat/test-input-select.R
View File

@@ -43,3 +43,58 @@ test_that("jqueryui is attached when drag_drop plugin is present", {
c("selectize", "jqueryui")
)
})
test_that("selectInput options are properly escaped", {
si <- selectInput("quote", "Quote", list(
"\"Separators\"" = list(
"None" = "",
"Double quote" = "\"",
"Single quote" = "'"
)
))
si_str <- as.character(si)
expect_true(any(grepl("<option value=\"&quot;\">", si_str, fixed = TRUE)))
expect_true(any(grepl("<option value=\"&#39;\">", si_str, fixed = TRUE)))
expect_true(any(grepl("<optgroup label=\"&quot;Separators&quot;\">", si_str, fixed = TRUE)))
})
test_that("selectInputUI has a select at an expected location", {
for (multiple in c(TRUE, FALSE)) {
for (selected in list(NULL, "", "A")) {
for (selectize in c(TRUE, FALSE)) {
selectInputVal <- selectInput(
inputId = "testId",
label = "test label",
choices = c("A", "B", "C"),
selected = selected,
multiple = multiple,
selectize = selectize
)
# if this getter is changed, varSelectInput getter needs to be changed
selectHtml <- selectInputVal$children[[2]]$children[[1]]
expect_true(inherits(selectHtml, "shiny.tag"))
expect_equal(selectHtml$name, "select")
if (!is.null(selectHtml$attribs$class)) {
expect_false(grepl(selectHtml$attribs$class, "symbol"))
}
varSelectInputVal <- varSelectInput(
inputId = "testId",
label = "test label",
data = data.frame(A = 1:2, B = 3:4, C = 5:6),
selected = selected,
multiple = multiple,
selectize = selectize
)
# if this getter is changed, varSelectInput getter needs to be changed
varSelectHtml <- varSelectInputVal$children[[2]]$children[[1]]
expect_true(inherits(varSelectHtml, "shiny.tag"))
expect_equal(varSelectHtml$name, "select")
expect_true(grepl("symbol", varSelectHtml$attribs$class, fixed = TRUE))
}
}
}
})

96
tests/testthat/test-input-slider.R Normal file
View File

@@ -0,0 +1,96 @@
# For issue #1006
test_that("sliderInput steps don't have rounding errors", {
# Need to use expect_identical; expect_equal is too forgiving of rounding error
expect_identical(findStepSize(-5.5, 4, NULL), 0.1)
})
test_that("sliderInput validation", {
# Number
x <- 10
expect_silent(sliderInput('s', 's', x-1, x+1, x))
expect_silent(sliderInput('s', 's', x-1, x+1, x-1))
expect_silent(sliderInput('s', 's', x-1, x+1, c(x-1, x+1)))
expect_warning(sliderInput('s', 's', x-1, x+1, x+2))
expect_warning(sliderInput('s', 's', x-1, x+1, x-2))
expect_warning(sliderInput('s', 's', x-1, x+1, c(x-2, x)))
expect_warning(sliderInput('s', 's', x-1, x+1, c(x, x+2)))
expect_error(sliderInput('s', 's', x-1, x+1))
expect_error(sliderInput('s', 's', x-1, x+1, NULL))
expect_error(sliderInput('s', 's', x-1, NULL, x))
expect_error(sliderInput('s', 's', NULL, x+1, x))
expect_error(sliderInput('s', 's', NULL, NULL, x))
expect_error(sliderInput('s', 's', x-1, x+1, NA_real_))
expect_error(sliderInput('s', 's', x-1, x+1, c(x, NA_real_)))
# Date
x <- Sys.Date()
expect_silent(sliderInput('s', 's', x-1, x+1, x))
expect_silent(sliderInput('s', 's', x-1, x+1, x-1))
expect_silent(sliderInput('s', 's', x-1, x+1, c(x-1, x+1)))
expect_warning(sliderInput('s', 's', x-1, x+1, x+2))
expect_warning(sliderInput('s', 's', x-1, x+1, x-2))
expect_warning(sliderInput('s', 's', x-1, x+1, c(x-2, x)))
expect_warning(sliderInput('s', 's', x-1, x+1, c(x, x+2)))
expect_error(sliderInput('s', 's', x-1, x+1))
expect_error(sliderInput('s', 's', x-1, x+1, NULL))
expect_error(sliderInput('s', 's', x-1, NULL, x))
expect_error(sliderInput('s', 's', NULL, x+1, x))
expect_error(sliderInput('s', 's', NULL, NULL, x))
expect_error(sliderInput('s', 's', x-1, x+1, as.Date(NA)))
# POSIXct
x <- Sys.time()
expect_silent(sliderInput('s', 's', x-1, x+1, x))
expect_silent(sliderInput('s', 's', x-1, x+1, x-1))
expect_silent(sliderInput('s', 's', x-1, x+1, c(x-1, x+1)))
expect_warning(sliderInput('s', 's', x-1, x+1, x+2))
expect_warning(sliderInput('s', 's', x-1, x+1, x-2))
expect_warning(sliderInput('s', 's', x-1, x+1, c(x-2, x)))
expect_warning(sliderInput('s', 's', x-1, x+1, c(x, x+2)))
expect_error(sliderInput('s', 's', x-1, x+1))
expect_error(sliderInput('s', 's', x-1, x+1, NULL))
expect_error(sliderInput('s', 's', x-1, NULL, x))
expect_error(sliderInput('s', 's', NULL, x+1, x))
expect_error(sliderInput('s', 's', NULL, NULL, x))
# POSIXLt
x <- as.POSIXlt(Sys.time())
expect_silent(sliderInput('s', 's', x-1, x+1, x))
expect_silent(sliderInput('s', 's', x-1, x+1, x-1))
expect_silent(sliderInput('s', 's', x-1, x+1, c(x-1, x+1)))
expect_warning(sliderInput('s', 's', x-1, x+1, x+2))
expect_warning(sliderInput('s', 's', x-1, x+1, x-2))
expect_warning(sliderInput('s', 's', x-1, x+1, c(x-2, x)))
expect_warning(sliderInput('s', 's', x-1, x+1, c(x, x+2)))
expect_error(sliderInput('s', 's', x-1, x+1))
expect_error(sliderInput('s', 's', x-1, x+1, NULL))
expect_error(sliderInput('s', 's', x-1, NULL, x))
expect_error(sliderInput('s', 's', NULL, x+1, x))
expect_error(sliderInput('s', 's', NULL, NULL, x))
# Size
x <- 10
## length 0
expect_error(sliderInput('s', 's', x-1, x+1, numeric(0)))
expect_error(sliderInput('s', 's', x-1, numeric(0), x))
expect_error(sliderInput('s', 's', numeric(0), x+1, x))
## length 1
expect_silent(sliderInput('s', 's', x-1, x+1, x))
## length 2
expect_silent(sliderInput('s', 's', x-1, x+1, c(x, x)))
## length 3+
expect_error(sliderInput('s', 's', x-1, x+1, c(x, x, x)))
expect_error(sliderInput('s', 's', x-1, c(x, x, x), x))
expect_error(sliderInput('s', 's', c(x, x, x), x+1, x))
})

62
tests/testthat/test-ui.R
View File

@@ -1,62 +0,0 @@
context("UI")
test_that("selectInput options are properly escaped", {
si <- selectInput("quote", "Quote", list(
"\"Separators\"" = list(
"None" = "",
"Double quote" = "\"",
"Single quote" = "'"
)
))
si_str <- as.character(si)
expect_true(any(grepl("<option value=\"&quot;\">", si_str, fixed = TRUE)))
expect_true(any(grepl("<option value=\"&#39;\">", si_str, fixed = TRUE)))
expect_true(any(grepl("<optgroup label=\"&quot;Separators&quot;\">", si_str, fixed = TRUE)))
})
# For issue #1006
test_that("sliderInput steps don't have rounding errors", {
# Need to use expect_identical; expect_equal is too forgiving of rounding error
expect_identical(findStepSize(-5.5, 4, NULL), 0.1)
})
test_that("selectInputUI has a select at an expected location", {
for (multiple in c(TRUE, FALSE)) {
for (selected in list(NULL, "", "A")) {
for (selectize in c(TRUE, FALSE)) {
selectInputVal <- selectInput(
inputId = "testId",
label = "test label",
choices = c("A", "B", "C"),
selected = selected,
multiple = multiple,
selectize = selectize
)
# if this getter is changed, varSelectInput getter needs to be changed
selectHtml <- selectInputVal$children[[2]]$children[[1]]
expect_true(inherits(selectHtml, "shiny.tag"))
expect_equal(selectHtml$name, "select")
if (!is.null(selectHtml$attribs$class)) {
expect_false(grepl(selectHtml$attribs$class, "symbol"))
}
varSelectInputVal <- varSelectInput(
inputId = "testId",
label = "test label",
data = data.frame(A = 1:2, B = 3:4, C = 5:6),
selected = selected,
multiple = multiple,
selectize = selectize
)
# if this getter is changed, varSelectInput getter needs to be changed
varSelectHtml <- varSelectInputVal$children[[2]]$children[[1]]
expect_true(inherits(varSelectHtml, "shiny.tag"))
expect_equal(varSelectHtml$name, "select")
expect_true(grepl("symbol", varSelectHtml$attribs$class, fixed = TRUE))
}
}
}
})