Merge pull request #24 from Boehringer-Ingelheim/280738-week-labels

280738 week labels

Author: zsigmas

.github/workflows/ci.yml

@@ -10,6 +10,7 @@ on:
       - ready_for_review
     branches:
       - main
+      - test
   push:
   workflow_dispatch:
 

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: dv.papo
 Title: Patient Profile
-Version: 2.0.1-9008
+Version: 2.0.1-9009
 Date: 2024-08-13
 Authors@R: 
     c(person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),
@@ -21,7 +21,7 @@ License: Apache License (>= 2)
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.2
+RoxygenNote: 7.3.1
 Depends: 
     R (>= 4.1.0)
 Imports:

NEWS.md

@@ -1,3 +1,8 @@
+# dv.papo 2.0.1-9009
+- x axis in the plots can now show `weeks` or `days` units
+- number of x axis breaks or an specific set of breaks can now be specified
+- Update to provide early error feedback if a sender_id is not available in list of modules.
+
 # dv.papo 2.0.1-9008
 
 - Improves SAE label positioning.

R/check_papo_call_manual.R

@@ -195,6 +195,26 @@ check_papo_call <- function(datasets, module_id, subject_level_dataset_name, sub
     palette <- plots[["palette"]]
     range_plots <- plots[["range_plots"]]
     value_plots <- plots[["value_plots"]]
+    x_axis_unit <- plots[["x_axis_unit"]]
+    x_axis_breaks <- plots[["x_axis_breaks"]]
+
+    assert_err(
+      checkmate::test_subset(x_axis_unit, choices = as.character(CONST$PLOT_X_AXIS_UNITS), empty.ok = FALSE) ||
+      is.null(x_axis_unit),
+      sprintf("`plots$x_axis_unit` must be `NULL` or one of [%s]", paste('"', CONST$PLOT_X_AXIS_UNITS,'"', collapse = ", "))
+    )
+
+    assert_err(
+      checkmate::test_numeric(x_axis_breaks, min.len = 1, null.ok = TRUE, any.missing = FALSE),
+      "`plots$x_axis_breaks` must NULL or a numeric vector with no NA values"
+    )
+
+    if(length(x_axis_breaks) == 1) {
+      assert_err(
+        checkmate::test_integerish(x_axis_breaks, len = 1, tol = 0, lower = 1, null.ok = TRUE),
+        "when a single value is passed`plots$x_axis_breaks` must NULL or an integer larger or equal than 1"
+      )
+    }
 
     # timeline_info
     if (assert_err(

R/create_plots.R

@@ -8,7 +8,7 @@
 #'
 #' @return A ggplot2 object
 create_ae_cm_plot <- function(data, x_limits, palette, sl_info, vline_vars, vline_day_numbers,
-                              ref_date) {
+                              x_axis_unit, x_axis_breaks, ref_date) {
   # set column for title banner
   data[["title_banner"]] <- " "
 
@@ -104,12 +104,54 @@ create_ae_cm_plot <- function(data, x_limits, palette, sl_info, vline_vars, vlin
   )
 
   as_CDISC_days <- function(days) days + (days >= 0)
-  p <- p + ggplot2::scale_x_continuous(
-    labels = function(days) {
+
+  if (x_axis_unit == CONST$PLOT_X_AXIS_UNITS$DAYS) {
+    if (length(x_axis_breaks) == 1) {
+      breaks <- base::pretty(x_limits_z, n = x_axis_breaks)
+    } else {
+      breaks <- x_axis_breaks
+    }
+
+    lbl_fn <- function(days) {
       dates <- ref_date + days
       days <- as_CDISC_days(days)
       sprintf("%s\nDay %s", dates, days)
-    },
+    }
+  } else if (x_axis_unit == CONST$PLOT_X_AXIS_UNITS$WEEKS) {
+    if (length(x_axis_breaks) == 1) {
+      # Calculates the breaks in weeks and move them back to days, round in case we incurr in a numerical error
+      breaks <- round(base::pretty(x_limits_z / 7, n = x_axis_breaks) * 7)
+      # Only return values within limits otherwise the appear in the labels as NA
+      breaks <- breaks[breaks >= x_limits_z[[1]] & breaks <= x_limits_z[[2]]]
+    } else {
+      breaks <- x_axis_breaks * 7
+    }
+
+    lbl_fn <- function(days) {
+      dates <- ref_date + days
+      days_z <- days
+      days <- as_CDISC_days(days)
+      labels <- vector(mode = "character", length = length(days))
+
+      for (idx in seq_along(days)) {
+        day <- days[[idx]]
+        day_z <- days_z[[idx]]
+        date <- dates[[idx]]
+        if (day_z == 0) {
+          labels[[idx]] <- sprintf("%s\nDay %s", date, day)
+        } else {
+          labels[[idx]] <- sprintf("%s\nWeek %s", date, day_z / 7)
+        }
+      }
+      return(labels)
+    }
+  } else {
+    stop("Unknown x_axis_unit")
+  }
+
+  p <- p + ggplot2::scale_x_continuous(
+    labels = lbl_fn,
+    breaks = breaks,
     limits = x_limits_z
   )
 
@@ -135,7 +177,7 @@ create_ae_cm_plot <- function(data, x_limits, palette, sl_info, vline_vars, vlin
 #'
 #' @return A ggplot2 object
 create_lb_vs_plot <- function(data, date, val, low_limit, high_limit, param, summary_stats, x_limits,
-                              palette, sl_info, vline_vars, vline_day_numbers, ref_date) {
+                              x_axis_unit, x_axis_breaks, palette, sl_info, vline_vars, vline_day_numbers, ref_date) {
   # NOTE(miguel): The following song and dance courtesy of plotly::layout not supporting dates on axes
   # column names that end with '_z' are days that represent ref_date as zero (unlike CDISC)
   data[["date_z"]] <- as.numeric(as.Date(data[[date]]) - ref_date)
@@ -193,7 +235,6 @@ create_lb_vs_plot <- function(data, date, val, low_limit, high_limit, param, sum
   plot <- plot + ggplot2::scale_color_manual(name = "Legend", values = palette)
   plot <- plot + ggplot2::scale_fill_manual(name = "Legend", values = palette)
 
-  as_CDISC_days <- function(days) days + (days >= 0)
 
   # get facet plots and set formats
   plot <- plot + ggplot2::facet_wrap(ggplot2::vars(.data[[param]]), ncol = 1, scales = "free_y") +
@@ -203,16 +244,60 @@ create_lb_vs_plot <- function(data, date, val, low_limit, high_limit, param, sum
       axis.text.y = ggplot2::element_text(size = 7), # y-axis text size
       strip.text = ggplot2::element_text(size = 6), # title text/banner size
       panel.spacing.y = ggplot2::unit(0, "lines") # distance between plots in facet_wrap
-    ) +
-    ggplot2::xlab("") + ggplot2::ylab("") +
-    ggplot2::scale_x_continuous(
-      labels = function(days) {
-        dates <- ref_date + days
-        days <- as_CDISC_days(days)
-        sprintf("%s\nDay %s", dates, days)
-      },
-      limits = x_limits_z
     )
+  ggplot2::xlab("") + ggplot2::ylab("")
+
+  as_CDISC_days <- function(days) days + (days >= 0)
+
+  if (x_axis_unit == CONST$PLOT_X_AXIS_UNITS$DAYS) {
+    if (length(x_axis_breaks) == 1) {
+      breaks <- base::pretty(x_limits_z, n = x_axis_breaks)
+    } else {
+      breaks <- x_axis_breaks
+    }
+
+    lbl_fn <- function(days) {
+      dates <- ref_date + days
+      days <- as_CDISC_days(days)
+      sprintf("%s\nDay %s", dates, days)
+    }
+  } else if (x_axis_unit == CONST$PLOT_X_AXIS_UNITS$WEEKS) {
+    if (length(x_axis_breaks) == 1) {
+      # Calculates the breaks in weeks and move them back to days, round in case we incurr in a numerical error
+      breaks <- round(base::pretty(x_limits_z / 7, n = x_axis_breaks) * 7)
+      # Only return values within limits otherwise the appear in the labels as NA
+      breaks <- breaks[breaks >= x_limits_z[[1]] & breaks <= x_limits_z[[2]]]
+    } else {
+      breaks <- x_axis_breaks * 7
+    }
+
+    lbl_fn <- function(days) {
+      dates <- ref_date + days
+      days_z <- days
+      days <- as_CDISC_days(days)
+      labels <- vector(mode = "character", length = length(days))
+
+      for (idx in seq_along(days)) {
+        day <- days[[idx]]
+        day_z <- days_z[[idx]]
+        date <- dates[[idx]]
+        if (day_z == 0) {
+          labels[[idx]] <- sprintf("%s\nDay %s", date, day)
+        } else {
+          labels[[idx]] <- sprintf("%s\nWeek %s", date, day_z / 7)
+        }
+      }
+      return(labels)
+    }
+  } else {
+    stop("Unknown x_axis_unit")
+  }
+
+  p <- p + ggplot2::scale_x_continuous(
+    labels = lbl_fn,
+    breaks = breaks,
+    limits = x_limits_z
+  )
 
   # HACK: Offset the limits of the y axis to account for label strips
   # TODO: Remove during transition away from ggplot2+plotly

R/global_params.r

@@ -12,5 +12,10 @@ CONST <- poc(
     `MILD` = "lightgreen", `MODERATE` = "gold1", `SEVERE` = "red",
     `Mild` = "lightgreen", `Moderate` = "gold1", `Severe` = "red",
     `mild` = "lightgreen", `moderate` = "gold1", `severe` = "red"
-  )
+  ),
+  PLOT_X_AXIS_UNITS = poc(
+    DAYS = "days",
+    WEEKS = "weeks"
+  ),
+  PLOT_X_AXIS_DEFAULT_NUMBER_OF_BREAKS = 5
 )

R/mock_patient_profile.R

@@ -72,6 +72,8 @@ mock_patient_profile_server <- function(input, output, session) {
       "Concomitant Medication" = list(dataset = "cm", default_vars = NULL)
     ),
     plots = list(
+      x_axis_unit = "weeks", # Week or Date
+      x_axis_breaks = 20, # x axis by
       timeline_info = c(
         trt_start_date = "TRTSDT",
         trt_end_date = "TRTEDT",

R/mod_API.R

@@ -17,6 +17,8 @@ mod_patient_profile_API_docs <- list(
   ),
   plots = list(
     "Plot section",
+    x_axis_unit = "Defines the units of the x axis in the plots",
+    x_axis_breaks = "When a single integer is passed it will use `base::pretty` to compute a set of breakpoints. If more than one value is passed it will use those breaks in the x axis",
     timeline_info = list(
       "Start and end study dates",
       icf_date = "Informed Consent Form signing Date",
@@ -72,6 +74,8 @@ mod_patient_profile_API <- T_group(
     default_vars = T_col("dataset") |> T_flag("optional", "zero_or_more", "as_array")
   ) |> T_flag("optional", "zero_or_more", "named"),
   plots = T_group(
+    x_axis_unit = T_character() |> T_flag("optional"),
+    x_axis_breaks = T_integer(min = 1) |> T_flag("optional", "zero_or_more", "as_array"),
     timeline_info = T_group(
       icf_date = T_col("subject_level_dataset_name", T_or(T_date(), T_datetime())) |> T_flag("optional"),
       trt_start_date = T_col("subject_level_dataset_name", T_or(T_date(), T_datetime())),

R/mod_listing.R

@@ -12,14 +12,16 @@ patient_listing_UI <- function(id) { # nolint
     shiny::tags$head(
       shiny::tags$style(
         shiny::HTML(
-          paste(".btn-papo_listing_data_selector_status:active,",
-                ".btn-papo_listing_data_selector_status.active,",
-                ".open>.btn-papo_listing_data_selector_status.dropdown-toggle {
+          paste(
+            ".btn-papo_listing_data_selector_status:active,",
+            ".btn-papo_listing_data_selector_status.active,",
+            ".open>.btn-papo_listing_data_selector_status.dropdown-toggle {
                     color: #fff;
                     background-color: #274AB3;
                     border-color: #274AB3;
-                }")
-          ),
+                }"
+          )
+        ),
       )
     ),
     shiny::uiOutput(ns("ui"))

R/mod_patient_profile.R

@@ -48,6 +48,8 @@ mod_patient_profile_server <- function(id, subject_level_dataset, extra_datasets
   vline_vars <- plots[["vline_vars"]]
   vline_day_numbers <- plots[["vline_day_numbers"]]
   palette <- plots[["palette"]]
+  x_axis_unit <- if (!is.null(plots[["x_axis_unit"]])) plots[["x_axis_unit"]] else CONST$PLOT_X_AXIS_UNITS$DAYS
+  x_axis_breaks <- if (!is.null(plots[["x_axis_breaks"]])) plots[["x_axis_breaks"]] else CONST$PLOT_X_AXIS_DEFAULT_NUMBER_OF_BREAKS
 
   # NOTE: simplifies downstream code because list[[optional_missing_element]] returns NULL
   for (i_plot in seq_along(range_plots)) {
@@ -88,9 +90,9 @@ mod_patient_profile_server <- function(id, subject_level_dataset, extra_datasets
         return(res)
       })
 
-      # (#ag4hj): Without these outputOptions the update selector tries to update a selector that is not yet in the UI.
-      # Therefore the update is lost. In practice this means that when using the receiver_ids the first subjid is lost
-      # and the interaction is incorrect.
+      # (ag4hj): Without these outputOptions the update selector (See: ag4hj) tries to update a selector that is not yet
+      # in the UI. Therefore the update is lost. In practice this means that when using the receiver_ids the first
+      # subjid is lost and the interaction is incorrect.
       shiny::outputOptions(output, "ui", suspendWhenHidden = FALSE)
 
       output[["selector"]] <- shiny::renderUI({
@@ -103,23 +105,25 @@ mod_patient_profile_server <- function(id, subject_level_dataset, extra_datasets
         )
       })
 
-      # See: (#ag4hj)
+      # See: (ag4hj)
       shiny::outputOptions(output, "selector", suspendWhenHidden = FALSE)
 
-      # See: (#ag4hj)
+      # See: (ag4hj)
       # change selected patient based on sender_ids
-      lapply(sender_ids, function(x) {
-        shiny::observeEvent(x()[["subj_id"]](), {
-          pid_passed <- x()[["subj_id"]]()
-          if (!identical(pid_passed, character(0))) {
-            shiny::updateSelectInput(
-              session = session,
-              inputId = "patient_selector",
-              selected = pid_passed
-            )
-          }
+      if (!is.null(sender_ids)) {
+        lapply(sender_ids, function(x) {
+          shiny::observeEvent(x()[["subj_id"]](), {
+            pid_passed <- x()[["subj_id"]]()
+            if (!identical(pid_passed, character(0))) {
+              shiny::updateSelectInput(
+                session = session,
+                inputId = "patient_selector",
+                selected = pid_passed
+              )
+            }
+          })
         })
-      })
+      }
 
       assert <- function(condition, message) shiny::validate(shiny::need(condition, message))
 
@@ -201,6 +205,8 @@ mod_patient_profile_server <- function(id, subject_level_dataset, extra_datasets
         id = "plot_contents", subjid_var,
         subject_level_dataset = filtered_subject_level_dataset,
         timeline_info,
+        x_axis_unit = x_axis_unit,
+        x_axis_breaks = x_axis_breaks,
         extra_datasets = filtered_extra_datasets,
         range_plots = range_plots,
         value_plots = value_plots,