Custom rendering to provide manual ticks when there is <10 ticks

R/toggleable_slider.R

@@ -17,13 +17,8 @@
 #'   length 2 for dichotomous slider.
 #' @param slider_initially `logical` whether to show slider or numeric fields
 #'   initially
-#' @param step_slider `numeric or integer` step for slider
 #' @param step_numeric `numeric or integer` step for numeric input fields
 #' @param width `numeric` width of slider or of each numeric field
-#' @param ... additional parameters to pass to `sliderInput`
-#'
-#' @return Shiny HTML UI
-#' @keywords internal
 #'
 #' @examples
 #' value <- c(20.3, 81.5) # dichotomous slider
@@ -37,15 +32,16 @@
 #'   toggle_slider_ui(
 #'     "toggle_slider", "Select value",
 #'     min = 0.2, max = 100.1, value = value,
-#'     slider_initially = FALSE, step_slider = 0.1, step_numeric = 0.001
+#'     slider_initially = FALSE, step_numeric = 0.001
 #'   ),
 #'   verbatimTextOutput("value")
 #' )
 #'
 #' server <- function(input, output, session) {
 #'   is_dichotomous_slider <- (length(value) == 2)
 #'   range_value <- toggle_slider_server("toggle_slider",
-#'     is_dichotomous_slider = is_dichotomous_slider
+#'     is_dichotomous_slider = is_dichotomous_slider,
+#'     step_slider = 0.1
 #'   )
 #'   messages <- reactiveVal() # to keep history
 #'   observeEvent(range_value$state(), {
@@ -60,6 +56,14 @@
 #' if (interactive()) {
 #'   shinyApp(ui, server)
 #' }
