fix: simplified changes during the call and fixed tests

insightsengineering · Oct 28, 2024 · 118fc93 · 118fc93
1 parent 54528bb
commit 118fc93
Show file tree

Hide file tree

Showing 3 changed files with 75 additions and 82 deletions.
diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R
@@ -24,22 +24,7 @@ toggle_slider_ui <- function(id, label) {
       tags$span(tags$strong(label)),
       tags$div(actionButton(ns("toggle"), "Toggle", class = "btn-xs"))
     ),
-    uiOutput(ns("slider_view")),
-    shinyjs::hidden(
-      tags$div(
-        id = ns("numeric_view"),
-        numericInput(
-          ns("value_low"),
-          "From:",
-          value = 0
-        ),
-        numericInput(
-          ns("value_high"),
-          "- to:",
-          value = 0
-        )
-      )
-    )
+    uiOutput(ns("inputs"))
   )
 }
 
@@ -52,36 +37,33 @@ toggle_slider_server <- function(id, ...) {
       max = NULL,
       value = NULL,
       step = NULL,
-      slider = NULL,
       data_range = NULL
     )
     slider_shown <- reactive(input$toggle %% 2 == 0)
 
     observeEvent(state$data_range, {
-      cat("state$date_range changed\n")
       state$min <- state$data_range[1]
       state$max <- state$data_range[2]
       state$value <- state$data_range
-      state$step <- NULL # TODO
     })
 
-    output$slider_view <- renderUI({
-      cat("renderUI triggered\n")
+    output$inputs <- renderUI({
       req(state$value)
-      tags$div(
-        class = "teal-goshawk toggle-slider-container",
-        sliderInput(
-          inputId = session$ns("slider"),
-          label = NULL,
-          min = min(state$data_range[1], state$min),
-          max = max(state$data_range[2], state$max),
-          value = state$value,
-          step = state$step,
-          ticks = TRUE,
-          ...
-        ),
-        tags$script(HTML(sprintf(
-          '
+      if (slider_shown()) {
+        tags$div(
+          class = "teal-goshawk toggle-slider-container",
+          sliderInput(
+            inputId = session$ns("slider"),
+            label = NULL,
+            min = min(state$data_range[1], state$min),
+            max = max(state$data_range[2], state$max),
+            value = state$value,
+            step = state$step,
+            ticks = TRUE,
+            ...
+          ),
+          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"
@@ -99,34 +81,43 @@ toggle_slider_server <- function(id, ...) {
             }
           });
         ',
-          session$ns("slider")
-        )))
-      )
-    })
-
-    observeEvent(input$toggle, {
-      shinyjs::toggle("slider_view", condition = slider_shown())
-      shinyjs::toggle("numeric_view", condition = !slider_shown())
+            session$ns("slider")
+          )))
+        )
+      } else {
+        tags$div(
+          class = "teal-goshawk toggle-slider-container",
+          numericInput(
+            inputId = session$ns("value_low"),
+            label = "From:",
+            value = state$value[1]
+          ),
+          numericInput(
+            inputId = session$ns("value_high"),
+            label = "to:",
+            value = state$value[2]
+          )
+        )
+      }
     })
 
-    observeEvent(input$slider, {
-      state$value <- input$slider
-    })
+    d_slider <- debounce(reactive(input$slider), 500)
 
