Merge pull request #12 from Boehringer-Ingelheim/rc/1.1.0

Rc/1.1.0

Author: iglauss

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: dv.clinlines
 Title: DaVinci's Clinical Timelines
-Version: 1.0.4
+Version: 1.1.0
 Authors@R:
     c(
       person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),
@@ -21,7 +21,7 @@ Imports:
     bslib (>= 0.6.1),
     checkmate (>= 2.3.1),
     dplyr (>= 1.1.0),
-    dv.manager (>= 2.1.0),
+    dv.manager (>= 2.1.4),
     ggplot2 (>= 3.4.4),
     lubridate (>= 1.9.3),
     magrittr (>= 2.0.3),
@@ -46,7 +46,6 @@ Suggests:
     testthat (>= 3.2.1)
 Config/testthat/edition: 3
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
-Remotes: boehringer-ingelheim/dv.manager@v2.1.2
+RoxygenNote: 7.3.2
+Remotes: boehringer-ingelheim/dv.manager@v2.1.4
 VignetteBuilder: knitr
-

NAMESPACE

@@ -4,6 +4,7 @@ export("%>%")
 export(default_basic_info)
 export(default_drug_admin)
 export(default_mapping)
+export(mock_clinical_timelines_app)
 export(mock_with_mm_app)
 export(mod_clinical_timelines)
 export(mod_clinical_timelines_UI)

NEWS.md

@@ -1,3 +1,11 @@
+# dv.clinlines 1.1.0
+
+* Display drug administration information in different colors, depending on the treatment name.
+* Allow for customized color palettes.
+* Use dv.manager's switch2mod() instead of deprecated switch2() function.
+* Export mock app.
+* Fix error occurring in case only timepoints (i.e., no intervals) are specified.
+
 # dv.clinlines 1.0.4
 
 * Adapt basic_info, filter, and drug_admin parameter to adhere module standard

R/data_prep.R

