diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 4773423b..814e7a2d 100644 --- 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 index ffac8db4..b893a02f 100644 --- 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 index 92020a1b..93d11b17 100644 --- 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(