slider snaps from edge in RangedFilterState

NEWS.md

@@ -17,6 +17,7 @@
 ### Bug fixes
 
 * Fixed an error where the `RangeFilterState` produced an error when using `bootstrap 4`.
+* Fixed a bug that caused the range slider to omit values selected programmatically through the filter API.
 
 ### Miscellaneous
 

R/FilterState-utils.R

@@ -239,7 +239,7 @@ init_filter_state.POSIXlt <- function(x,
 #' @keywords internal
 #'
 #' @examples
-#' \dontrun{
+#' \donttest{
 #' check_in_range(c(3, 1), c(1, 3))
 #' check_in_range(c(0, 3), c(1, 3))
 #' check_in_range(
@@ -287,13 +287,15 @@ check_in_range <- function(subinterval, range, pre_msg = "") {
 #' @keywords internal
 #'
 #' @examples
-#' check_in_subset <- teal.slice:::check_in_subset
+#' \donttest{
+#' check_in_subset <- check_in_subset
 #' check_in_subset(c("a", "b"), c("a", "b", "c"))
 #' \dontrun{
 #' check_in_subset(c("a", "b"), c("b", "c"), pre_msg = "Error: ")
 #' # truncated because too long
 #' check_in_subset("a", LETTERS, pre_msg = "Error: ")
 #' }
+#' }
 check_in_subset <- function(subset, choices, pre_msg = "") {
   checkmate::assert_string(pre_msg)
 
@@ -310,3 +312,46 @@ check_in_subset <- function(subset, choices, pre_msg = "") {
   }
   return(invisible(NULL))
 }
+
+#' Find containing limits for interval.
+#'
+#' Given an interval and a numeric vector,
+#' find the smallest interval within the numeric vector that contains the interval.
+#'
+#' This is a helper function for `RangeFilterState` that modifies slider selection
+#' so that the _subsetting call_ includes the value specified by the filter API call.
+#'
+#' Regardless of the underlying numeric data, the slider always presents 100 steps.
+#' The ticks on the slider do not represent actual observations but rather borders between virtual bins.
+#' Since the value selected on the slider is passed to `private$selected` and that in turn
+#' updates the slider selection, programmatic selection of arbitrary values may inadvertently shift
+#' the selection to the closest tick, thereby dropping the actual value set (if it exists in the data).
+#'
+#' This function purposely shifts the selection to the closest ticks whose values form an interval
+#' that will contain the interval defined by the filter API call.
+#'
+#' @param x `numeric(2)` interval to contain
+#' @param range `numeric(>=2)` vector of values to contain `x` in
+#'
+#' @return Numeric vector of length 2 that lies within `range`.
+#'
+#' @keywords internal
+#'
+#' @examples
+#' \donttest{
+#' ticks <- 1:10
+#' values1 <- c(3, 5)
+#' contain_interval(values1, ticks)
+#' values2 <- c(3.1, 5.7)
+#' contain_interval(values2, ticks)
+#' values3 <- c(0, 20)
+#' contain_interval(values3, ticks)
+#'}
+contain_interval <- function(x, range) {
+  checkmate::assert_numeric(x, len = 2L, any.missing = FALSE, sorted = TRUE)
+  checkmate::assert_numeric(range, min.len = 2L, any.missing = FALSE, sorted = TRUE)
+
+  x[1] <- Find(function(i) i <= x[1], range, nomatch = min(range), right = TRUE)
+  x[2] <- Find(function(i) i >= x[2], range, nomatch = max(range))
+  x
+}

R/FilterState.R

@@ -2,7 +2,9 @@
 #' @docType class
 #'
 #'
-#' @title Abstract class to encapsulate filter states
+#' @title FilterState Abstract Class
+#'
+#' @description Abstract class to encapsulate filter states
 #'
 #' @details
 #' This class is responsible for managing single filter item within
@@ -281,7 +283,7 @@ FilterState <- R6::R6Class( # nolint
     #' @param value (`vector`)\cr
     #'   value(s) that come from filter selection; values are set in the
     #'   module server after a selection is made in the app interface;
-    #'   values are stored in `private$selected`n which is reactive;
+    #'   values are stored in `private$selected` which is reactive;
     #'   value types have to be the same as `private$choices`
     #'
     #' @return NULL invisibly
@@ -420,11 +422,12 @@ FilterState <- R6::R6Class( # nolint
     varlabel = character(0),
     extract_type = logical(0),
 
-    #' description
-    #' Adds `is.na(varname)` before existing condition calls if `keep_na` is selected.
-    #' Otherwise, if missings are found in the variable `!is.na` will be added
-    #' only if `private$na_rm = TRUE`
-    #' return (`call`)
+    # private methods ----
+    # @description
+    # Adds `is.na(varname)` before existing condition calls if `keep_na` is selected.
+    # Otherwise, if missings are found in the variable `!is.na` will be added
+    # only if `private$na_rm = TRUE`
+    # @return (`call`)
     add_keep_na_call = function(filter_call) {
       if (isTRUE(self$get_keep_na())) {
         call(
@@ -443,14 +446,14 @@ FilterState <- R6::R6Class( # nolint
       }
     },
 
-    #' description
-    #' Prefixed (or not) variable
-    #'
-    #' Return variable name needed to condition call.
-    #' If `isTRUE(private$use_dataset)` variable is prefixed by
-    #' dataname to be evaluated as extracted object, for example
-    #' `data$var`
-    #' return (`name` or `call`)
+    # @description
+    # Prefixed (or not) variable
+    #
+    # Return variable name needed to condition call.
+    # If `isTRUE(private$use_dataset)` variable is prefixed by
+    # dataname to be evaluated as extracted object, for example
+    # `data$var`
+    # @return (`name` or `call`)
     get_varname_prefixed = function() {
       if (isTRUE(private$extract_type == "list")) {
         call_extract_list(private$dataname, private$varname)
@@ -464,20 +467,19 @@ FilterState <- R6::R6Class( # nolint
       }
     },
 
-    #' Sets `keep_na` field according to observed `input$keep_na`
-    #' If `keep_na = TRUE`, `is.na(varname)` is added to the returned call.
-    #' Otherwise returned call excludes `NA` when executed.
+    # Sets `keep_na` field according to observed `input$keep_na`
+    # If `keep_na = TRUE` `is.na(varname)` is added to the returned call.
+    # Otherwise returned call excludes `NA` when executed.
     observe_keep_na = function(input) {
 
     },
 
-    #' Set choices
-    #'
-    #' Set choices is supposed to be executed once in the constructor
-    #' to define set/range which selection is made from.
-    #' parameter choices (`vector`)\cr
-    #'  class of the vector depends on the `FilterState` class.
-    #' return a `NULL`
+    # @description
+    # Set choices is supposed to be executed once in the constructor
+    # to define set/range which selection is made from.
+    # parameter choices (`vector`)\cr
+    #  class of the vector depends on the `FilterState` class.
+    # @return `NULL`
     set_choices = function(choices) {
       private$choices <- choices
       invisible(NULL)
@@ -514,11 +516,11 @@ FilterState <- R6::R6Class( # nolint
     },
 
     # shiny modules -----
-    #' module with inputs
+    # module with inputs
     ui_inputs = function(id) {
       stop("abstract class")
     },
-    #' module with inputs
+    # module with inputs
     server_inputs = function(id) {
       stop("abstract class")
     },
@@ -566,7 +568,7 @@ FilterState <- R6::R6Class( # nolint
           }
         )
         private$observers$keep_na <- observeEvent(
-          ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in the `selectInput`,
+          ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in the `selectInput`
           ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
           eventExpr = input$value,
           handlerExpr = {

R/FilterStateChoices.R

@@ -18,6 +18,9 @@
 ChoicesFilterState <- R6::R6Class( # nolint
   "ChoicesFilterState",
   inherit = FilterState,
+
+  # public methods ----
+
   public = list(
 
     #' @description
@@ -134,8 +137,13 @@ ChoicesFilterState <- R6::R6Class( # nolint
       super$set_selected(value)
     }
   ),
+
+  # private members ----
+
   private = list(
     histogram_data = data.frame(),
+
+    # private methods ----
     validate_selection = function(value) {
       if (!is.character(value)) {
         stop(
@@ -174,6 +182,8 @@ ChoicesFilterState <- R6::R6Class( # nolint
       values[in_choices_mask]
     },
 
+    # shiny modules ----
+
     # @description
     # UI Module for `ChoicesFilterState`.
     # This UI element contains available choices selection and
@@ -185,21 +195,18 @@ ChoicesFilterState <- R6::R6Class( # nolint
       div(
         if (length(private$choices) <= getOption("teal.threshold_slider_vs_checkboxgroup")) {
           l_counts <- as.numeric(names(private$choices))
-          is_na_l_counts <- is.na(l_counts)
-          if (any(is_na_l_counts)) l_counts[is_na_l_counts] <- 0
+          l_counts[is.na(l_counts)] <- 0
+          l_freqs <- l_counts / sum(l_counts)
           labels <- lapply(seq_along(private$choices), function(i) {
-            l_count <- l_counts[i]
-            l_freq <- l_count / sum(l_counts)
-            if (is.na(l_freq) || is.nan(l_freq)) l_freq <- 0
             div(
               class = "choices_state_label",
-              style = sprintf("width:%s%%", l_freq * 100),
+              style = sprintf("width:%s%%", l_freqs[i] * 100),
               span(
                 class = "choices_state_label_text",
                 sprintf(
                   "%s (%s)",
                   private$choices[i],
-                  l_count
+                  l_counts[i]
                 )
               )
             )

R/FilterStateDate.R

@@ -19,6 +19,9 @@
 DateFilterState <- R6::R6Class( # nolint
   "DateFilterState",
   inherit = FilterState,
+
+  # public methods ----
+
   public = list(
 
     #' @description
@@ -63,12 +66,13 @@ DateFilterState <- R6::R6Class( # nolint
     format = function(indent = 0) {
       checkmate::assert_number(indent, finite = TRUE, lower = 0)
 
+      vals <- self$get_selected()
       sprintf(
         "%sFiltering on: %s\n%1$s  Selected range: %s - %s\n%1$s  Include missing values: %s",
         format("", width = indent),
         private$varname,
-        format(self$get_selected()[1], nsmall = 3),
-        format(self$get_selected()[2], nsmall = 3),
+        format(vals[1], nsmall = 3),
+        format(vals[2], nsmall = 3),
         format(self$get_keep_na())
       )
     },
@@ -125,6 +129,9 @@ DateFilterState <- R6::R6Class( # nolint
       super$set_selected(value)
     }
   ),
+
+  # private methods ----
+
   private = list(
     validate_selection = function(value) {
       if (!is(value, "Date")) {
@@ -173,6 +180,8 @@ DateFilterState <- R6::R6Class( # nolint
       values
     },
 
+    # shiny modules ----
+
     # @description
     # UI Module for `DateFilterState`.
     # This UI element contains two date selections for `min` and `max`

R/FilterStateDatettime.R

@@ -19,6 +19,9 @@
 DatetimeFilterState <- R6::R6Class( # nolint
   "DatetimeFilterState",
   inherit = FilterState,
+
+  # public methods ----
+
   public = list(
 
     #' @description
@@ -75,12 +78,15 @@ DatetimeFilterState <- R6::R6Class( # nolint
     #'
     format = function(indent = 0) {
       checkmate::assert_number(indent, finite = TRUE, lower = 0)
+
+
+      vals <- self$get_selected()
       sprintf(
         "%sFiltering on: %s\n%1$s  Selected range: %s - %s\n%1$s  Include missing values: %s",
         format("", width = indent),
         private$varname,
-        format(self$get_selected(), nsmall = 3)[1],
-        format(self$get_selected(), nsmall = 3)[2],
+        format(vals[1], nsmall = 3),
+        format(vals[2], nsmall = 3),
         format(self$get_keep_na())
       )
     },
@@ -137,8 +143,14 @@ DatetimeFilterState <- R6::R6Class( # nolint
       super$set_selected(value)
     }
   ),
+
+  # private fields ----
+
   private = list(
     timezone = Sys.timezone(),
+
+    # private methods ----
+
     validate_selection = function(value) {
       if (!(is(value, "POSIXct") || is(value, "POSIXlt"))) {
         stop(
@@ -187,6 +199,8 @@ DatetimeFilterState <- R6::R6Class( # nolint
       values
     },
 
+    # shiny modules ----
+
     # @description
     # UI Module for `DatetimeFilterState`.
     # This UI element contains two date-time selections for `min` and `max`