@@ -19,9 +19,11 @@ prep_data <- function(data_list,
                       drug_admin = default_drug_admin(),
                       subjid_var = "USUBJID",
                       filter = NULL) {
+
   if (is.null(drug_admin)) {
     empty_drug_admin <- data.frame(
       subjects = character(),
+      treatment = character(),
       start = lubridate::ymd_hm(),
       end = lubridate::ymd_hm(),
       details = character(),
@@ -34,6 +36,7 @@ prep_data <- function(data_list,
 
     drug_admin <- list(
       dataset_name = "no_da",
+      trt_var = "treatment",
       start_var = "start",
       end_var = "end",
       detail_var = "details",
@@ -324,11 +327,14 @@ set_events_intern <- function(data_list, mapping = default_mapping(), subjid_var
 set_exp_intervals <- function(data_list, mapping = default_drug_admin(), subjid_var) {
   col_list <- mapping[!names(mapping) %in% c("dataset_name")]
 
-  cols <- c(col_list$start_var, col_list$end_var, col_list$detail_var)
+  cols <- c(col_list$start_var, col_list$end_var, col_list$detail_var, col_list$trt_var)
   data <- data_list[[mapping$dataset_name]]
 
+  check_names(data, cols, subjid_var)
+  check_date_type(data, c(col_list$start_var, col_list$end_var))
+
   data <- data %>%
-    dplyr::group_by(get(subjid_var)) %>%
+    dplyr::group_by(get(subjid_var), get(col_list$trt_var)) %>%
     dplyr::mutate(
       exp_dose = dplyr::case_when(
         is.na(dplyr::lag(get(col_list$dose_var))) ~ "start/equal",
@@ -338,22 +344,25 @@ set_exp_intervals <- function(data_list, mapping = default_drug_admin(), subjid_
       )
     ) %>%
     dplyr::ungroup()
-
-  check_names(data, cols, subjid_var)
-  check_date_type(data, c(col_list$start_var, col_list$end_var))
-
   interval_df <- data %>%
     dplyr::mutate(
       detail_var = paste(
         .data[[col_list$detail_var]], "-",
         .data[[col_list$dose_var]],
         .data[[col_list$dose_unit_var]]
-      )
+      ),
+      trt_var = .data[[col_list$trt_var]]
     ) %>%
     dplyr::select(
-      tidyselect::all_of(c(subjid_var, cols[1:2], "set_id", "exp_dose", "detail_var"))
+      tidyselect::all_of(c(subjid_var, cols[1:2], "set_id", "exp_dose", "detail_var", "trt_var"))
+    ) %>%
+    dplyr::mutate(
+      group = dplyr::if_else(
+        !is.na(.data[["trt_var"]]),
+        paste0(col_list$label, ": ", .data[["trt_var"]]),
+        NA
+      )
     ) %>%
-    tibble::add_column(group = rep(col_list$label)) %>%
     dplyr::rename(
       start_exp = tidyselect::all_of(col_list$start_var),
       end_exp = tidyselect::all_of(col_list$end_var)

R/helpers.R

@@ -77,25 +77,28 @@ set_event <- function(start_dt_var,
 #'
 #' @param dataset_name Character name of the data frame that holds drug administration data
 #'   (e.g. ex domain) as it is called in the \code{data_list} parameter.
+#' @param trt_var Character name of the variable that contains the treatment name.
+#'   Must be present in the data frame mentioned in the \code(dataset_name) element.
 #' @param start_var Character name of the variable that contains the start dates
-#'   (e.g. exposure start dates). Must be present in the data frame mentioned in the name
-#'   element.
+#'   (e.g. exposure start dates). Must be present in the data frame mentioned in the
+#'   \code(dataset_name) element.
 #' @param end_var Character name of the variable that contains the end dates
-#'   (e.g. exposure start dates). Must be present in the data frame mentioned in the name
-#'   element.
+#'   (e.g. exposure start dates). Must be present in the data frame mentioned in the
+#'   \code(dataset_name) element.
 #' @param detail_var Character name of the variable that contains the treatment
-#' information. Must exist in the dataset mentioned in the name element.
+#' information. Must exist in the dataset mentioned in the \code(dataset_name) element.
 #' @param label Free-text character label for the drug administration event.
 #' @param dose_var Character name of the variable that contains the dosis level
-#' information. Must exist in the dataset mentioned in the name element.
+#' information. Must exist in the dataset mentioned in the \code(dataset_name) element.
 #' @param dose_unit_var Character name of the variable that contains the dosis unit.
-#' Must exist in the dataset mentioned in the name element.
+#' Must exist in the dataset mentioned in the \code(dataset_name) element.
 #'
 #' @return A list that could directly be used as input for the \code{drug_admin} parameter
 #'   of \code{mod_clinical_timelines()} and \code{mod_clinical_timelines_server()}.
 #' @export
 #'
 set_drug_admin <- function(dataset_name,
+                           trt_var,
                            start_var,
                            end_var,
                            detail_var,
@@ -105,6 +108,7 @@ set_drug_admin <- function(dataset_name,
   return(
     list(
       dataset_name = dataset_name,
+      trt_var = trt_var,
       start_var = start_var,
       end_var = end_var,
       detail_var = detail_var,

R/mock_clinical_timelines.R

@@ -10,7 +10,7 @@ mock_clinical_timelines_UI <- function(id = NULL) { # nolint
 
   ui <- shiny::fluidPage(
     theme = bslib::bs_theme(version = "4"),
-    shiny::tags$h1("BI Clinical Timelines", class = "mod-title"),
+    shiny::tags$h1("DaVinci's Clinical Timelines Module", class = "mod-title"),
     mod_clinical_timelines_UI(
       ns("clin_tl"),
       list("serious_ae_var", "soc_var", "pref_term_var", "drug_rel_ae_var")
@@ -69,6 +69,7 @@ mock_clinical_timelines_server <- function(input, output, session) {
     ),
     drug_admin = list(
       dataset_name = "exp",
+      trt_var = "EXTRT",
       start_var = "EXSTDTC",
       end_var = "EXENDTC",
       detail_var = "EXTRT",
@@ -87,6 +88,7 @@ mock_clinical_timelines_server <- function(input, output, session) {
         drug_rel_ae_var = "AEREL"
       )
     ),
+    start_day = -5,
     ms = 50
   )
 }
@@ -98,6 +100,7 @@ mock_clinical_timelines_server <- function(input, output, session) {
 #' \code{mock_clinical_timelines_app()} runs the \pkg{dv.clinlines} module
 #' with dummy data. Local adverse event filters included.
 #'
+#' @export
 mock_clinical_timelines_app <- function() {
   shiny::shinyApp(
     ui = mock_clinical_timelines_UI,

R/mock_with_mm.R

@@ -4,17 +4,15 @@
 #' module manager surface. Displays data from the \pkg{pharmaverseadam} package.
 #'
 #' @export
-#' @keywords internal
-#'
 mock_with_mm_app <- function() {
-  # Specifiy dataset list for modulemanager
+  # Specifiy dataset list for module manager
   dataset_list <- list(
     dummyData1 = prep_dummy_data(20),
     dummyData2 = prep_dummy_data(200)
   )
 
 
-  # Define module list for modulemanager
+  # Define module list for module manager
   module_list <- list(
     "Clinical Timelines" = mod_clinical_timelines(
       module_id = "mod1",
@@ -60,6 +58,7 @@ mock_with_mm_app <- function() {
       ),
       drug_admin = list(
         dataset_name = "exp",
+        trt_var = "EXTRT",
         start_var = "EXSTDTC",
         end_var = "EXENDTC",
         detail_var = "EXTRT",
@@ -84,6 +83,16 @@ mock_with_mm_app <- function() {
         start_day = -5,
         boxheight_val = 60
       )
+      # nolint start: commented_code_linter
+      # color_palette = c(
+      #   "Treatment End" = "blue",
+      #   "Treatment Start" = "red",
+      #   "Drug Administration: PLACEBO" = "yellow",
+      #   "Drug Administration: XANOMELINE" = "green",
+      #   "Informed Consent" = "purple",
+      #   "Adverse Events" = "orange"
+      # )
+      # nolint end
     )
   )
 

R/mod_clinical_timelines.R

@@ -105,6 +105,7 @@ mod_clinical_timelines_server <- function(module_id,
                                           filter = NULL,
                                           subjid_var = "USUBJID",
                                           start_day = NULL,
+                                          color_palette = NULL,
                                           ms = 1000,
                                           receiver_id = NULL,
                                           afmm_param = NULL) {
@@ -137,7 +138,13 @@ mod_clinical_timelines_server <- function(module_id,
   checkmate::assert_list(drug_admin, types = "character", null.ok = TRUE, add = ac)
   checkmate::assert_subset(
     names(drug_admin),
-    choices = c("dataset_name", "start_var", "end_var", "detail_var", "label", "dose_var", "dose_unit_var"),
+    choices = c(
+      "dataset_name",
+      "trt_var",
+      "start_var", "end_var",
+      "detail_var", "label",
+      "dose_var", "dose_unit_var"
+    ),
     add = ac
   )
   checkmate::assert_list(filter, types = "list", null.ok = TRUE, add = ac)
@@ -153,7 +160,10 @@ mod_clinical_timelines_server <- function(module_id,
   checkmate::assert_numeric(ms, len = 1, add = ac)
   checkmate::assert_string(receiver_id, min.chars = 1, null.ok = TRUE, add = ac)
   checkmate::assert_list(afmm_param, null.ok = TRUE, add = ac)
+  checkmate::assert_character(color_palette, null.ok = TRUE, add = ac)
+  checkmate::assert_character(names(color_palette), null.ok = TRUE, unique = TRUE, add = ac)
   checkmate::reportAssertions(ac)
+  check_valid_color(color_palette)
 
   shiny::moduleServer(
     module_id,
@@ -201,7 +211,9 @@ mod_clinical_timelines_server <- function(module_id,
 
       # Set a fixed color for each group
       colors_groups <- shiny::reactive({
-        if (nrow(pre_data()) > 0) color_lookup(unique(pre_data()$group))
+        if (nrow(pre_data()) > 0) {
+          color_lookup(unique(pre_data()$group), color_palette)
+        }
       })
 
       # Add adverse event data that are relevant for filtering
@@ -239,7 +251,7 @@ mod_clinical_timelines_server <- function(module_id,
             type = "message"
           )
         } else if (!is.null(receiver_id)) {
-          afmm_param$utils$switch2(afmm_param$module_names[[receiver_id]])
+          afmm_param$utils$switch2mod(receiver_id)
         }
       })
 
@@ -294,7 +306,11 @@ mod_clinical_timelines_server <- function(module_id,
 #' (defaults to NULL, using the day of the earliest event to be displayed),
 #' \code{boxheight_val} contains a value between 30 and 150 defining the initial height of
 #' the individual timeline plot boxes at app launch (defaults to 60).
+#' @param color_palette `[character(1+) | NULL]`
 #'
+#' A named vector that specifies the colors for drawing events or intervals.
+#' Each name in the vector should correspond to an entry in the legend.
+#' If \code{NULL} (default), the default color palette is used.
 #' @param ms `[numeric(1)]`
 #'
 #' Single numeric value indicating how many milliseconds to wait before the plot
@@ -377,19 +393,22 @@ mod_clinical_timelines_server <- function(module_id,
 #'   \item{\code{dataset_name}: Character name of the dataset that holds drug administration data
 #'     (e.g. ex domain), as it is called in the datalist that is provided to the
 #'     \pkg{modulemanager}.}
+#'   \item{\code{trt_var}: Character name of the variable that contains the
+#'     treatment name which must be present in the dataset mentioned in the
+#'     \code{dataset_name} element.}
 #'   \item{\code{start_var}: Character name of the variable that contains the start dates
 #'     (e.g. exposure start dates) which must be present in the dataset mentioned in the
-#'     \code{name} element.}
+#'     \code{dataset_name} element.}
 #'   \item{\code{end_var}: Character name of the variable that contains the end dates
 #'     (e.g. exposure end dates) which must be present in the dataset mentioned in the
-#'     \code{name} element.}
+#'     \code{dataset_name} element.}
 #'   \item{\code{detail_var}: Character name of the variable that contains the treatment
-#'     information. Must exist in the dataset mentioned in the \code{name} element.}
+#'     information. Must exist in the dataset mentioned in the \code{dataset_name} element.}
 #'   \item{\code{label}: Free-text character label for the drug administration event.}
 #'   \item{\code{dose_var}: Character name of the variable that contains the dosis level
-#'     information. Must exist in the dataset mentioned in the \code{name} element.}
+#'     information. Must exist in the dataset mentioned in the \code{dataset_name} element.}
 #'   \item{\code{dose_unit_var}: Character name of the variable that contains the dosis
-#'     unit. Must exist in the dataset mentioned in the \code{name} element.}
+#'     unit. Must exist in the dataset mentioned in the \code{dataset_name} element.}
 #' }
 #'
 #' \cr
@@ -443,6 +462,7 @@ mod_clinical_timelines <- function(module_id,
                                      start_day = NULL,
                                      boxheight_val = 60
                                    ),
+                                   color_palette = NULL,
                                    ms = 1000,
                                    receiver_id = NULL) {
   # Check validity of arguments that won't be checked in UI/server
@@ -481,6 +501,7 @@ mod_clinical_timelines <- function(module_id,
         filter = filter,
         subjid_var = subjid_var,
         start_day = default_plot_settings$start_day,
+        color_palette = color_palette,
         ms = ms,
         receiver_id = receiver_id,
         afmm_param = list(utils = afmm$utils, module_names = afmm$module_names)

R/mod_main_view.R

@@ -194,9 +194,19 @@ mod_main_view_server <- function(module_id, initial_data, changed,
           cache$date_day_range <<- list(
             date = c(
               min(initial_data()$date_min),
-              max(c(initial_data()$end_dt_var, initial_data()$end_exp), na.rm = TRUE)
+              max(c(
+                initial_data()$start_dt_var,
+                initial_data()$end_dt_var,
+                initial_data()$start_exp,
+                initial_data()$end_exp
+              ), na.rm = TRUE)
             ),
-            day = c(start_day, max(c(initial_data()$end_dy_var, initial_data()$end_exp_day), na.rm = TRUE))
+            day = c(start_day, max(c(
+              initial_data()$start_dy_var,
+              initial_data()$end_dy_var,
+              initial_data()$start_exp_day,
+              initial_data()$end_exp_day
+            ), na.rm = TRUE))
           )
         }
 
@@ -358,6 +368,22 @@ mod_main_view_server <- function(module_id, initial_data, changed,
         subject
       })
 
+      testing <- isTRUE(getOption("shiny.testmode"))
+      if (testing) {
+        subject_id_orig <- subject_id
+
+        trigger <- shiny::reactiveVal(0)
+        shiny::observeEvent(input[["debug_select_subject"]], trigger(trigger() + 1))
+        subject_id <- shiny::reactive({
+          res <- NULL
+          if (trigger()) {
+            res <- shiny::isolate(input[["debug_select_subject"]])
+          } else {
+            res <- subject_id_orig()
+          }
+          return(res)
+        })
+      }
 
       # For exchange with receiver module
       return(