#271640 [dv.edish] Feature requests - User-controlled axes ranges

R/helper_functions.R

@@ -132,7 +132,7 @@ filter_data <- function(dataset, arm_var, sel_arm, lb_test_var, sel_lb_test) {
 #'
 #' @param dataset `[data.frame]`
 #'
-#' A dataframe containing the variables listed below as columns.
+#' A data frame containing the variables listed below as columns.
 #' @param subjectid_var `[character(1)]`
 #'
 #' Name of the variable containing the unique subject IDs.
@@ -175,7 +175,7 @@ derive_req_vars <- function(
     return(NULL)
   }
 
-  # Get the data-frame in required structure (Pivot wider grouped by certain variables)
+  # Get the data frame in required structure (Pivot wider grouped by certain variables)
   dataset <- dataset %>%
     dplyr::filter(.data[[lb_test_var]] %in% c(sel_x, sel_y)) %>%
     dplyr::mutate(
@@ -185,7 +185,7 @@ derive_req_vars <- function(
     dplyr::select(dplyr::all_of(c(subjectid_var, arm_var, lb_test_var, visit_var, "r_ULN", "r_Baseline"))) %>%
     dplyr::group_by(.data[[subjectid_var]], .data[[arm_var]], .data[[lb_test_var]], .data[[visit_var]]) %>%
     dplyr::mutate(row = dplyr::row_number()) %>%
-    tidyr::pivot_wider(names_from = lb_test_var, values_from = c("r_ULN", "r_Baseline")) %>%
+    tidyr::pivot_wider(names_from = tidyr::all_of(lb_test_var), values_from = c("r_ULN", "r_Baseline")) %>%
     dplyr::select(-dplyr::all_of("row")) %>%
     dplyr::mutate(
       "r_ULN_{{sel_x}}" = as.numeric(.data[[paste0("r_ULN_", sel_x)]]),
@@ -205,7 +205,7 @@ derive_req_vars <- function(
 #'
 #' @param dataset `[data.frame]`
 #'
-#' A dataframe containing the variables listed below as columns.
+#' A data frame containing the variables listed below as columns.
 #' @param subjectid_var `[character(1)]`
 #'
 #' Name of the variable containing the unique subject IDs.
@@ -229,6 +229,24 @@ derive_req_vars <- function(
 #'
 #' Character specifying the plot type for the y-axis. This leads to
 #' using the `dataset`'s column "r_<y_plot_type>_<y_sel>" for the y-values.
+#' @param x_ref_line_num `[numeric(1)]`
+#'
+#' Numeric specifying the reference line for the x-axis.
+#' @param y_ref_line_num `[numeric(1)]`
+#'
+#' Numeric specifying the reference line for the y-axis.
+#' @param x_rng_lower `[numeric(1)]`
+#'
+#' Numeric specifying the lower point in the x-axis range.
+#' @param x_rng_upper `[numeric(1)]`
+#'
+#' Numeric specifying the upper point in the x-axis range.
+#' @param y_rng_lower `[numeric(1)]`
+#'
+#' Numeric specifying the lower point in the y-axis range.
+#' @param y_rng_upper `[numeric(1)]`
+#'
+#' Numeric specifying the upper point in the y-axis range.
 #'
 #' @return A plotly object specifying the generated eDISH plot.
 #'
@@ -243,11 +261,29 @@ generate_plot <- function(
     x_plot_type,
     y_plot_type,
     x_ref_line_num,
-    y_ref_line_num) {
+    y_ref_line_num,
+    x_rng_lower,
+    x_rng_upper,
+    y_rng_lower,
+    y_rng_upper) {
   if (is.null(dataset)) {
     return(dataset)
   }
 
+  # Prepare x-axis layout based on whether range has been specified
+  layout_xaxis <- list(title = paste0(sel_x, "/", x_plot_type))
+  if (!is.null(x_rng_lower) && !is.null(x_rng_upper)) {
+    layout_xaxis <- c(layout_xaxis,
+                      list(range = c(x_rng_lower, x_rng_upper)))
+  }
+
+  # Prepare y-axis layout based on whether range has been specified
+  layout_yaxis <- list(title = paste0(sel_y, "/", y_plot_type))
+  if (!is.null(y_rng_lower) && !is.null(y_rng_upper)) {
+    layout_yaxis <- c(layout_yaxis,
+                      list(range = c(y_rng_lower, y_rng_upper)))
+  }
+
   plt_obj <- dataset %>%
     plotly::plot_ly(type = "scatter", mode = "markers", color = .[[arm_var]]) %>%
     plotly::add_trace(
@@ -263,8 +299,8 @@ generate_plot <- function(
       hoverinfo = "text"
     ) %>%
     plotly::layout(
-      xaxis = list(title = paste0(sel_x, "/", x_plot_type)),
-      yaxis = list(title = paste0(sel_y, "/", y_plot_type)),
+      xaxis = layout_xaxis,
+      yaxis = layout_yaxis,
       shapes = list(
         list( # vline
           type = "line",

R/mod_edish.R

@@ -9,10 +9,13 @@ EDISH <- pack_of_constants(
   AXIS_LABEL = "Parameter:",
   X_REF_ID = "x_ref",
   Y_REF_ID = "y_ref",
+  X_RNG_ID = "x_rng",
+  Y_RNG_ID = "y_rng",
   REF_LABEL = "Reference line:",
   X_PLOT_TYPE_ID = "x_plot_type",
   Y_PLOT_TYPE_ID = "y_plot_type",
-  PLOT_TYPE_CHOICES = c("x ULN (eDISH)", "x Baseline (mDISH)"),
+  PLOT_TYPE_CHOICES = c("\u00d7 ULN (eDISH)" = "ULN",
+                        "\u00d7 Baseline (mDISH)" = "Baseline"),
   PLOT_ID = "plot",
   NO_PLOT = "noplot"
 )
@@ -59,6 +62,14 @@ edish_UI <- function(module_id) {
           max = 100,
           step = 0.5
         ),
+        shinyWidgets::numericRangeInput(
+          inputId = ns(EDISH$X_RNG_ID),
+          label = "Range",
+          value = c(NA, NA),
+          min = 0,
+          max = 100,
+          step = 0.1
+        ),
         shiny::radioButtons(
           inputId = ns(EDISH$X_PLOT_TYPE_ID),
           label = NULL,
@@ -79,6 +90,14 @@ edish_UI <- function(module_id) {
           max = 100,
           step = 0.5
         ),
+        shinyWidgets::numericRangeInput(
+          inputId = ns(EDISH$Y_RNG_ID),
+          label = "Range",
+          value = c(NA, NA),
+          min = 0,
+          max = 100,
+          step = 0.1
+        ),
         shiny::radioButtons(
           inputId = ns(EDISH$Y_PLOT_TYPE_ID),
           label = NULL,
@@ -269,9 +288,11 @@ edish_server <- function(
         dataset = plot_data(),
         subjectid_var = subjectid_var, arm_var = arm_var, visit_var = visit_var,
         sel_x = input[[EDISH$X_AXIS_ID]], sel_y = input[[EDISH$Y_AXIS_ID]],
-        x_plot_type = ifelse(grepl("eDISH", input[[EDISH$X_PLOT_TYPE_ID]]), "ULN", "Baseline"),
-        y_plot_type = ifelse(grepl("eDISH", input[[EDISH$Y_PLOT_TYPE_ID]]), "ULN", "Baseline"),
-        x_ref_line_num = input[[EDISH$X_REF_ID]], y_ref_line_num = input[[EDISH$Y_REF_ID]]
+        x_plot_type = input[[EDISH$X_PLOT_TYPE_ID]],
+        y_plot_type = input[[EDISH$Y_PLOT_TYPE_ID]],
+        x_ref_line_num = input[[EDISH$X_REF_ID]], y_ref_line_num = input[[EDISH$Y_REF_ID]],
+        x_rng_lower = input[[EDISH$X_RNG_ID]][1], x_rng_upper = input[[EDISH$X_RNG_ID]][2],
+        y_rng_lower = input[[EDISH$Y_RNG_ID]][1], y_rng_upper = input[[EDISH$Y_RNG_ID]][2]
       )
     )
 

tests/testthat/_snaps/05-mod_edish.md

@@ -39,20 +39,26 @@
       [1] "test 1"
 
       $input$`edish-x_plot_type`
-      [1] "x ULN (eDISH)"
+      [1] "ULN"
 
       $input$`edish-x_ref`
       [1] 3
 
+      $input$`edish-x_rng`
+      NULL
+
       $input$`edish-y_axis`
       [1] "test 2"
 
       $input$`edish-y_plot_type`
-      [1] "x ULN (eDISH)"
+      [1] "ULN"
 
       $input$`edish-y_ref`
       [1] 2
 
+      $input$`edish-y_rng`
+      NULL
+
       $input$`plotly_afterplot-A`
       [1] "\"edish-plot\""
 

tests/testthat/test-04-generate_plot.R

@@ -48,6 +48,10 @@ x_plot_type <- "ULN"
 y_plot_type <- "Baseline"
 x_ref_line_num <- 3
 y_ref_line_num <- 2
+x_rng_lower <- 0
+x_rng_upper <- 10
+y_rng_lower <- 0
+y_rng_upper <- 10
 
 # Invoke the function
 plt_obj <- generate_plot(
@@ -60,7 +64,11 @@ plt_obj <- generate_plot(
   x_plot_type = x_plot_type,
   y_plot_type = y_plot_type,
   x_ref_line_num = x_ref_line_num,
-  y_ref_line_num = y_ref_line_num
+  y_ref_line_num = y_ref_line_num,
+  x_rng_lower = x_rng_lower,
+  x_rng_upper = x_rng_upper,
+  y_rng_lower = y_rng_lower,
+  y_rng_upper = y_rng_upper
 )
 
 # Tests
@@ -110,6 +118,18 @@ test_that("the resulting plot object includes the correct reference lines" %>%
   expect_identical(actual_y1, y_ref_line_num)
 })
 
+test_that("the resulting plot object includes the correct axis range" %>%
+  vdoc[["add_spec"]](specs$plot_specs$axis_labels), {
+  actual_x <- plt_obj$x$layoutAttrs[[1]]$xaxis$range
+  actual_y <- plt_obj$x$layoutAttrs[[1]]$yaxis$range
+
+  expected_x <- c(x_rng_lower, x_rng_upper)
+  expected_y <- c(y_rng_lower, y_rng_upper)
+
+  expect_identical(actual_x, expected_x)
+  expect_identical(actual_y, expected_y)
+})
+
 test_that("the resulting plot object includes the correct coloring" %>%
   vdoc[["add_spec"]](specs$plot_specs$arm_coloring), {
   actual <- plt_obj$x$attrs[[1]]$color

tests/testthat/test-05-mod_edish.R

@@ -43,7 +43,7 @@ test_that("the app displays the correct plot at app launch (snapshot test)" %>%
   app$stop()
 })
 
-test_that("default settigns are visible after Single-Sign-On redirect", {
+test_that("default settings are visible after Single-Sign-On redirect", {
   skip("Cannot integrate SSO within unit tests, i.e., this test has to be performed manually.")
 })
 
@@ -56,33 +56,48 @@ test_that("the app's state is restored when bookmarking" %>%
   app_bmk <- shinytest2::AppDriver$new(
     app_dir = "./apps/bookmarking_app", name = "test_bookmarking"
   )
-
-  app$wait_for_idle()
+    
+  app_bmk$wait_for_idle()
 
   # Update values
   app_bmk$set_inputs(`edish-arm_id` = c("arm1", "arm2"))
   app_bmk$set_inputs(`edish-x_axis` = "test 2")
-  app_bmk$set_inputs(`edish-x_ref` = 3)
-  app_bmk$set_inputs(`edish-x_plot_type` = "x Baseline (mDISH)")
+  app_bmk$set_inputs(`edish-x_ref` = 3.5)
+  app_bmk$set_inputs(`edish-x_plot_type` = "Baseline")
+
+  # It is not possible to set shinyWidgets::numericalRangeInput using shinytest2
+  # We use an alternative approach by setting the url query part manually
+  # nolint start
+  # app_bmk$set_inputs(`edish-x_rng` = c(0.1, 5.1))
+  # app_bmk$set_inputs(`edish-y_rng` = c(0.1, 7.1))
+  # nolint end
+  range_url_part <- "&edish-x_rng=%5B0.1%2C5.1%5D&edish-y_rng=%5B0.1%2C7.1%5D"
 
   # Bookmark
   app_bmk$set_inputs(!!"._bookmark_" := "click") # nolint
 
   # Initialize bookmarked app
-  bmk_url <- app_bmk$get_value(export = "url")
-  app_rst <- shinytest2::AppDriver$new(app_dir = bmk_url, name = "test_restoring")
+  bmk_url <- app_bmk$get_value(export = "url")  
+
+  bmk_url_with_range <- paste0(bmk_url, range_url_part)
+  app_rst <- shinytest2::AppDriver$new(app_dir = bmk_url_with_range, name = "test_restoring")
+
+  app_rst$wait_for_idle()
 
   # Get values and test
-  actual <- app_rst$get_values(input = c("edish-arm_id", "edish-x_axis", "edish-x_plot_type", "edish-x_ref"))
+  actual <- app_rst$get_values(input = c("edish-arm_id", "edish-x_axis", "edish-x_plot_type", "edish-x_ref",
+                                         "edish-x_rng", "edish-y_rng"))
   expected <- list(
     input = list(
       `edish-arm_id` = c("arm1", "arm2"),
       `edish-x_axis` = "test 2",
-      `edish-x_plot_type` = "x Baseline (mDISH)",
-      `edish-x_ref` = 3
+      `edish-x_plot_type` = "Baseline",
+      `edish-x_ref` = 3.5,
+      `edish-x_rng` = c(0.1, 5.1),
+      `edish-y_rng` = c(0.1, 7.1)
     )
   )
-  testthat::expect_equal(actual, expected)
+  testthat::expect_identical(actual, expected)
 
   # Stop apps
   app_bmk$stop()