Skip to content

Commit

Permalink
feat: pass the data states as a reactive
Browse files Browse the repository at this point in the history
  • Loading branch information
vedhav committed Oct 28, 2024
1 parent 118fc93 commit 8182ce7
Show file tree
Hide file tree
Showing 8 changed files with 62 additions and 79 deletions.
7 changes: 3 additions & 4 deletions R/tm_g_gh_boxplot.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")
Expand Down
15 changes: 6 additions & 9 deletions R/tm_g_gh_correlationplot.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")

Expand Down
15 changes: 6 additions & 9 deletions R/tm_g_gh_density_distribution_plot.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")

Expand Down
16 changes: 6 additions & 10 deletions R/tm_g_gh_lineplot.R
Original file line number Diff line number Diff line change
Expand Up @@ -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({
Expand All @@ -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"))

Expand All @@ -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)) %>%
Expand All @@ -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(
Expand Down
15 changes: 6 additions & 9 deletions R/tm_g_gh_scatterplot.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")

Expand Down
7 changes: 3 additions & 4 deletions R/tm_g_gh_spaghettiplot.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")
Expand Down
64 changes: 32 additions & 32 deletions R/toggleable_slider.R
Original file line number Diff line number Diff line change
Expand Up @@ -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({
Expand All @@ -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")
)))
)
Expand Down Expand Up @@ -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"))
Expand All @@ -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
)
}
2 changes: 0 additions & 2 deletions tests/testthat/test-shinytest2-tm_g_gh_boxplot.R
Original file line number Diff line number Diff line change
Expand Up @@ -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(
Expand Down

0 comments on commit 8182ce7

Please sign in to comment.