Update tests and language

Conflicts:
	R/input-slider.R

R/input-slider.R

@@ -79,9 +79,12 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                         round = FALSE, ticks = TRUE, animate = FALSE,
                         width = NULL, sep = ",", pre = NULL, post = NULL,
                         timeFormat = NULL, timezone = NULL, dragRange = TRUE) {
-  validate_slider_value(min, max, value, "sliderInput")
 
-  dataType <- getSliderType(min, max, value)
+  # Force required arguments for maximally informative errors
+  inputId; label; min; max; value
+
+  validate_slider_value(min, max, value, "sliderInput")
+  dataType <- slider_type(value)
 
   if (is.null(timeFormat)) {
     timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
@@ -288,37 +291,45 @@ 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 (!is_slider_type(min) || length(min) != 1 || is_na(min)) {
+    rlang::abort("sliderInput(min) must be a single number, Date, or POSIXct")
+  }
+  if (!is_slider_type(min) || length(max) != 1 || is_na(max)) {
+    rlang::abort("sliderInput(value) must be a single number, Date, or POSIXct")
+  }
+  if (!is_slider_type(value) || !length(value) %in% c(1, 2) || any(is_na(value))) {
+    rlang::abort(
+      "sliderInput(value) must be a single or pair of numbers, Dates, or POSIXcts"
     )
   }
 
-  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 (!identical(class(min), class(value)) || !identical(class(max), class(value))) {
+    rlang::abort(c(
+      "Type mismatch for `min`, `max`, and `value`.",
+      i = "All values must have same type: either numeric, Date, or POSIXt."
+    ))
   }
 
-  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
-      )
-    )
+  if (min(value) < min || max(value) > max) {
+    rlang::abort("`value` does not lie within [min, max]")
   }
 }
 
+is_slider_type <- function(x) {
+  is.numeric(x) || inherits(x, "Date") || inherits(x, "POSIXct")
+}
+slider_type <- function(x) {
+  if (is.numeric(x)) {
+    "number"
+  } else if (inherits(x, "Date")) {
+    "date"
+  } else if (inherits(x, "POSIXct")) {
+    "datetime"
+  }
+}
 
 #' @rdname sliderInput
 #'

R/utils.R

@@ -1751,23 +1751,6 @@ createVarPromiseDomain <- function(env, name, value) {
   )
 }
 
-getSliderType <- function(min, max, value) {
-  vals <- dropNulls(list(value, min, max))
-  if (length(vals) == 0) return("")
-  type <- unique(lapply(vals, function(x) {
-    if      (inherits(x, "Date"))   "date"
-    else if (inherits(x, "POSIXt")) "datetime"
-    else                            "number"
-  }))
-  if (length(type) > 1) {
-    rlang::abort(c(
-      "Type mismatch for `min`, `max`, and `value`.",
-      "All values must either be numeric, Date, or POSIXt."
-    ))
-  }
-  type[[1]]
-}
-
 # Reads the `shiny.sharedSecret` global option, and returns a function that can
 # be used to test header values for a match.
 loadSharedSecret <- function() {

tests/testthat/_snaps/input-slider.md

@@ -0,0 +1,28 @@
+# sliderInput gives informative errors for bad inputs
+
+    Code
+      sliderInput("x", "x")
+    Error <simpleError>
+      argument "min" is missing, with no default
+    Code
+      sliderInput("x", "x", min = NULL, max = 3, value = 2)
+    Error <rlang_error>
+      sliderInput(min) must be a single number, Date, or POSIXct
+    Code
+      sliderInput("x", "x", min = 1, max = NULL, value = 2)
+    Error <rlang_error>
+      sliderInput(value) must be a single number, Date, or POSIXct
+    Code
+      sliderInput("x", "x", min = 1, max = 3, value = NULL)
+    Error <rlang_error>
+      sliderInput(value) must be a single or pair of numbers, Dates, or POSIXcts
+    Code
+      sliderInput("x", "x", min = Sys.Date(), max = Sys.Date(), value = 1)
+    Error <rlang_error>
+      Type mismatch for `min`, `max`, and `value`.
+      i All values must have same type: either numeric, Date, or POSIXt.
+    Code
+      sliderInput("x", "x", min = 1, max = 3, value = 0)
+    Error <rlang_error>
+      `value` does not lie within [min, max]
+

tests/testthat/test-input-slider.R

@@ -4,99 +4,23 @@ test_that("sliderInput steps don't have rounding errors", {
   expect_identical(findStepSize(-5.5, 4, NULL), 0.1)
 })
 
+test_that("sliderInput can use numbers, dates, or POSIXct", {
+  n <- 1
+  d <- Sys.Date()
+  dt <- Sys.time()
 
-
-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_warning(sliderInput('s', 's', x-1,  x+1,  x+2))
-  expect_warning(sliderInput('s', 's', x-1,  x+1,  x-2))
-
-  if (getRversion() >= "4.0") {
-    expect_silent(sliderInput('s', 's', x-1, x+1, c(x-1, x+1)))
-    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)))
-  } else {
-    skip("c() doesn't work sensibly on POSIXlt objects with this version of R")
-  }
-
-
-  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))
+  expect_error(sliderInput("x", "x", n - 1, n + 1, n), NA)
+  expect_error(sliderInput("x", "x", d - 1, d + 1, d), NA)
+  expect_error(sliderInput("x", "x", dt - 1, dt + 1, dt), NA)
+})
+
+test_that("sliderInput gives informative errors for bad inputs", {
+  expect_snapshot(error = TRUE, {
+    sliderInput("x", "x")
+    sliderInput("x", "x", min = NULL, max = 3, value = 2)
+    sliderInput("x", "x", min = 1, max = NULL, value = 2)
+    sliderInput("x", "x", min = 1, max = 3, value = NULL)
+    sliderInput("x", "x", min = Sys.Date(), max = Sys.Date(), value = 1)
+    sliderInput("x", "x", min = 1, max = 3, value = 0)
+  })
 })