+#' @name toggle_sidebar
+#' @rdname toggle_sidebar
+#' @keywords internal
+#' @return `NULL`.
+NULL
+
+
+#' @rdname toggle_sidebar
 toggle_slider_ui <- function(id,
                              label,
                              min,
@@ -91,16 +95,7 @@ toggle_slider_ui <- function(id,
       actionButton(ns("toggle"), "Toggle", class = "btn-xs")
     ),
     show_or_not(slider_initially)(
-      sliderInput(
-        ns("slider"),
-        label = NULL,
-        min = min,
-        max = max,
-        value = value,
-        step = step_slider,
-        width = width,
-        ...
-      )
+      uiOutput(ns("slider_ui"))
     ),
     show_or_not(!slider_initially)(tags$span(
       id = ns("numeric_view"),
@@ -140,13 +135,18 @@ toggle_slider_ui <- function(id,
   )
 }
 
-# is_dichotomous_slider `logical` whether it is a dichotomous slider or normal slider
-toggle_slider_server <- function(id, is_dichotomous_slider = TRUE) {
+#' @param is_dichotomous_slider `logical` whether it is a dichotomous slider or normal slider
+#' @param step_slider `numeric or integer` step for slider
+#' @param ... additional parameters to pass to `sliderInput`
+#' @keywords internal
+#' @rdname toggle_slider
+toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = NULL, ...) {
   moduleServer(id, function(input, output, session) {
     checkmate::assert_flag(is_dichotomous_slider)
     # model view controller: cur_state is the model, the sliderInput and numericInputs are two views/controllers
     # additionally, the module returns the cur_state, so it can be controlled from that end as well
     cur_state <- reactiveVal(NULL) # model, can contain min, max, value etc.
+    slider_range <- reactiveVal(NULL)
 
 
     iv_r <- reactive({
@@ -177,8 +177,11 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE) {
 
       # only update provided components, do not discasrd others
       old_state <- cur_state()
-      new_state <- c(new_state, old_state[!names(old_state) %in% names(new_state)])
-      new_state <- new_state[sort(names(new_state))]
+      if (is.null(old_state)) {
+        old_state <- new_state
+      }
+      new_state <- utils::modifyList(old_state, new_state)
+
       if (!setequal(new_state, cur_state())) {
         cur_state(new_state)
       }
@@ -204,41 +207,98 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE) {
       }
     )
 
-    update_widgets <- function() {
+    slider_states <- reactive({
       state_slider <- cur_state()
       req(length(state_slider) > 0) # update will otherwise not work
       state_low <- state_slider
       state_high <- state_slider
-      if (!is.null(state_slider$value) && (length(state_slider$value) > 1)) {
+      if (length(state_slider$value) > 1) {
         state_low$value <- state_low$value[[1]]
         state_high$value <- state_high$value[[2]]
       }
-      if (input$toggle %% 2 == 0) {
-        if (input$toggle > 0) {
-          state_slider$max <- max(state_slider$max, state_slider$value[2])
-          state_slider$min <- min(state_slider$min, state_slider$value[1])
-        }
-        do.call(updateSliderInput, c(list(session, "slider"), state_slider))
-      } else {
-        if (length(state_slider$value) > 1) {
-          do.call(updateNumericInput, c(list(session, "value_low"), state_low))
-          do.call(updateNumericInput, c(list(session, "value_high"), state_high))
+      state_slider$max <- max(state_slider$max, state_slider$value[2])
+      state_slider$min <- min(state_slider$min, state_slider$value[1])
+      list(
+        low = state_low,
+        high = state_high,
+        low_value = state_low$value,
+        high_value = state_high$value,
+        slider_value = state_slider$value,
+        slider_max = state_slider$max,
+        slider_min = state_slider$min
+      )
+    })
+
+    update_widgets <- function() {
+      state <- slider_states()
+      if (input$toggle %% 2 != 0) {
+        if (length(state$slider_value) > 1) {
+          do.call(updateNumericInput, c(list(session, "value_low"), state$low))
+          do.call(updateNumericInput, c(list(session, "value_high"), state$high))
         } else {
-          do.call(updateNumericInput, c(list(session, "value"), state_low))
+          do.call(updateNumericInput, c(list(session, "value"), state$low))
         }
       }
     }
     observeEvent(input$toggle, {
       update_widgets()
       shinyjs::toggle("numeric_view")
-      shinyjs::toggle("slider")
+      shinyjs::toggle("slider_ui")
+    })
+
+
+    output$slider_ui <- renderUI({
+      req(input$toggle >= 0)
+      req(slider_range())
+      state <- isolate(slider_states())
+      args <- list(
+        inputId = session$ns("slider"),
+        label = NULL,
+        min = state$slider_min,
+        max = state$slider_max,
+        value = state$slider_value,
+        step = step_slider,
+        ...
+      )
+      if (length(seq(state$slider_min, state$slider_max)) < 10) {
+        args$ticks <- TRUE
+        html <- do.call("sliderInput", args)
+      } else {
+        html <- do.call("sliderInput", args)
+      }
+      tags$div(
+        class = "teal-goshawk toggle-slider-container",
+        html,
+        tags$script(HTML(sprintf(
+          '
+          $(".teal-goshawk.toggle-slider-container #%s").ready(function () {
+            var tickLabel = document.querySelector(
+              ".teal-goshawk.toggle-slider-container .irs-grid-text.js-grid-text-9"
+            );
+            var tick = document.querySelector(
+              ".teal-goshawk.toggle-slider-container .irs-grid-pol:nth-last-child(6)"
+            );
+            if (tickLabel) {
+              if (parseFloat(tickLabel.style.left) > 95) {
+                tickLabel.style.opacity = "0";
+                tick.style.opacity = "0";
+              }
+            } else {
+              console.log("Toggle slider element not found.");
+            }
+          });
+        ',
+          session$ns("slider")
+        )))
+      )
     })
 
     update_toggle_slider <- function(value = NULL, min = NULL, max = NULL, step = NULL) {
       if (!is.null(value) && is_dichotomous_slider) {
         stopifnot(length(value) == 2)
       }
       set_state(Filter(Negate(is.null), list(value = value, min = min, max = max, step = step)))
+      slider_range(list(value = value, min = min, max = max, step = step))
       update_widgets()
     }
     return(list(