From d8e3548985131c4355cd51c9907fb37c09625b7c Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 10 Oct 2024 17:38:02 +0530 Subject: [PATCH 01/15] feat: custom rendering to provide manual ticks when there is <10 ticks --- R/toggleable_slider.R | 81 +++++++++++++++++++++++++++++------------ man/toggle_slider_ui.Rd | 9 ++--- 2 files changed, 61 insertions(+), 29 deletions(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 2a02ae0b..94f529b0 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -17,10 +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 @@ -37,7 +35,7 @@ #' 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") #' ) @@ -45,7 +43,8 @@ #' 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(), { @@ -91,16 +90,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,8 +130,11 @@ toggle_slider_ui <- function(id, ) } +#' @param step_slider `numeric or integer` step for slider +#' @param ... additional parameters to pass to `sliderInput` +#' @keywords internal # is_dichotomous_slider `logical` whether it is a dichotomous slider or normal slider -toggle_slider_server <- function(id, is_dichotomous_slider = TRUE) { +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 @@ -213,13 +206,7 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE) { 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 (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)) @@ -231,7 +218,55 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE) { observeEvent(input$toggle, { update_widgets() shinyjs::toggle("numeric_view") - shinyjs::toggle("slider") + shinyjs::toggle("slider_ui") + }) + + output$slider_ui <- renderUI({ + state_slider <- cur_state() + req(length(state_slider) > 0) + state_low <- state_slider + state_high <- state_slider + if (!is.null(state_slider$value) && (length(state_slider$value) > 1)) { + state_low$value <- state_low$value[[1]] + state_high$value <- state_high$value[[2]] + } + if (input$toggle %% 2 == 0) { + state_slider$max <- max(state_slider$max, state_slider$value[2]) + state_slider$min <- min(state_slider$min, state_slider$value[1]) + } + if (length(seq(state_slider$min, state_slider$max)) < 10) { + ticks <- seq(state_slider$min, state_slider$max) + values <- c( + which(ticks == state_low$value) - 1, + which(ticks == state_high$value) - 1 + ) + args <- list( + inputId = "slider", + label = NULL, + min = state_slider$min, + max = state_slider$max, + value = values, + ticks = ticks, + step = step_slider, + ... + ) + ticks <- paste0(args$ticks, collapse = ",") + args$ticks <- TRUE + html <- do.call("sliderInput", args) + html$children[[2]]$attribs[["data-values"]] <- ticks + } else { + args <- list( + inputId = "slider", + label = NULL, + min = state_slider$min, + max = state_slider$max, + value = c(state_slider$min, state_slider$max), + step = step_slider, + ... + ) + html <- do.call("sliderInput", args) + } + html }) update_toggle_slider <- function(value = NULL, min = NULL, max = NULL, step = NULL) { diff --git a/man/toggle_slider_ui.Rd b/man/toggle_slider_ui.Rd index cdea0433..db2c67dd 100644 --- a/man/toggle_slider_ui.Rd +++ b/man/toggle_slider_ui.Rd @@ -32,13 +32,9 @@ length 2 for dichotomous slider.} \item{slider_initially}{\code{logical} whether to show slider or numeric fields initially} -\item{step_slider}{\verb{numeric or integer} step for slider} - \item{step_numeric}{\verb{numeric or integer} step for numeric input fields} \item{width}{\code{numeric} width of slider or of each numeric field} - -\item{...}{additional parameters to pass to \code{sliderInput}} } \value{ Shiny HTML UI @@ -65,7 +61,7 @@ ui <- div( 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") ) @@ -73,7 +69,8 @@ ui <- div( 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(), { From 6468f33a82b7ce61d4b5d7e7eb3cc782dff14b5d Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 10 Oct 2024 17:54:26 +0530 Subject: [PATCH 02/15] chore: update docs --- R/toggleable_slider.R | 14 ++++++++++---- man/{toggle_slider_ui.Rd => toggle_sidebar.Rd} | 5 +++-- 2 files changed, 13 insertions(+), 6 deletions(-) rename man/{toggle_slider_ui.Rd => toggle_sidebar.Rd} (97%) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 94f529b0..78c6694e 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -20,9 +20,6 @@ #' @param step_numeric `numeric or integer` step for numeric input fields #' @param width `numeric` width of slider or of each numeric field #' -#' @return Shiny HTML UI -#' @keywords internal -#' #' @examples #' value <- c(20.3, 81.5) # dichotomous slider #' # value <- c(50.1) # normal slider @@ -59,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, @@ -130,10 +135,11 @@ toggle_slider_ui <- function(id, ) } +#' @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 -# is_dichotomous_slider `logical` whether it is a dichotomous slider or normal slider +#' @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) diff --git a/man/toggle_slider_ui.Rd b/man/toggle_sidebar.Rd similarity index 97% rename from man/toggle_slider_ui.Rd rename to man/toggle_sidebar.Rd index db2c67dd..29774db7 100644 --- a/man/toggle_slider_ui.Rd +++ b/man/toggle_sidebar.Rd @@ -1,6 +1,7 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/toggleable_slider.R -\name{toggle_slider_ui} +\name{toggle_sidebar} +\alias{toggle_sidebar} \alias{toggle_slider_ui} \title{UI with a toggleable slider to change between slider and numeric input fields} \usage{ @@ -37,7 +38,7 @@ initially} \item{width}{\code{numeric} width of slider or of each numeric field} } \value{ -Shiny HTML UI +\code{NULL}. } \description{ This is useful when a slider should be shown, but it is sometimes hard to configure sliders, From 754ac20ae79335c473c40f4c91b45ee713c3d195 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 10 Oct 2024 18:21:49 +0530 Subject: [PATCH 03/15] chore: simplify slider states logic --- R/toggleable_slider.R | 61 ++++++++++++++++++++++++------------------- 1 file changed, 34 insertions(+), 27 deletions(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 78c6694e..c86266b6 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -203,7 +203,7 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = } ) - update_widgets <- function() { + slider_states <- reactive({ state_slider <- cur_state() req(length(state_slider) > 0) # update will otherwise not work state_low <- state_slider @@ -212,12 +212,29 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = state_low$value <- state_low$value[[1]] state_high$value <- state_high$value[[2]] } + if (input$toggle %% 2 == 0) { + 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)) + 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)) } } } @@ -228,29 +245,19 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = }) output$slider_ui <- renderUI({ - state_slider <- cur_state() - req(length(state_slider) > 0) - state_low <- state_slider - state_high <- state_slider - if (!is.null(state_slider$value) && (length(state_slider$value) > 1)) { - state_low$value <- state_low$value[[1]] - state_high$value <- state_high$value[[2]] - } - if (input$toggle %% 2 == 0) { - state_slider$max <- max(state_slider$max, state_slider$value[2]) - state_slider$min <- min(state_slider$min, state_slider$value[1]) - } - if (length(seq(state_slider$min, state_slider$max)) < 10) { - ticks <- seq(state_slider$min, state_slider$max) + state <- slider_states() + if (length(seq(state$slider_min, state$slider_max)) < 10) { + # The values should be index reference instead of actual values because of how we are calling the `sliderInput` + ticks <- seq(state$slider_min, state$slider_max) values <- c( - which(ticks == state_low$value) - 1, - which(ticks == state_high$value) - 1 + which(ticks == state$low_value) - 1, + which(ticks == state$high_value) - 1 ) args <- list( inputId = "slider", label = NULL, - min = state_slider$min, - max = state_slider$max, + min = state$slider_min, + max = state$slider_max, value = values, ticks = ticks, step = step_slider, @@ -258,15 +265,15 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = ) ticks <- paste0(args$ticks, collapse = ",") args$ticks <- TRUE - html <- do.call("sliderInput", args) + html <- suppressWarnings(do.call("sliderInput", args)) html$children[[2]]$attribs[["data-values"]] <- ticks } else { args <- list( inputId = "slider", label = NULL, - min = state_slider$min, - max = state_slider$max, - value = c(state_slider$min, state_slider$max), + min = state$slider_min, + max = state$slider_max, + value = c(state$slider_min, state$slider_max), step = step_slider, ... ) From 28e08afdd4d3e84f98a23451e1ddd0e3e43b7eb2 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 10 Oct 2024 18:56:32 +0530 Subject: [PATCH 04/15] fix: make the slider work + fix recursive auto update --- R/toggleable_slider.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index c86266b6..83d3f5dc 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -245,7 +245,8 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = }) output$slider_ui <- renderUI({ - state <- slider_states() + req(input$toggle >= 0) + state <- isolate(slider_states()) if (length(seq(state$slider_min, state$slider_max)) < 10) { # The values should be index reference instead of actual values because of how we are calling the `sliderInput` ticks <- seq(state$slider_min, state$slider_max) @@ -254,11 +255,11 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = which(ticks == state$high_value) - 1 ) args <- list( - inputId = "slider", + inputId = session$ns("slider"), label = NULL, min = state$slider_min, max = state$slider_max, - value = values, + value = c(state$low_value, state$high_value), ticks = ticks, step = step_slider, ... @@ -266,10 +267,9 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = ticks <- paste0(args$ticks, collapse = ",") args$ticks <- TRUE html <- suppressWarnings(do.call("sliderInput", args)) - html$children[[2]]$attribs[["data-values"]] <- ticks } else { args <- list( - inputId = "slider", + inputId = session$ns("slider"), label = NULL, min = state$slider_min, max = state$slider_max, From 51eb85bccd9bba909e9d694fcd6d66f13b994945 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 11 Oct 2024 17:57:16 +0530 Subject: [PATCH 05/15] fix: re-render the slider when min and max state range changes --- R/toggleable_slider.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 83d3f5dc..9f3cd3bb 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -244,8 +244,16 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = shinyjs::toggle("slider_ui") }) + slider_range <- reactive({ + list( + low = slider_states()$low, + high = slider_states()$high + ) + }) + output$slider_ui <- renderUI({ req(input$toggle >= 0) + req(slider_range()) state <- isolate(slider_states()) if (length(seq(state$slider_min, state$slider_max)) < 10) { # The values should be index reference instead of actual values because of how we are calling the `sliderInput` From 046b119f16922f8062707315e92413db1625d49b Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 11 Oct 2024 18:07:31 +0530 Subject: [PATCH 06/15] fix: trigger update using the `keep_range_slider_updated` logic --- R/toggleable_slider.R | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 9f3cd3bb..1d6da357 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -146,6 +146,7 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_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({ @@ -244,12 +245,6 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = shinyjs::toggle("slider_ui") }) - slider_range <- reactive({ - list( - low = slider_states()$low, - high = slider_states()$high - ) - }) output$slider_ui <- renderUI({ req(input$toggle >= 0) @@ -295,6 +290,7 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_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( From 902fb404d6aa25baae5cfc7ac845b8938cbe3441 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 15 Oct 2024 19:28:49 +0530 Subject: [PATCH 07/15] fix: reset of slider state on toggle --- R/toggleable_slider.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 1d6da357..5ea2204d 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -213,10 +213,8 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = state_low$value <- state_low$value[[1]] state_high$value <- state_high$value[[2]] } - if (input$toggle %% 2 == 0) { - state_slider$max <- max(state_slider$max, state_slider$value[2]) - state_slider$min <- min(state_slider$min, state_slider$value[1]) - } + 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, From 4a25b2807c05972d17965fb39b9894d518d94a3d Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 16 Oct 2024 12:26:50 +0530 Subject: [PATCH 08/15] fix: manually hide the last before tick when it is closer + fix reactivity issue --- R/toggleable_slider.R | 30 +++++++++++++++++++++++++++--- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 5ea2204d..8b2f6aec 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -260,7 +260,7 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = label = NULL, min = state$slider_min, max = state$slider_max, - value = c(state$low_value, state$high_value), + value = state$slider_value, ticks = ticks, step = step_slider, ... @@ -274,13 +274,37 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = label = NULL, min = state$slider_min, max = state$slider_max, - value = c(state$slider_min, state$slider_max), + value = state$slider_value, step = step_slider, ... ) html <- do.call("sliderInput", args) } - html + 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) { From c12a8c7d9b4f56222d320ad18e2f311adee78042 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 16 Oct 2024 16:45:51 +0530 Subject: [PATCH 09/15] chore: remove redundant code --- R/toggleable_slider.R | 44 +++++++++++++++---------------------------- 1 file changed, 15 insertions(+), 29 deletions(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 8b2f6aec..9ffd01e8 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -177,8 +177,11 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = # 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 <- modifyList(old_state, new_state) + if (!setequal(new_state, cur_state())) { cur_state(new_state) } @@ -248,36 +251,19 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = 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) { - # The values should be index reference instead of actual values because of how we are calling the `sliderInput` - ticks <- seq(state$slider_min, state$slider_max) - values <- c( - which(ticks == state$low_value) - 1, - which(ticks == state$high_value) - 1 - ) - args <- list( - inputId = session$ns("slider"), - label = NULL, - min = state$slider_min, - max = state$slider_max, - value = state$slider_value, - ticks = ticks, - step = step_slider, - ... - ) - ticks <- paste0(args$ticks, collapse = ",") args$ticks <- TRUE - html <- suppressWarnings(do.call("sliderInput", args)) + html <- do.call("sliderInput", args) } else { - args <- list( - inputId = session$ns("slider"), - label = NULL, - min = state$slider_min, - max = state$slider_max, - value = state$slider_value, - step = step_slider, - ... - ) html <- do.call("sliderInput", args) } tags$div( From 215c0fc4cff079e60f12e278c533c4e69fb2c123 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 16 Oct 2024 16:49:06 +0530 Subject: [PATCH 10/15] chore: remove unwanted condition --- R/toggleable_slider.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 9ffd01e8..ea39b1d9 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -212,7 +212,7 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = 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]] } From c068ac35b8993c1682a6a09edd549f7ae3ed32d6 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 16 Oct 2024 17:23:59 +0530 Subject: [PATCH 11/15] chore: add package prefix --- R/toggleable_slider.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index ea39b1d9..a7e380a0 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -180,7 +180,7 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = if (is.null(old_state)) { old_state <- new_state } - new_state <- modifyList(old_state, new_state) + new_state <- utils::modifyList(old_state, new_state) if (!setequal(new_state, cur_state())) { cur_state(new_state) From 05befbf868ba5f9ed84f36a8dc9af51c9654cc13 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 16 Oct 2024 17:55:39 +0530 Subject: [PATCH 12/15] chore: simplify --- R/toggleable_slider.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index a7e380a0..45419a15 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -177,10 +177,9 @@ toggle_slider_server <- function(id, is_dichotomous_slider = TRUE, step_slider = # only update provided components, do not discasrd others old_state <- cur_state() - if (is.null(old_state)) { - old_state <- new_state + if (!is.null(old_state)) { + new_state <- utils::modifyList(old_state, new_state) } - new_state <- utils::modifyList(old_state, new_state) if (!setequal(new_state, cur_state())) { cur_state(new_state) From 665019cc7da658d510dcb408e310a2ec84421413 Mon Sep 17 00:00:00 2001 From: Vedha Viyash <49812166+vedhav@users.noreply.github.com> Date: Mon, 28 Oct 2024 19:36:43 +0530 Subject: [PATCH 13/15] Refactor slider state management (#322) Closes #321 Changes: 1. The `toggle_slider_ui` and `toggle_slider_server` can only be used to create dichotomous slider now. There was no instance of single value slider created. So, there is no need to create it and increase the complexity. 2. Removal of the `keep_range_slider_updated` in favor of `keep_slider_state_updated` to keep the states updated based on other widget inputs. 3. Updated the modules that uses this widget. Note that the `tm_g_gh_lineplot` does not use the `keep_slider_state_updated` and directly updates the state reactiveValues. Check all the modules that use the `toggle_slider` module: - [ ] `tm_g_gh_boxplot` - [ ] `tm_g_gh_correlationplot` - [ ] `tm_g_gh_density_distribution_plot` - [ ] `tm_g_gh_lineplot` - [ ] `tm_g_gh_spaghettiplot` - [ ] `tm_g_gh_scatterplot `(deprecate in favor of `tm_g_gh_correlationplot`) --------- Co-authored-by: go_gonzo --- DESCRIPTION | 1 + R/tm_g_gh_boxplot.R | 24 +- R/tm_g_gh_correlationplot.R | 31 +- R/tm_g_gh_density_distribution_plot.R | 45 +-- R/tm_g_gh_lineplot.R | 24 +- R/tm_g_gh_scatterplot.R | 41 +- R/tm_g_gh_spaghettiplot.R | 17 +- R/toggleable_slider.R | 380 ++++++------------ R/utils-keep_range_slider_updated.r | 46 --- man/toggle_sidebar.Rd | 90 ----- man/toggle_slider.Rd | 38 ++ tests/testthat.R | 3 + tests/testthat/helper-TealAppDriver.R | 20 + tests/testthat/helper-module-utils.R | 75 ++++ tests/testthat/helper-toggle-slider-utils.R | 88 ++++ .../test-shinytest2-tm_g_gh_boxplot.R | 105 +++++ 16 files changed, 539 insertions(+), 489 deletions(-) delete mode 100644 R/utils-keep_range_slider_updated.r delete mode 100644 man/toggle_sidebar.Rd create mode 100644 man/toggle_slider.Rd create mode 100644 tests/testthat.R create mode 100644 tests/testthat/helper-TealAppDriver.R create mode 100644 tests/testthat/helper-module-utils.R create mode 100644 tests/testthat/helper-toggle-slider-utils.R create mode 100644 tests/testthat/test-shinytest2-tm_g_gh_boxplot.R diff --git a/DESCRIPTION b/DESCRIPTION index a6dd12cd..7e106a8b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -78,3 +78,4 @@ Language: en-US LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 +Config/testthat/edition: 3 diff --git a/R/tm_g_gh_boxplot.R b/R/tm_g_gh_boxplot.R index 4f262c13..7f95d04b 100644 --- a/R/tm_g_gh_boxplot.R +++ b/R/tm_g_gh_boxplot.R @@ -263,10 +263,7 @@ ui_g_boxplot <- function(id, ...) { title = "Plot Aesthetic Settings", toggle_slider_ui( ns("yrange_scale"), - label = "Y-Axis Range Zoom", - min = -1000000, - max = 1000000, - value = c(-1000000, 1000000) + label = "Y-Axis Range Zoom" ), numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1), checkboxInput(ns("loq_legend"), "Display LoQ Legend", a$loq_legend), @@ -342,15 +339,14 @@ srv_g_boxplot <- function(id, anl_q <- anl_q_output()$value # update sliders for axes taking constraints into account - yrange_slider <- toggle_slider_server("yrange_scale") - keep_range_slider_updated( - session, - input, - update_slider_fcn = yrange_slider$update_state, - id_var = "yaxis_var", - id_param_var = "xaxis_param", - reactive_ANL = anl_q - ) + 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") @@ -395,7 +391,7 @@ srv_g_boxplot <- function(id, yaxis <- input$yaxis_var xaxis <- input$xaxis_var facet_var <- `if`(is.null(input$facet_var), "None", input$facet_var) - ylim <- yrange_slider$state()$value + ylim <- yrange_slider_state$value facet_ncol <- input$facet_ncol alpha <- input$alpha diff --git a/R/tm_g_gh_correlationplot.R b/R/tm_g_gh_correlationplot.R index f26a282b..36f15f0b 100644 --- a/R/tm_g_gh_correlationplot.R +++ b/R/tm_g_gh_correlationplot.R @@ -315,13 +315,11 @@ ui_g_correlationplot <- function(id, ...) { title = "Plot Aesthetic Settings", toggle_slider_ui( ns("xrange_scale"), - label = "X-Axis Range Zoom", - min = -1000000, max = 1000000, value = c(-1000000, 1000000) + label = "X-Axis Range Zoom" ), toggle_slider_ui( ns("yrange_scale"), - label = "Y-Axis Range Zoom", - min = -1000000, max = 1000000, value = c(-1000000, 1000000) + label = "Y-Axis Range Zoom" ), numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1), checkboxInput(ns("trt_facet"), "Treatment Variable Faceting", a$trt_facet), @@ -599,10 +597,23 @@ 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") - keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_constraint) - keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "yaxis_param", anl_constraint) + data_state_x <- reactive({ + get_data_range_states( + varname = input$xaxis_var, + paramname = input$xaxis_param, + ANL = anl_constraint()$ANL + ) + }) + 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") # selector names after transposition @@ -725,8 +736,8 @@ srv_g_correlationplot <- function(id, xaxis_var <- input$xaxis_var yaxis_param <- input$yaxis_param yaxis_var <- input$yaxis_var - xlim <- xrange_slider$state()$value - ylim <- yrange_slider$state()$value + xlim <- xrange_slider$value + ylim <- yrange_slider$value font_size <- input$font_size dot_size <- input$dot_size reg_text_size <- input$reg_text_size diff --git a/R/tm_g_gh_density_distribution_plot.R b/R/tm_g_gh_density_distribution_plot.R index 3d3a2f85..1227bca6 100644 --- a/R/tm_g_gh_density_distribution_plot.R +++ b/R/tm_g_gh_density_distribution_plot.R @@ -203,17 +203,11 @@ ui_g_density_distribution_plot <- function(id, ...) { title = "Plot Aesthetic Settings", toggle_slider_ui( ns("xrange_scale"), - label = "X-Axis Range Zoom", - min = -1000000, - max = 1000000, - value = c(-1000000, 1000000) + label = "X-Axis Range Zoom" ), toggle_slider_ui( ns("yrange_scale"), - label = "Y-Axis Range Zoom", - min = -1000000, - max = 1000000, - value = c(-1000000, 1000000) + label = "Y-Axis Range Zoom" ), numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1), checkboxInput(ns("comb_line"), "Display Combined line", a$comb_line), @@ -287,19 +281,24 @@ 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") - keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q) - keep_range_slider_updated( - session, - input, - yrange_slider$update_state, - "xaxis_var", - "xaxis_param", - anl_q, - is_density = TRUE, - "trt_group" - ) + data_state_x <- reactive({ + get_data_range_states( + varname = input$xaxis_var, + paramname = input$xaxis_param, + ANL = anl_q()$ANL + ) + }) + 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") horizontal_line <- srv_arbitrary_lines("hline_arb") @@ -326,8 +325,8 @@ srv_g_density_distribution_plot <- function(id, # nolint # nolint start param <- input$xaxis_param xaxis_var <- input$xaxis_var - xlim <- xrange_slider$state()$value - ylim <- yrange_slider$state()$value + xlim <- xrange_slider$value + ylim <- yrange_slider$value font_size <- input$font_size line_size <- input$line_size hline_arb <- horizontal_line()$line_arb diff --git a/R/tm_g_gh_lineplot.R b/R/tm_g_gh_lineplot.R index 516c13fd..044419ed 100644 --- a/R/tm_g_gh_lineplot.R +++ b/R/tm_g_gh_lineplot.R @@ -271,10 +271,7 @@ ui_lineplot <- function(id, ...) { title = "Plot Aesthetic Settings", toggle_slider_ui( ns("yrange_scale"), - label = "Y-Axis Range Zoom", - min = -1000000, - max = 1000000, - value = c(-1000000, 1000000) + label = "Y-Axis Range Zoom" ), checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab), numericInput(ns("count_threshold"), "Contributing Observations Threshold:", a$count_threshold) @@ -404,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({ @@ -423,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")) @@ -436,7 +431,7 @@ srv_lineplot <- function(id, NULL } - # we don't need to additionally filter for paramvar here as in keep_range_slider_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)) %>% @@ -463,15 +458,14 @@ srv_lineplot <- function(id, f = 0.05 ) - # we don't use keep_range_slider_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 - isolate(yrange_slider$update_state( - min = minmax[[1]], - max = minmax[[2]], - value = minmax - )) + list( + range = c(min = minmax[[1]], max = minmax[[2]]) + ) }) + yrange_slider <- toggle_slider_server("yrange_scale", data_state) line_color_defaults <- color_manual line_type_defaults <- c( @@ -667,7 +661,7 @@ srv_lineplot <- function(id, teal::validate_inputs(iv_r()) req(anl_q(), line_color_selected(), line_type_selected()) # nolint start - ylim <- yrange_slider$state()$value + ylim <- yrange_slider$value plot_font_size <- input$plot_font_size dot_size <- input$dot_size dodge <- input$dodge diff --git a/R/tm_g_gh_scatterplot.R b/R/tm_g_gh_scatterplot.R index 916876b3..da82442f 100644 --- a/R/tm_g_gh_scatterplot.R +++ b/R/tm_g_gh_scatterplot.R @@ -200,17 +200,13 @@ ui_g_scatterplot <- function(id, ...) { teal.widgets::panel_group( teal.widgets::panel_item( title = "Plot Aesthetic Settings", - toggle_slider_ui(ns("xrange_scale"), - label = "X-Axis Range Zoom", - min = -1000000, - max = 1000000, - value = c(-1000000, 1000000) + toggle_slider_ui( + ns("xrange_scale"), + label = "X-Axis Range Zoom" ), - toggle_slider_ui(ns("yrange_scale"), - label = "Y-Axis Range Zoom", - min = -1000000, - max = 1000000, - value = c(-1000000, 1000000) + toggle_slider_ui( + ns("yrange_scale"), + label = "Y-Axis Range Zoom" ), numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1), checkboxInput(ns("trt_facet"), "Treatment Variable Faceting", a$trt_facet), @@ -290,18 +286,31 @@ 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") - keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q) - keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q) + data_state_x <- reactive({ + get_data_range_states( + varname = input$xaxis_var, + paramname = input$xaxis_param, + ANL = anl_q()$ANL + ) + }) + 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") # plot plot_q <- debounce(reactive({ req(anl_q()) # nolint start - xlim <- xrange_slider$state()$value - ylim <- yrange_slider$state()$value + xlim <- xrange_slider$value + ylim <- yrange_slider$value facet_ncol <- input$facet_ncol validate(need( is.na(facet_ncol) || (as.numeric(facet_ncol) > 0 && as.numeric(facet_ncol) %% 1 == 0), diff --git a/R/tm_g_gh_spaghettiplot.R b/R/tm_g_gh_spaghettiplot.R index 3077d655..48379ef8 100644 --- a/R/tm_g_gh_spaghettiplot.R +++ b/R/tm_g_gh_spaghettiplot.R @@ -301,10 +301,7 @@ g_ui_spaghettiplot <- function(id, ...) { tags$div( toggle_slider_ui( ns("yrange_scale"), - label = "Y-Axis Range Zoom", - min = -1000000, - max = 1000000, - value = c(-1000000, 1000000) + label = "Y-Axis Range Zoom" ), tags$div( class = "flex flex-wrap items-center", @@ -399,8 +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") - keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q) + 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") @@ -425,7 +428,7 @@ srv_g_spaghettiplot <- function(id, teal::validate_inputs(iv_r()) req(anl_q()) # nolint start - ylim <- yrange_slider$state()$value + ylim <- yrange_slider$value facet_ncol <- input$facet_ncol facet_scales <- ifelse(input$free_x, "free_x", "fixed") diff --git a/R/toggleable_slider.R b/R/toggleable_slider.R index 45419a15..c946dc3b 100644 --- a/R/toggleable_slider.R +++ b/R/toggleable_slider.R @@ -1,308 +1,152 @@ -#' UI with a toggleable slider to change between slider and numeric input fields +#' UI with a toggleable dichotomous slider to change between slider and numeric input fields #' #' This is useful when a slider should be shown, but it is sometimes hard to configure sliders, #' so one can toggle to one or two numeric input fields to set slider instead. -#' Both normal sliders (for a single number in a range) and dichotomous sliders (for a range -#' within the slider range) are supported. In the former case, the toggle button -#' will show one numeric input field, in the latter case two. -#' -#' Value is not checked to be within minmax range +#' The toggle button will show two numeric input field for selecting the from and to range. #' #' @md #' @param id `character` module id #' @param label `label` label for input field, e.g. slider or numeric inputs -#' @param min `numeric or integer` minimum value -#' @param max `numeric or integer` maximum value -#' @param value `numeric or integer` either of length 1 for normal slider or of -#' length 2 for dichotomous slider. -#' @param slider_initially `logical` whether to show slider or numeric fields -#' initially -#' @param step_numeric `numeric or integer` step for numeric input fields -#' @param width `numeric` width of slider or of each numeric field -#' -#' @examples -#' value <- c(20.3, 81.5) # dichotomous slider -#' # value <- c(50.1) # normal slider -#' -#' # use non-exported function from teal.goshawk -#' toggle_slider_ui <- getFromNamespace("toggle_slider_ui", "teal.goshawk") -#' toggle_slider_server <- getFromNamespace("toggle_slider_server", "teal.goshawk") -#' -#' ui <- div( -#' toggle_slider_ui( -#' "toggle_slider", "Select value", -#' min = 0.2, max = 100.1, value = value, -#' 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, -#' step_slider = 0.1 -#' ) -#' messages <- reactiveVal() # to keep history -#' observeEvent(range_value$state(), { -#' list_with_names_str <- function(x) paste(names(x), x, sep = ": ", collapse = ", ") -#' messages(c(messages(), list_with_names_str(range_value$state()))) -#' }) -#' output$value <- renderText({ -#' paste(messages(), collapse = "\n") -#' }) -#' } +#' @param ... additional parameters to pass to `sliderInput` #' -#' if (interactive()) { -#' shinyApp(ui, server) -#' } -#' @name toggle_sidebar -#' @rdname toggle_sidebar +#' @name toggle_slider #' @keywords internal #' @return `NULL`. NULL -#' @rdname toggle_sidebar -toggle_slider_ui <- function(id, - label, - min, - max, - value, - slider_initially = TRUE, - step_slider = NULL, - step_numeric = step_slider, - width = NULL, - ...) { - checkmate::assert_number(min) - checkmate::assert_number(max) - checkmate::assert_flag(slider_initially) - checkmate::assert_number(step_slider, null.ok = TRUE) - checkmate::assert_number(step_numeric, null.ok = TRUE) - checkmate::assert_numeric(value, min.len = 1, max.len = 2) - if (is.null(step_numeric)) { - step_numeric <- NA # numericInput does not support NULL - } - - show_or_not <- function(show) if (show) identity else shinyjs::hidden +#' @rdname toggle_slider +toggle_slider_ui <- function(id, label) { ns <- NS(id) tags$div( - include_css_files("custom"), - shinyjs::useShinyjs(), tags$div( - class = "flex justify-between mb-1", + style = "display: flex; justify-content: space-between;", tags$span(tags$strong(label)), - actionButton(ns("toggle"), "Toggle", class = "btn-xs") - ), - show_or_not(slider_initially)( - uiOutput(ns("slider_ui")) + tags$div(actionButton(ns("toggle"), "Toggle", class = "btn-xs")) ), - show_or_not(!slider_initially)(tags$span( - id = ns("numeric_view"), - if (length(value) == 1) { - numericInput( - ns("value"), - label = NULL, - min = min, - max = max, - value = value[[1]], - step = step_numeric, - width = width - ) - } else { - tags$div( - numericInput( - ns("value_low"), - "From:", - min = min, - max = max, - value = value[[1]], - step = step_numeric, - width = width - ), - numericInput( - ns("value_high"), - "- to:", - min = min, - max = max, - value = value[[2]], - step = step_numeric, - width = width - ) - ) - } - )) + uiOutput(ns("inputs")) ) } -#' @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, ...) { +toggle_slider_server <- function(id, data_state, ...) { 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) - + state <- reactiveValues( + min = NULL, + max = NULL, + value = NULL + ) + slider_shown <- reactive(input$toggle %% 2 == 0) - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$condition(~ input$toggle %% 2 == 1) - iv$add_rule("value_low", shinyvalidate::sv_required("A 'from' value is required - a default is used instead")) - iv$add_rule("value_high", shinyvalidate::sv_required("A 'to' value is required - a default is used instead)")) - iv$add_rule( - "value_high", - ~ if (!is.na(input$value_low) && (.) < input$value_low) { - "'From' value should be lower than 'to' value - axis has been flipped" - } - ) - iv$add_rule( - "value_low", - ~ if (!is.na(input$value_high) && (.) > input$value_high) { - "'To' value should be greater than 'from' value - axis has been flipped" - } - ) - iv$enable() - iv + observeEvent(data_state()$range, { + state$min <- data_state()$range[1] + state$max <- data_state()$range[2] + state$value <- data_state()$range }) - set_state <- function(new_state) { - stopifnot(all(names(new_state) %in% c("min", "max", "step", "value"))) - iv_r()$is_valid() - # when value does not fall into min, max range, it will automatically get truncated - - # only update provided components, do not discasrd others - old_state <- cur_state() - if (!is.null(old_state)) { - new_state <- utils::modifyList(old_state, new_state) - } - - if (!setequal(new_state, cur_state())) { - cur_state(new_state) + output$inputs <- renderUI({ + req(state$value) + if (slider_shown()) { + tags$div( + class = "teal-goshawk toggle-slider-container", + sliderInput( + inputId = session$ns("slider"), + label = NULL, + min = min(data_state()$range[1], state$min), + max = max(data_state()$range[2], state$max), + value = state$value, + 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."); + } + }); + ', + 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, { - set_state(list(value = input$slider)) }) - # two values for range (dichotomous slider) - observeEvent( - eventExpr = { # nolint - input$value_low - input$value_high - }, - handlerExpr = { # nolint - set_state(list(value = c(input$value_low, input$value_high))) - } - ) - # one value for value in range - observeEvent( - input$value, - handlerExpr = { # nolint - set_state(list(value = input$value)) - } - ) - 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 (length(state_slider$value) > 1) { - state_low$value <- state_low$value[[1]] - state_high$value <- state_high$value[[2]] - } - 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 - ) - }) + d_slider <- debounce(reactive(input$slider), 500) - 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)) - } + observeEvent(d_slider(), { + if (!setequal(state$value, d_slider())) { + state$value <- d_slider() } - } - observeEvent(input$toggle, { - update_widgets() - shinyjs::toggle("numeric_view") - shinyjs::toggle("slider_ui") }) + d_value_low <- debounce(reactive(input$value_low), 500) + d_value_high <- debounce(reactive(input$value_high), 500) - 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) + observeEvent(c(d_value_low(), d_value_high()), ignoreInit = TRUE, { + values <- c(input$value_low, input$value_high) + if (!setequal(state$value, values)) { + state$value <- values + state$min <- values[1] + state$max <- values[2] } - 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( - state = cur_state, - update_state = update_toggle_slider - )) + return(state) }) } + +#' @keywords internal +#' @rdname toggle_slider +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")) + + var <- stats::na.omit(ANL[[varname]]) + minmax <- if (length(var)) c(floor(min(var)), ceiling(max(var))) else c(0, 0) + if (!is.null(trt_group)) { + ANL_split <- ANL %>% split(f = factor(paste0(ANL[["AVISITCD"]], ANL[[trt_group]]))) # nolint + density_maxes <- lapply(ANL_split, function(x) { + max(stats::density(stats::na.omit(x[[varname]]))$y) + }) + dmax <- max(unlist(density_maxes)) + minmax <- c(0, round(dmax * 1.2, 5)) + step <- round(dmax / 100, 5) + } + list( + range = c(min = minmax[[1]], max = minmax[[2]]), + step = step + ) +} diff --git a/R/utils-keep_range_slider_updated.r b/R/utils-keep_range_slider_updated.r deleted file mode 100644 index c179d5a0..00000000 --- a/R/utils-keep_range_slider_updated.r +++ /dev/null @@ -1,46 +0,0 @@ -keep_range_slider_updated <- function(session, - input, - update_slider_fcn, - id_var, - id_param_var, - reactive_ANL, # nolint - is_density = FALSE, - id_trt_group) { - stopifnot(is.function(update_slider_fcn)) - - observe({ - varname <- input[[id_var]] - validate(need(varname, "Please select variable")) - paramname <- input[[id_param_var]] - validate(need(paramname, "Please select variable")) - req(length(paramname) == 1) - - # we need id_param_var (e.g. ALT) to filter down because the y-axis may have a different - # param var and the range of id_var (e.g. BASE) values may be larger due to this - # therefore, we need to filter - ANL <- reactive_ANL()$ANL %>% dplyr::filter(.data$PARAMCD == paramname) # nolint - validate_has_variable(ANL, varname, paste("variable", varname, "does not exist")) - - var <- stats::na.omit(ANL[[varname]]) - minmax <- if (length(var)) c(floor(min(var)), ceiling(max(var))) else c(0, 0) - step <- NULL - - if (isTRUE(is_density)) { - treatname <- input[[id_trt_group]] - ANL_split <- ANL %>% split(f = factor(paste0(ANL[["AVISITCD"]], ANL[[treatname]]))) # nolint - density_maxes <- lapply(ANL_split, function(x) { - max(stats::density(stats::na.omit(x[[varname]]))$y) - }) - dmax <- max(unlist(density_maxes)) - minmax <- c(0, round(dmax * 1.2, 5)) - step <- round(dmax / 100, 5) - } - - isolate(update_slider_fcn( - min = minmax[[1]], - max = minmax[[2]], - value = minmax, - step = step - )) - }) -} diff --git a/man/toggle_sidebar.Rd b/man/toggle_sidebar.Rd deleted file mode 100644 index 29774db7..00000000 --- a/man/toggle_sidebar.Rd +++ /dev/null @@ -1,90 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/toggleable_slider.R -\name{toggle_sidebar} -\alias{toggle_sidebar} -\alias{toggle_slider_ui} -\title{UI with a toggleable slider to change between slider and numeric input fields} -\usage{ -toggle_slider_ui( - id, - label, - min, - max, - value, - slider_initially = TRUE, - step_slider = NULL, - step_numeric = step_slider, - width = NULL, - ... -) -} -\arguments{ -\item{id}{\code{character} module id} - -\item{label}{\code{label} label for input field, e.g. slider or numeric inputs} - -\item{min}{\verb{numeric or integer} minimum value} - -\item{max}{\verb{numeric or integer} maximum value} - -\item{value}{\verb{numeric or integer} either of length 1 for normal slider or of -length 2 for dichotomous slider.} - -\item{slider_initially}{\code{logical} whether to show slider or numeric fields -initially} - -\item{step_numeric}{\verb{numeric or integer} step for numeric input fields} - -\item{width}{\code{numeric} width of slider or of each numeric field} -} -\value{ -\code{NULL}. -} -\description{ -This is useful when a slider should be shown, but it is sometimes hard to configure sliders, -so one can toggle to one or two numeric input fields to set slider instead. -Both normal sliders (for a single number in a range) and dichotomous sliders (for a range -within the slider range) are supported. In the former case, the toggle button -will show one numeric input field, in the latter case two. -} -\details{ -Value is not checked to be within minmax range -} -\examples{ -value <- c(20.3, 81.5) # dichotomous slider -# value <- c(50.1) # normal slider - -# use non-exported function from teal.goshawk -toggle_slider_ui <- getFromNamespace("toggle_slider_ui", "teal.goshawk") -toggle_slider_server <- getFromNamespace("toggle_slider_server", "teal.goshawk") - -ui <- div( - toggle_slider_ui( - "toggle_slider", "Select value", - min = 0.2, max = 100.1, value = value, - 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, - step_slider = 0.1 - ) - messages <- reactiveVal() # to keep history - observeEvent(range_value$state(), { - list_with_names_str <- function(x) paste(names(x), x, sep = ": ", collapse = ", ") - messages(c(messages(), list_with_names_str(range_value$state()))) - }) - output$value <- renderText({ - paste(messages(), collapse = "\n") - }) -} - -if (interactive()) { - shinyApp(ui, server) -} -} -\keyword{internal} diff --git a/man/toggle_slider.Rd b/man/toggle_slider.Rd new file mode 100644 index 00000000..e973eca9 --- /dev/null +++ b/man/toggle_slider.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/toggleable_slider.R +\name{toggle_slider} +\alias{toggle_slider} +\alias{toggle_slider_ui} +\alias{toggle_slider_server} +\alias{keep_slider_state_updated} +\title{UI with a toggleable dichotomous slider to change between slider and numeric input fields} +\usage{ +toggle_slider_ui(id, label) + +toggle_slider_server(id, ...) + +keep_slider_state_updated( + state, + varname, + paramname, + ANL, + trt_group = NULL, + step = NULL +) +} +\arguments{ +\item{id}{\code{character} module id} + +\item{label}{\code{label} label for input field, e.g. slider or numeric inputs} + +\item{...}{additional parameters to pass to \code{sliderInput}} +} +\value{ +\code{NULL}. +} +\description{ +This is useful when a slider should be shown, but it is sometimes hard to configure sliders, +so one can toggle to one or two numeric input fields to set slider instead. +The toggle button will show two numeric input field for selecting the from and to range. +} +\keyword{internal} diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 00000000..174caadb --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,3 @@ +pkg_name <- "teal.goshawk" +library(pkg_name, character.only = TRUE) +testthat::test_check(pkg_name) diff --git a/tests/testthat/helper-TealAppDriver.R b/tests/testthat/helper-TealAppDriver.R new file mode 100644 index 00000000..599e5c88 --- /dev/null +++ b/tests/testthat/helper-TealAppDriver.R @@ -0,0 +1,20 @@ +init_teal_app_driver <- function(...) { + testthat::with_mocked_bindings( + { + TealAppDriver <- getFromNamespace("TealAppDriver", "teal") # nolint: object_name. + TealAppDriver$new(...) + }, + shinyApp = function(ui, server, ...) { + functionBody(server) <- bquote({ + # Hint to shinytest2 that this package should be available (via {globals}) + .hint_to_load_package <- tm_g_gh_boxplot # Hint to shinytest2 when looking for packages in globals + .(functionBody(server)) + }) + + shiny::shinyApp(ui, server, ...) + }, + # The relevant shinyApp call in `TealAppDriver` is being called without prefix, + # hence why the package bindings that is changed is in {teal} and not {shiny} + .package = "teal" + ) +} diff --git a/tests/testthat/helper-module-utils.R b/tests/testthat/helper-module-utils.R new file mode 100644 index 00000000..7405ead5 --- /dev/null +++ b/tests/testthat/helper-module-utils.R @@ -0,0 +1,75 @@ +# nolint start +get_test_data <- function() { + data <- teal_data() + data <- within(data, { + library(dplyr) + library(nestcolor) + library(stringr) + + # use non-exported function from goshawk + h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk") + + # original ARM value = dose value + arm_mapping <- list( + "A: Drug X" = "150mg QD", + "B: Placebo" = "Placebo", + "C: Combination" = "Combination" + ) + set.seed(1) + ADSL <- rADSL + ADLB <- rADLB + var_labels <- lapply(ADLB, function(x) attributes(x)$label) + ADLB <- ADLB %>% + mutate( + AVISITCD = case_when( + AVISIT == "SCREENING" ~ "SCR", + AVISIT == "BASELINE" ~ "BL", + grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")), + TRUE ~ as.character(NA) + ), + AVISITCDN = case_when( + AVISITCD == "SCR" ~ -2, + AVISITCD == "BL" ~ 0, + grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), + TRUE ~ as.numeric(NA) + ), + AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN), + TRTORD = case_when( + ARMCD == "ARM C" ~ 1, + ARMCD == "ARM B" ~ 2, + ARMCD == "ARM A" ~ 3 + ), + ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]), + ARM = factor(ARM) %>% reorder(TRTORD), + ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]), + ACTARM = factor(ACTARM) %>% reorder(TRTORD), + ANRLO = 50, + ANRHI = 75 + ) %>% + rowwise() %>% + group_by(PARAMCD) %>% + mutate(LBSTRESC = ifelse( + USUBJID %in% sample(USUBJID, 1, replace = TRUE), + paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC + )) %>% + mutate(LBSTRESC = ifelse( + USUBJID %in% sample(USUBJID, 1, replace = TRUE), + paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC + )) %>% + ungroup() + + attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] + attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]] + attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit" + attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit" + + # add LLOQ and ULOQ variables + ALB_LOQS <- h_identify_loq_values(ADLB, "LOQFL") + ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM") + }) + datanames <- c("ADSL", "ADLB") + datanames(data) <- datanames + join_keys(data) <- default_cdisc_join_keys[datanames] + data +} +# nolint end diff --git a/tests/testthat/helper-toggle-slider-utils.R b/tests/testthat/helper-toggle-slider-utils.R new file mode 100644 index 00000000..b893a02f --- /dev/null +++ b/tests/testthat/helper-toggle-slider-utils.R @@ -0,0 +1,88 @@ +click_toggle_button <- function(app) { + app$click(NS(app$active_ns()$module, "yrange_scale-toggle")) +} + +#' 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-inputs") + # Note that the values can only be observed once they are visible + if (!is_slider_visible(app)) { + click_toggle_button(app) + } + list( + min = app$get_text(sprintf("#%s .irs-min", id)) |> as.numeric(), + max = app$get_text(sprintf("#%s .irs-max", id)) |> as.numeric(), + value = c( + app$get_text(sprintf("#%s .irs-from", id)), + app$get_text(sprintf("#%s .irs-to", id)) + ) |> as.numeric() + ) +} + +#' 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") + ) +} + +#' Checking if the sliderInput and the numericInputs with custom values. +#' values must be a list with min, max, value as keys. +#' check_widgets_with_value(app, list(min = 0, max = 55, value = c(0, 55))) +check_widgets_with_value <- function(app, values) { + checkmate::assert_list(values, types = "numeric", min.len = 3) + 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_setequal( + numeric_values, + values$value + ) +} + +is_slider_visible <- function(app) { + app$get_active_module_input("yrange_scale-toggle") %% 2 == 0 +} + +#' values should be a numeric vector of length 2 +#' Note that it will automatically toggle slider to be visible before setting it +set_slider_values <- function(app, values) { + checkmate::assert_numeric(values, len = 2) + + if (!is_slider_visible(app)) { + click_toggle_button(app) + } + app$set_active_module_input( + "yrange_scale-slider", + values, + wait_ = FALSE + ) +} + +#' values should be a numeric vector of length 2 +#' Note that it will automatically toggle slider to be visible before setting it +set_numeric_input_values <- function(app, values) { + checkmate::assert_numeric(values, len = 2) + + if (is_slider_visible(app)) { + click_toggle_button(app) + } + app$set_active_module_input( + "yrange_scale-value_low", + values[1], + wait_ = FALSE + ) + 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 new file mode 100644 index 00000000..4fdcdb3f --- /dev/null +++ b/tests/testthat/test-shinytest2-tm_g_gh_boxplot.R @@ -0,0 +1,105 @@ +app_driver <- init_teal_app_driver( + data = get_test_data(), + modules = tm_g_gh_boxplot( + label = "Box Plot", + dataname = "ADLB", + param_var = "PARAMCD", + param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"), + yaxis_var = choices_selected(c("AVAL", "BASE", "CHG"), "AVAL"), + xaxis_var = choices_selected(c("ACTARM", "ARM", "AVISITCD", "STUDYID"), "ARM"), + facet_var = choices_selected(c("ACTARM", "ARM", "AVISITCD", "SEX"), "AVISITCD"), + trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"), + loq_legend = TRUE, + rotate_xlab = FALSE, + hline_arb = c(60, 55), + hline_arb_color = c("grey", "red"), + hline_arb_label = c("default_hori_A", "default_hori_B"), + hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"), + hline_vars_colors = c("pink", "brown", "purple", "black"), + ) +) + +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( + app_driver, + list(min = 0, max = 55, value = c(1, 50)) + ) +}) + +testthat::test_that( + "toggle_slider_module: changing the numericInputs + within the sliderInput range, sets proper sliderInput values", + { + initial_range <- list(min = 0, max = 55) + new_value <- c(10, 40) + set_numeric_input_values(app_driver, new_value) + check_widgets_with_value( + app_driver, + list( + min = initial_range$min, + max = initial_range$max, + value = new_value + ) + ) + } +) + +testthat::test_that( + "toggle_slider_module: changing the numericInputs + outside the sliderInput range, sets proper sliderInput values and range", + { + new_range <- c(-5, 60) + set_numeric_input_values(app_driver, new_range) + check_widgets_with_value( + app_driver, + list( + min = new_range[1], + max = new_range[2], + value = c(new_range[1], new_range[2]) + ) + ) + } +) + +testthat::test_that( + "toggle_slider_module: changing the numericInputs + within the rage, sets back the sliderInput range to initial range", + { + initial_range <- list(min = 0, max = 55) + new_value <- c(11, 30) + set_numeric_input_values(app_driver, new_value) + check_widgets_with_value( + app_driver, + list( + min = initial_range$min, + max = initial_range$max, + value = c(new_value[1], new_value[2]) + ) + ) + } +) + +testthat::test_that( + "toggle_slider_module: changing dependant widgets outside +sets proper sliderInput and numericInput values", + { + app_driver$set_active_module_input("xaxis_param", "CRP") + new_range <- c(5, 13) + check_widgets_with_value( + app_driver, + list( + min = new_range[1], + max = new_range[2], + value = c(new_range[1], new_range[2]) + ) + ) + app_driver$stop() + } +) From 59908554304216f210394f1fc6ba437f513a7722 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Mon, 28 Oct 2024 14:12:04 +0000 Subject: [PATCH 14/15] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/toggle_slider.Rd | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/man/toggle_slider.Rd b/man/toggle_slider.Rd index e973eca9..8a28de07 100644 --- a/man/toggle_slider.Rd +++ b/man/toggle_slider.Rd @@ -4,21 +4,14 @@ \alias{toggle_slider} \alias{toggle_slider_ui} \alias{toggle_slider_server} -\alias{keep_slider_state_updated} +\alias{get_data_range_states} \title{UI with a toggleable dichotomous slider to change between slider and numeric input fields} \usage{ toggle_slider_ui(id, label) -toggle_slider_server(id, ...) +toggle_slider_server(id, data_state, ...) -keep_slider_state_updated( - state, - varname, - paramname, - ANL, - trt_group = NULL, - step = NULL -) +get_data_range_states(varname, paramname, ANL, trt_group = NULL, step = NULL) } \arguments{ \item{id}{\code{character} module id} From 0be5c7f260c784e0990b29415893121361fa5832 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 28 Oct 2024 21:11:18 +0530 Subject: [PATCH 15/15] chore: add test dependencies to suggests --- DESCRIPTION | 4 +++- tests/testthat/helper-toggle-slider-utils.R | 18 ++++++++++++++---- .../testthat/test-shinytest2-tm_g_gh_boxplot.R | 9 ++++++--- 3 files changed, 23 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 44f32e1b..bb67b066 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -59,6 +59,8 @@ Suggests: teal.data (>= 0.5.0), tern (>= 0.7.10), testthat (>= 3.0.4), + rvest (>= 1.0.0), + shinytest2, utils VignetteBuilder: knitr, @@ -72,7 +74,7 @@ Config/Needs/verdepcheck: insightsengineering/goshawk, rstudio/shiny, insightsengineering/teal.widgets, yihui/knitr, insightsengineering/nestcolor, rstudio/rmarkdown, tidyverse/stringr, insightsengineering/teal.data, insightsengineering/tern, - r-lib/testthat + r-lib/testthat, rstudio/shinytest2, tidyverse/rvest Config/Needs/website: insightsengineering/nesttemplate Encoding: UTF-8 Language: en-US diff --git a/tests/testthat/helper-toggle-slider-utils.R b/tests/testthat/helper-toggle-slider-utils.R index b893a02f..68043922 100644 --- a/tests/testthat/helper-toggle-slider-utils.R +++ b/tests/testthat/helper-toggle-slider-utils.R @@ -67,10 +67,10 @@ set_slider_values <- function(app, values) { ) } -#' values should be a numeric vector of length 2 +#' value should be a numeric vector of length 1 #' Note that it will automatically toggle slider to be visible before setting it -set_numeric_input_values <- function(app, values) { - checkmate::assert_numeric(values, len = 2) +set_numeric_input_low <- function(app, values) { + checkmate::assert_numeric(values, len = 1) if (is_slider_visible(app)) { click_toggle_button(app) @@ -80,9 +80,19 @@ set_numeric_input_values <- function(app, values) { values[1], wait_ = FALSE ) +} + +#' value should be a numeric vector of length 1 +#' Note that it will automatically toggle slider to be visible before setting it +set_numeric_input_high <- function(app, values) { + checkmate::assert_numeric(values, len = 1) + + if (is_slider_visible(app)) { + click_toggle_button(app) + } app$set_active_module_input( "yrange_scale-value_high", - values[2], + values[1], 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 4fdcdb3f..f5ea36e4 100644 --- a/tests/testthat/test-shinytest2-tm_g_gh_boxplot.R +++ b/tests/testthat/test-shinytest2-tm_g_gh_boxplot.R @@ -39,7 +39,8 @@ testthat::test_that( { initial_range <- list(min = 0, max = 55) new_value <- c(10, 40) - set_numeric_input_values(app_driver, new_value) + set_numeric_input_low(app_driver, new_value[1]) + set_numeric_input_high(app_driver, new_value[2]) check_widgets_with_value( app_driver, list( @@ -56,7 +57,8 @@ testthat::test_that( outside the sliderInput range, sets proper sliderInput values and range", { new_range <- c(-5, 60) - set_numeric_input_values(app_driver, new_range) + set_numeric_input_low(app_driver, new_range[1]) + set_numeric_input_high(app_driver, new_range[2]) check_widgets_with_value( app_driver, list( @@ -74,7 +76,8 @@ testthat::test_that( { initial_range <- list(min = 0, max = 55) new_value <- c(11, 30) - set_numeric_input_values(app_driver, new_value) + set_numeric_input_low(app_driver, new_value[1]) + set_numeric_input_high(app_driver, new_value[2]) check_widgets_with_value( app_driver, list(