Jumping feature

.Rbuildignore

@@ -5,4 +5,6 @@
 ^docs$
 ^README\.html$
 ^LICENSE$
-^\.github
+^\.github
+^doc$
+^Meta$

.gitignore

@@ -11,4 +11,7 @@ vignettes/*\.html
 vignettes/*\.R
 inst/validation/results/val_param.rds
 inst/validation/results/val_report.html
-tests/testthat/app/shiny_bookmarks
+tests/testthat/app/shiny_bookmarks
+inst/doc
+/doc/
+/Meta/

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: dv.listings
 Type: Package
 Title: Data listings module
-Version: 4.0.1
+Version: 4.0.2
 Authors@R: 
     c(
       person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),
@@ -31,6 +31,7 @@ Imports:
     dplyr (>= 1.0.5),
     DT (>= 0.18),
     dv.manager (>= 2.0.0-17),
+    dv.papo (>= 2.0.1),
     htmlwidgets (>= 1.6.2),
     magrittr (>= 2.0.3),
     openxlsx (>= 4.2.5.2),
@@ -41,7 +42,7 @@ Imports:
     shinyjs (>= 2.1.0),
     shinyWidgets (>= 0.8.0),
     tibble (>= 3.2.1)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Roxygen: list(markdown = TRUE)
 Remotes: boehringer-ingelheim/dv.manager@main
 VignetteBuilder: knitr

NEWS.md

@@ -1,3 +1,7 @@
+# dv.listings 4.0.2
+
+- add jumping feature
+
 # dv.listings 4.0.1
 
 The module allows now to 

R/helpers.R

@@ -247,3 +247,34 @@ set_up_datatable <- function(dataset, selected_cols, pagination) {
     )
   )
 }
+
+#' Produce a warning for non-available receiver names
+#'
+#' @param receiver_id Character string defining the module that should receive a subject identifier
+#'   from clinlines.
+#' @param module_ids Vector of characters defining all available module IDs.
+#'
+#' @return Logical outcome of the test invisible.
+#' @keywords internal
+#'
+check_receiver <- function(receiver_id, module_ids) {
+  if (!is.null(receiver_id) && !receiver_id %in% module_ids) {
+    rlang::warn(
+      message = c(
+        "Clinical Timelines: You tried to point to a receiver module
+              that does not exist in your module list.",
+        x = paste0("You have set '", receiver_id, "' as receiver_id."),
+        i = paste0(
+          "Your module list contains ",
+          paste(module_ids, collapse = ", "),
+          "."
+        ),
+        i = "Have you spelled receiver_id correctly?"
+      )
+    )
+
+    return(invisible(FALSE))
+  }
+
+  return(invisible(TRUE))
+}

R/mod_listings.R

@@ -55,20 +55,20 @@ listings_UI <- function(module_id) { # nolint
             options = list(plugins = list("remove_button", "drag_drop"))
           ),
           shiny::actionButton(
-            ns(TBL$SELECT_ALL_COLS_BUTTON_ID), 
-            TBL$SELECT_ALL_COLS_BUTTON_LABEL, 
+            ns(TBL$SELECT_ALL_COLS_BUTTON_ID),
+            TBL$SELECT_ALL_COLS_BUTTON_LABEL,
             icon = shiny::icon("check-double")
           ),
           shiny::actionButton(
             ns(TBL$REMOVE_ALL_COLS_BUTTON_ID),
-            TBL$REMOVE_ALL_COLS_BUTTON_LABEL, 
+            TBL$REMOVE_ALL_COLS_BUTTON_LABEL,
             icon = shiny::icon("xmark")
           ),
           shiny::actionButton(
             ns(TBL$RESET_COLS_DEFAULT_BUTTON_ID),
-            TBL$RESET_COLS_DEFAULT_BUTTON_LABEL, 
+            TBL$RESET_COLS_DEFAULT_BUTTON_LABEL,
             icon = shiny::icon("rotate-left")
-          ), 
+          ),
           circle = FALSE,
           icon = shiny::icon("cog"),
           width = TBL$DRPDBUTTON_WIDTH,
@@ -86,6 +86,7 @@ listings_UI <- function(module_id) { # nolint
     ),
     shiny::br(),
     DT::dataTableOutput(ns(TBL$TABLE_ID), height = "80vh"),
+    shiny::verbatimTextOutput(ns("tst1"))
   )
 }
 
@@ -111,13 +112,31 @@ listings_UI <- function(module_id) { # nolint
 #' @param intended_use_label `[character(1) | NULL]` Either a string indicating the intended use for export, or
 #' NULL. The provided label will be displayed prior to the download and will also be included in the exported file.
 #'
+#' @param subjid_var `[character(1)]`
+#'
+#' Column corresponding to subject ID. Default value is 'USUBJID'
+#'
+#' @param receiver_id `[character(1) | NULL]`
+#'
+#' Character string defining the ID of the module to which to send a subject ID. The
+#' module must exist in the module list. The default is NULL which disables communication.
+#'
+#' @param afmm_param `[list(2+) | NULL]`
+#'
+#' Named list of a selection of arguments from module manager. Expects
+#' at least two elements: \code{utils} and \code{module_names} defining a character vector
+#' whose entries have the corresponding module IDs as names.
+#'
 #' @export
 listings_server <- function(module_id,
                             dataset_list,
                             default_vars = NULL,
                             dataset_metadata,
                             pagination = NULL,
-                            intended_use_label = NULL) {
+                            intended_use_label = NULL,
+                            subjid_var = "USUBJID",
+                            receiver_id = NULL,
+                            afmm_param = NULL) {
   checkmate::assert(
     checkmate::check_character(module_id, min.chars = 1),
     checkmate::check_multi_class(dataset_list, c("reactive", "shinymeta_reactive")),
@@ -127,6 +146,8 @@ listings_server <- function(module_id,
     checkmate::check_subset(names(dataset_metadata), choices = c("name", "date_range")),
     checkmate::check_logical(pagination, null.ok = TRUE),
     checkmate::check_string(intended_use_label, null.ok = TRUE),
+    checkmate::check_string(receiver_id, min.chars = 1, null.ok = TRUE),
+    checkmate::check_list(afmm_param, null.ok = TRUE),
     combine = "and"
   )
   if (!is.null(default_vars)) {
@@ -142,6 +163,13 @@ listings_server <- function(module_id,
     # Set choices as a reactive value item
     rvs <- shiny::reactiveValues(dataset_choices = NA, variable_choices = NA)
 
+    shiny::observe({
+      shiny::req(afmm_param$module_names)
+
+      # Check availability of receiver id
+      check_receiver(receiver_id, names(afmm_param$module_names))
+    })
+
     # Listing selection (start)
     shiny::observeEvent(v_dataset_list(), {
       # Fill default in case bookmark or default columns do not have all the listings in the dataset
@@ -152,6 +180,7 @@ listings_server <- function(module_id,
       } else {
         bmk_dataset
       }
+
       bmk_dataset <<- NULL
 
       rvs$dataset_choices <- generate_choices(v_dataset_list())
@@ -340,14 +369,34 @@ listings_server <- function(module_id,
               action = htmlwidgets::JS(js)
             )
           )
-        )
+        ),
+        selection = "single"
       )
     })
-
-
+
+    # start: jumping feature --------------------------------------------------
+    if (!is.null(receiver_id)) {
+      selected_subject_id <- shiny::reactiveVal()
+
+      shiny::observeEvent(input[[paste0(TBL$TABLE_ID, "_rows_selected")]], {
+        row_index <- input[[paste0(TBL$TABLE_ID, "_rows_selected")]]
+        subject <- listings_data()[[subjid_var]][row_index] |> as.character()
+
+        selected_subject_id(subject)
+        afmm_param$utils$switch2mod(receiver_id)
+      })
+
+      # N.B papo requires a list containing an element named 'subj_id', hence:
+      subject <- list(subj_id = selected_subject_id)
+      return(subject)
+    }
+
+    # end: jumping feature ----------------------------------------------------
+
     shiny::exportTestValues(
       selected_columns_in_dataset = r_selected_columns_in_dataset()
     )
+
   })
 }
 
@@ -423,14 +472,12 @@ mod_listings <- function(
     default_vars = NULL,
     pagination = NULL,
     intended_use_label = "Use only for internal review and monitoring during the conduct of clinical trials.",
-    dataset_disp) {
+    dataset_disp,
+    subjid_var = "USUBJID",
+    receiver_id = NULL) {
   # Check validity of parameters
-  if (!missing(dataset_names)) {
-    checkmate::assert_character(dataset_names)
-  }
-  if (!missing(dataset_disp)) {
-    checkmate::assert_list(dataset_disp, types = "character")
-  }
+  if (!missing(dataset_names)) checkmate::assert_character(dataset_names)
+  if (!missing(dataset_disp)) checkmate::assert_list(dataset_disp, types = "character")
 
   # skip assertions/checks for module_id and default_vars since they will be checked directly in listings_server()
   if (!missing(dataset_disp)) {
@@ -452,6 +499,7 @@ mod_listings <- function(
   } else {
     use_disp <- TRUE
   }
+
 
   mod <- list(
     ui = function(module_id) {
@@ -472,7 +520,10 @@ mod_listings <- function(
         dataset_metadata = afmm$dataset_metadata,
         pagination = pagination,
         module_id = module_id,
-        intended_use_label = intended_use_label
+        intended_use_label = intended_use_label,
+        subjid_var = subjid_var,
+        receiver_id = receiver_id,
+        afmm_param = list(utils = afmm$utils, module_names = afmm$module_names)
       )
     },
     module_id = module_id

README.md

@@ -112,3 +112,7 @@ To download the currently active listing, it will be saved exactly as it appears
 For users who wish to download all listings, the module allows saving in .xlsx format exclusively. This process disregards any local filters, and each listing is saved in a separate worksheet within the file. 
 
 Please be aware that the PDF download feature is implemented using an RMarkdown file that is rendered into a PDF through LaTeX. As such, it is important to note that a LaTeX installation, along with the necessary packages, is required to use this feature.
+
+## Jumping Feature
+
+Users can select a row from listings table to jump to a patient profile of the subject. The row turns blue once selected and remains grey on hover. To see a working example, please consult "Communication_jumping_feature" vignette.

inst/validation/specs.R

@@ -16,7 +16,8 @@ listing <- specs_list(
   "select_all_columns" = "dv.listings includes functionality to select all the columns.",
   "unselect_all_columns" = "dv.listings includes functionality to unselect all the columns.",
   "reset_columns" = "dv.listings includes includes functionality to reset to the default columns.",
-  "reset_filters" = "dv.listings includes functionality to reset all filters."
+  "reset_filters" = "dv.listings includes functionality to reset all filters.",
+  "jumping_feature" = "dv.listings includes jumping feature."
 )
 export <- specs_list(
   "export" = "dv.listings includes a button to export the listing(s). A click to the button envokes a pop-up to appear that allows the user to decide whether the download should only contain the displayed listing or all available listings, provide a file name (defaulted to the dataset name), and select from available file types.",