-    observeEvent(state$value, { # todo: change to state$value
-      cat("state$value changed\n")
-      if (!setequal(state$value, c(input$value_low, input$value_high))) {
-        cat("state differs from input updating numeric input\n")
-        updateNumericInput(session, "value_low", value = state$value[1])
-        updateNumericInput(session, "value_high", value = state$value[2])
+    observeEvent(d_slider(), {
+      if (!setequal(state$value, d_slider())) {
+        state$value <- d_slider()
       }
     })
 
-    observeEvent(c(input$value_low, input$value_high), ignoreInit = TRUE, {
-      cat("input$numeric changed - updating state value\n")
+    d_value_low <- debounce(reactive(input$value_low), 500)
+    d_value_high <- debounce(reactive(input$value_high), 500)
+
+    observeEvent(c(d_value_low(), d_value_high()), ignoreInit = TRUE, {
       values <- c(input$value_low, input$value_high)
-      if (all(!is.na(values))) {
+      if (!setequal(state$value, values)) {
         state$value <- values
+        state$min <- values[1]
+        state$max <- values[2]
       }
     })
 
@@ -156,5 +147,6 @@ keep_slider_state_updated <- function(state, varname, paramname, ANL, trt_group
     step <- round(dmax / 100, 5)
   }
   state$data_range <- c(min = minmax[[1]], max = minmax[[2]])
-  state
+  state$step <- step
+  invisible(NULL)
 }
diff --git a/tests/testthat/helper-toggle-slider-utils.R b/tests/testthat/helper-toggle-slider-utils.R
@@ -4,7 +4,7 @@ click_toggle_button <- function(app) {
 
 #' Extract the values and the ranges from the UI for the slider
 get_ui_slider_values <- function(app) {
-  id <- NS(app$active_ns()$module, "yrange_scale-slider_view")
+  id <- NS(app$active_ns()$module, "yrange_scale-inputs")
   # Note that the values can only be observed once they are visible
   if (!is_slider_visible(app)) {
     click_toggle_button(app)
@@ -19,14 +19,16 @@ get_ui_slider_values <- function(app) {
   )
 }
 
-#' Checking if the sliderInput and the numericInputs match
-check_if_widgets_match <- function(app) {
-  testthat::expect_identical(
-    app$get_active_module_input("yrange_scale-slider"),
-    c(
-      app$get_active_module_input("yrange_scale-value_low"),
-      app$get_active_module_input("yrange_scale-value_high")
-    )
+#' Extract the values and the ranges from the numeric widgets
+get_numeric_values <- function(app) {
+  id <- NS(app$active_ns()$module, "yrange_scale-inputs")
+  # Note that the values can only be observed once they are visible
+  if (is_slider_visible(app)) {
+    click_toggle_button(app)
+  }
+  c(
+    app$get_active_module_input("yrange_scale-value_low"),
+    app$get_active_module_input("yrange_scale-value_high")
   )
 }
 
@@ -38,14 +40,11 @@ check_widgets_with_value <- function(app, values) {
   checkmate::assert_names(names(values), must.include = c("min", "max", "value"))
   checkmate::assert_numeric(values$value, len = 2)
   slider_values <- get_ui_slider_values(app)
+  numeric_values <- get_numeric_values(app)
   testthat::expect_identical(slider_values, values)
-  testthat::expect_identical(
-    app$get_active_module_input("yrange_scale-value_low"),
-    as.integer(values$value[1])
-  )
-  testthat::expect_identical(
-    app$get_active_module_input("yrange_scale-value_high"),
-    as.integer(values$value[2])
+  testthat::expect_setequal(
+    numeric_values,
+    values$value
   )
 }
 
@@ -61,8 +60,8 @@ set_slider_values <- function(app, values) {
   if (!is_slider_visible(app)) {
     click_toggle_button(app)
   }
-  app$set_input(
-    NS(app$active_ns()$module, "yrange_scale-slider"),
+  app$set_active_module_input(
+    "yrange_scale-slider",
     values,
     wait_ = FALSE
   )
@@ -76,13 +75,13 @@ set_numeric_input_values <- function(app, values) {
   if (is_slider_visible(app)) {
     click_toggle_button(app)
   }
-  app$set_input(
-    NS(app$active_ns()$module, "yrange_scale-value_low"),
+  app$set_active_module_input(
+    "yrange_scale-value_low",
     values[1],
     wait_ = FALSE
   )
-  app$set_input(
-    NS(app$active_ns()$module, "yrange_scale-value_high"),
+  app$set_active_module_input(
+    "yrange_scale-value_high",
     values[2],
     wait_ = FALSE
   )

diff --git a/tests/testthat/test-shinytest2-tm_g_gh_boxplot.R b/tests/testthat/test-shinytest2-tm_g_gh_boxplot.R
@@ -19,18 +19,20 @@ app_driver <- init_teal_app_driver(
   )
 )
 
+app_driver$view()
 testthat::test_that("toggle_slider_module: widgets are initialized with proper values", {
   app_driver$click(selector = ".well .panel-group > div:first-of-type > .panel > .panel-heading")
   init_values <- list(min = 0, max = 55, value = c(0, 55))
-  check_if_widgets_match(app_driver)
   check_widgets_with_value(app_driver, init_values)
 })
 
 
 testthat::test_that("toggle_slider_module: changing the sliderInput sets proper numericInput values", {
-  new_value <- c(12, 50)
-  set_slider_values(app_driver, new_value)
-  check_if_widgets_match(app_driver)
+  set_slider_values(app_driver, c(1, 50))
+  check_widgets_with_value(
+    app_driver,
+    list(min = 0, max = 55, value = c(1, 50))
+  )
 })
 
 testthat::test_that(