From 8182ce70f6a775ea3a78c610033f8d23065f4962 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 28 Oct 2024 19:20:50 +0530 Subject: [PATCH] feat: pass the data states as a reactive --- R/tm_g_gh_boxplot.R | 7 +- R/tm_g_gh_correlationplot.R | 15 ++--- R/tm_g_gh_density_distribution_plot.R | 15 ++--- R/tm_g_gh_lineplot.R | 16 ++--- R/tm_g_gh_scatterplot.R | 15 ++--- R/tm_g_gh_spaghettiplot.R | 7 +- R/toggleable_slider.R | 64 +++++++++---------- .../test-shinytest2-tm_g_gh_boxplot.R | 2 - 8 files changed, 62 insertions(+), 79 deletions(-) diff --git a/R/tm_g_gh_boxplot.R b/R/tm_g_gh_boxplot.R index b8f6b60b..7f95d04b 100644 --- a/R/tm_g_gh_boxplot.R +++ b/R/tm_g_gh_boxplot.R @@ -339,15 +339,14 @@ srv_g_boxplot <- function(id, anl_q <- anl_q_output()$value # update sliders for axes taking constraints into account - yrange_slider_state <- toggle_slider_server("yrange_scale") - observe({ - keep_slider_state_updated( - state = yrange_slider_state, + data_state <- reactive({ + get_data_range_states( varname = input$yaxis_var, paramname = input$xaxis_param, ANL = anl_q()$ANL ) }) + yrange_slider_state <- toggle_slider_server("yrange_scale", data_state) keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") horizontal_line <- srv_arbitrary_lines("hline_arb") diff --git a/R/tm_g_gh_correlationplot.R b/R/tm_g_gh_correlationplot.R index 74397a26..36f15f0b 100644 --- a/R/tm_g_gh_correlationplot.R +++ b/R/tm_g_gh_correlationplot.R @@ -597,25 +597,22 @@ srv_g_correlationplot <- function(id, anl_constraint <- anl_constraint_output()$value # update sliders for axes taking constraints into account - xrange_slider <- toggle_slider_server("xrange_scale") - yrange_slider <- toggle_slider_server("yrange_scale") - - observe({ - keep_slider_state_updated( - state = xrange_slider, + data_state_x <- reactive({ + get_data_range_states( varname = input$xaxis_var, paramname = input$xaxis_param, ANL = anl_constraint()$ANL ) }) - observe({ - keep_slider_state_updated( - state = yrange_slider, + xrange_slider <- toggle_slider_server("xrange_scale", data_state_x) + data_state_y <- reactive({ + get_data_range_states( varname = input$yaxis_var, paramname = input$yaxis_param, ANL = anl_constraint()$ANL ) }) + yrange_slider <- toggle_slider_server("yrange_scale", data_state_y) keep_data_const_opts_updated(session, input, anl_constraint, "xaxis_param") diff --git a/R/tm_g_gh_density_distribution_plot.R b/R/tm_g_gh_density_distribution_plot.R index 18aa935b..1227bca6 100644 --- a/R/tm_g_gh_density_distribution_plot.R +++ b/R/tm_g_gh_density_distribution_plot.R @@ -281,26 +281,23 @@ srv_g_density_distribution_plot <- function(id, # nolint anl_q <- anl_q_output()$value # update sliders for axes taking constraints into account - xrange_slider <- toggle_slider_server("xrange_scale") - yrange_slider <- toggle_slider_server("yrange_scale") - - observe({ - keep_slider_state_updated( - state = xrange_slider, + data_state_x <- reactive({ + get_data_range_states( varname = input$xaxis_var, paramname = input$xaxis_param, ANL = anl_q()$ANL ) }) - observe({ - keep_slider_state_updated( - state = yrange_slider, + xrange_slider <- toggle_slider_server("xrange_scale", data_state_x) + data_state_y <- reactive({ + get_data_range_states( varname = input$xaxis_var, paramname = input$xaxis_param, ANL = anl_q()$ANL, trt_group = "trt_group" ) }) + yrange_slider <- toggle_slider_server("yrange_scale", data_state_y) keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") diff --git a/R/tm_g_gh_lineplot.R b/R/tm_g_gh_lineplot.R index ea933a24..044419ed 100644 --- a/R/tm_g_gh_lineplot.R +++ b/R/tm_g_gh_lineplot.R @@ -401,8 +401,6 @@ srv_lineplot <- function(id, keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") - yrange_slider <- toggle_slider_server("yrange_scale") - horizontal_line <- srv_arbitrary_lines("hline_arb") iv_r <- reactive({ @@ -420,7 +418,7 @@ srv_lineplot <- function(id, # update sliders for axes - observe({ + data_state <- reactive({ varname <- input[["yaxis_var"]] validate(need(varname, "Please select variable")) @@ -433,7 +431,7 @@ srv_lineplot <- function(id, NULL } - # we don't need to additionally filter for paramvar here as in keep_slider_state_updated because + # we don't need to additionally filter for paramvar here as in get_data_range_states because # xaxis_var and yaxis_var are always distinct sum_data <- ANL %>% dplyr::group_by_at(c(input$xaxis_var, input$trt_group, shape)) %>% @@ -460,16 +458,14 @@ srv_lineplot <- function(id, f = 0.05 ) - # we don't use keep_slider_state_updated because this module computes the min, max + # we don't use get_data_range_states because this module computes the data ranges # not from the constrained ANL, but rather by first grouping and computing confidence # intervals - yrange_slider$slider <- list( - min = minmax[[1]], - max = minmax[[2]], - value = minmax + list( + range = c(min = minmax[[1]], max = minmax[[2]]) ) - yrange_slider$data_range <- list(min = minmax[[1]], max = minmax[[2]]) }) + yrange_slider <- toggle_slider_server("yrange_scale", data_state) line_color_defaults <- color_manual line_type_defaults <- c( diff --git a/R/tm_g_gh_scatterplot.R b/R/tm_g_gh_scatterplot.R index ecfd63c3..da82442f 100644 --- a/R/tm_g_gh_scatterplot.R +++ b/R/tm_g_gh_scatterplot.R @@ -286,25 +286,22 @@ srv_g_scatterplot <- function(id, anl_q <- anl_q_output()$value # update sliders for axes taking constraints into account - xrange_slider <- toggle_slider_server("xrange_scale") - yrange_slider <- toggle_slider_server("yrange_scale") - - observe({ - keep_slider_state_updated( - state = xrange_slider, + data_state_x <- reactive({ + get_data_range_states( varname = input$xaxis_var, paramname = input$xaxis_param, ANL = anl_q()$ANL ) }) - observe({ - keep_slider_state_updated( - state = yrange_slider, + xrange_slider <- toggle_slider_server("xrange_scale", data_state_x) + data_state_y <- reactive({ + get_data_range_states( varname = input$yaxis_var, paramname = input$xaxis_param, ANL = anl_q()$ANL ) }) + yrange_slider <- toggle_slider_server("yrange_scale", data_state_y) keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") diff --git a/R/tm_g_gh_spaghettiplot.R b/R/tm_g_gh_spaghettiplot.R index 64dfd95c..48379ef8 100644 --- a/R/tm_g_gh_spaghettiplot.R +++ b/R/tm_g_gh_spaghettiplot.R @@ -396,15 +396,14 @@ srv_g_spaghettiplot <- function(id, anl_q <- anl_q_output()$value # update sliders for axes taking constraints into account - yrange_slider <- toggle_slider_server("yrange_scale") - observe({ - keep_slider_state_updated( - state = yrange_slider, + data_state <- reactive({ + get_data_range_states( varname = input$yaxis_var, paramname = input$xaxis_param, ANL = anl_q()$ANL ) }) + yrange_slider <- toggle_slider_server("yrange_scale", data_state) keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") horizontal_line <- srv_arbitrary_lines("hline_arb") diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 814e7a2d..c946dc3b 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -30,21 +30,19 @@ toggle_slider_ui <- function(id, label) { #' @keywords internal #' @rdname toggle_slider -toggle_slider_server <- function(id, ...) { +toggle_slider_server <- function(id, data_state, ...) { moduleServer(id, function(input, output, session) { state <- reactiveValues( min = NULL, max = NULL, - value = NULL, - step = NULL, - data_range = NULL + value = NULL ) slider_shown <- reactive(input$toggle %% 2 == 0) - observeEvent(state$data_range, { - state$min <- state$data_range[1] - state$max <- state$data_range[2] - state$value <- state$data_range + observeEvent(data_state()$range, { + state$min <- data_state()$range[1] + state$max <- data_state()$range[2] + state$value <- data_state()$range }) output$inputs <- renderUI({ @@ -55,32 +53,32 @@ toggle_slider_server <- function(id, ...) { sliderInput( inputId = session$ns("slider"), label = NULL, - min = min(state$data_range[1], state$min), - max = max(state$data_range[2], state$max), + min = min(data_state()$range[1], state$min), + max = max(data_state()$range[2], state$max), value = state$value, - step = state$step, + step = data_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" - ); - 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."); - } - }); - ', + $(".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") ))) ) @@ -127,10 +125,11 @@ toggle_slider_server <- function(id, ...) { #' @keywords internal #' @rdname toggle_slider -keep_slider_state_updated <- function(state, varname, paramname, ANL, trt_group = NULL, step = NULL) { # nolint object_name_linter +get_data_range_states <- function(varname, paramname, ANL, trt_group = NULL, step = NULL) { # nolint object_name_linter validate(need(varname, "Please select variable")) validate(need(paramname, "Please select variable")) req(length(paramname) == 1) + step <- NULL ANL <- ANL %>% dplyr::filter(.data$PARAMCD == paramname) # nolint object_name_linter validate_has_variable(ANL, varname, paste("variable", varname, "does not exist")) @@ -146,7 +145,8 @@ keep_slider_state_updated <- function(state, varname, paramname, ANL, trt_group minmax <- c(0, round(dmax * 1.2, 5)) step <- round(dmax / 100, 5) } - state$data_range <- c(min = minmax[[1]], max = minmax[[2]]) - state$step <- step - invisible(NULL) + list( + range = c(min = minmax[[1]], max = minmax[[2]]), + step = step + ) } diff --git a/tests/testthat/test-shinytest2-tm_g_gh_boxplot.R b/tests/testthat/test-shinytest2-tm_g_gh_boxplot.R index 93d11b17..4fdcdb3f 100644 --- a/tests/testthat/test-shinytest2-tm_g_gh_boxplot.R +++ b/tests/testthat/test-shinytest2-tm_g_gh_boxplot.R @@ -19,14 +19,12 @@ 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_widgets_with_value(app_driver, init_values) }) - testthat::test_that("toggle_slider_module: changing the sliderInput sets proper numericInput values", { set_slider_values(app_driver, c(1, 50)) check_widgets_with_value(