Merge branch '257261_default_col_palette' of https://github.com/Boehringer-Ingelheim/dv.papo into 257261_default_col_palette

Author: gm-ebs-ext

NAMESPACE

@@ -1,8 +1,5 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method("$",pack_of_constants)
-S3method("[",pack_of_constants)
-S3method("[[",pack_of_constants)
 export(explorer_app)
 export(mock_patient_profile_UI)
 export(mock_patient_profile_app)

NEWS.md

@@ -1,16 +1,15 @@
 # dv.papo 2.0.5-900
-
 - Fixes missing palette colours for AE, CM grading values.
 
 # dv.papo 2.0.4-900
-
 - Fixes issue with labels not working fully if a data.frame is passed as input.
 
 # dv.papo 2.0.3-900
-
 - Fixes y-axis getting squashed if blank values present in DECODE variable for AE/CM plots.
 
-# dv.papo 2.0.1-900
+# dv.papo 2.0.2-900
+- Fixes Serious AE labels mapping when the column is a "Y/N" `character` or `factor` variable instead of `logical`.
+
 
 # dv.papo 2.0.1
 

R/aaa_preface.R

@@ -4,9 +4,6 @@
 #' Build a collection of named constants
 #'
 #' @param ... Named parameters to be collected as constants
-#'
-#' @keywords internal
-#'
 #' @details
 #' Shiny uses strings as IDs to link UI and server elements. E.g:
 #'   foo_UI(id = ns("foo")) ...
@@ -37,6 +34,7 @@
 #' It is tagged as an S3 object to override its extraction operators.
 #'
 #' The use of checkmate is unnecessary, but it's a Good Library(TM) and your module should rely on it anyways
+#' @keywords internal
 pack_of_constants <- function(...) {
   result <- list(...)
   checkmate::assert_list(result, any.missing = FALSE, names = "unique")
@@ -51,24 +49,16 @@ pack_of_constants <- function(...) {
 #'
 #' This function differs from the base list extraction method in that it avoids partial matching of keys and throws
 #' an error if the looked-for constant is not contained within the pack.
-#'
 #' @keywords internal
-#'
-#' @export
 `$.pack_of_constants` <- function(pack, name) {
   checkmate::assert_true(name %in% names(pack), .var.name = paste0(deparse(substitute(pack)), "$", name))
   NextMethod()
 }
 
-# This exports are recent requirement for devtools check https://github.com/r-lib/roxygen2/issues/1592#issue-2121199122
-#'
 #' @keywords internal
-#'
-#' @export
 `[[.pack_of_constants` <- `$.pack_of_constants`
 
 #' @keywords internal
-#' @export
 `[.pack_of_constants` <- function(pack, name) {
   stop("Invalid pack_of_constants method")
 }

R/check_papo_call_manual.R

@@ -243,7 +243,18 @@ check_papo_call <- function(datasets, module_id, subject_level_dataset_name, sub
                 "`plots$timeline_info$%s` (%s) is not of allowed types (%s)",
                 "trt_start_date", col, paste(allowed_classes_date, collapse = ",")
               )
+            ) &&
+          assert_err(
+            !anyNA(sl_dataset[[col]]),
+            sprintf(
+              "Dataset: '%s' `plots$timeline_info$%s` (%s) can not contain missing values. <br>
+              trt_start_date is used as Day 1 reference date;
+              together with trt_end_date, they define the extent of the x-axis",
+              subject_level_dataset_name, "trt_start_date", col
             )
+
+          )
+
         # timeline_info$trt_end_date
         col <- timeline_info[["trt_end_date"]]
         end_date_ok <-
@@ -260,7 +271,16 @@ check_papo_call <- function(datasets, module_id, subject_level_dataset_name, sub
                 "`plots$timeline_info$%s` (%s) is not of allowed types (%s)",
                 "trt_end_date", col, paste(allowed_classes_date, collapse = ",")
               )
+            ) &&
+          assert_err(
+            !anyNA(sl_dataset[[col]]),
+            sprintf(
+              "Dataset: '%s' `plots$timeline_info$%s` (%s) can not contain missing values.
+              trt_start_date is used as Day 1 reference date;
+              together with trt_end_date, they define the extent of the x-axis",
+              subject_level_dataset_name, "trt_end_date", col
             )
+          )
         # timeline_info$part_end_date
         part_end_date_ok <- FALSE
         if ("part_end_date" %in% names(timeline_info)) {

R/create_plots.R

@@ -27,6 +27,10 @@ create_ae_cm_plot <- function(data, x_limits, palette, sl_info, vline_vars, vlin
   grading <- "<no grading>"
   if (grading_available) grading <- data[["grading"]]
 
+  # fix for AE/CM y-axis getting squashed:
+  blank_decode_indexes <- which(trimws(data[["decode"]]) == "")
+  data[["decode"]][blank_decode_indexes] <- htmltools::HTML("<b><i>undefined</i></b>")
+
   p <- ggplot2::ggplot(data, ggplot2::aes(x = .data[["start_day_z"]], y = .data[["decode"]]))
   p <- p + ggplot2::theme_bw()
   p <- p + ggplot2::geom_rect(

R/data_prep.R

@@ -13,8 +13,11 @@ pt_info_data_filter <- function(df, subjid_var, columns, selected_key) {
   row_index <- which(df[[subjid_var]] == selected_key)
   if (length(row_index) == 1) {
     res <- df[row_index, columns]
+      df_labels <- structure(get_labels(df), names = names(df))[columns] #extract and save labels
+      for (i in columns) {
+        attr(res[[i]], "label") <- df_labels[[i]] # re-apply saved labels
+      }
   }
-
   return(res)
 }
 

R/mod_patient_profile.R

@@ -88,9 +88,9 @@ mod_patient_profile_server <- function(id, subject_level_dataset, extra_datasets
         return(res)
       })
 
-      # (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.
+      # (#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.
       shiny::outputOptions(output, "ui", suspendWhenHidden = FALSE)
 
       output[["selector"]] <- shiny::renderUI({
@@ -103,25 +103,23 @@ 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
-      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
-              )
-            }
-          })
+      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))
 

R/mod_plots.R

@@ -217,7 +217,14 @@ patient_plot_server <- function(id, subject_var,
             df[["end_date"]] <- as.Date(df[[vars[["end_date"]]]])
             df[["decode"]] <- df[[vars[["decode"]]]]
             if ("grading" %in% names(vars)) df[["grading"]] <- df[[vars[["grading"]]]]
-            if ("serious_ae" %in% names(vars)) df[["serious_ae"]] <- df[[vars[["serious_ae"]]]]
+            if ("serious_ae" %in% names(vars)) {
+              # FIXME: This is a temporal patch while we fix the modular API part
+              if (!is.logical(df[["serious_ae"]])) {
+                df[["serious_ae"]] <- df[[vars[["serious_ae"]]]] == "Y"
+              } else {
+                df[["serious_ae"]] <- df[[vars[["serious_ae"]]]]
+              }                
+            } 
 
             # wrap decode column
             df[["decode"]] <- strwrap(df[["decode"]],
@@ -284,6 +291,7 @@ patient_plot_server <- function(id, subject_var,
               exported_test_data[[paste0("plot_first_line_color/", plot_name)]] <<-
                 plot[["x"]][["data"]][[1]][["line"]][["color"]]
               exported_test_data[[paste0("arrow_right/", plot_name)]] <<- df[["arrow_right"]]
+              exported_test_data[[paste0("serious_ae/", plot_name)]] <<- df[["serious_ae"]]
             }
 
             # tweak legend manually - adapted from dv.papo 1; maybe there's a documented way of achieving the same?

R/utils-misc.R

@@ -29,10 +29,28 @@ silence_warning <- function(expr, warning_message) {
 
 merge_with_no_duplicate_cols <- function(a, b, by) merge(a, b[c(by, setdiff(names(b), names(a)))], by)
 
-robust_min <- function(...) min(..., +Inf, na.rm = TRUE) # TODO: Remove if unused
-robust_max <- function(...) max(..., -Inf, na.rm = TRUE) # TODO: Remove if unused
-
+#' Convert possibly truncated character(n) 'yyyy-mm-dd' to Date(n)
+#' performing optional round up using the level of precision present
+#' in the input data
+#'
+#' @param data [character(n)] Vector of dates
+#'
+#' @keywords internal
+#'
 robust_ymd <- function(data, round_up = FALSE) {
+  # NOTE(miguel): 
+  # `dv.papo` used to rely on `lubridate` for date parsing.
+  # We dropped that library because we didn't need any of its many advanced features.
+  # Instead, we wrote this function to parse the only format we cared about ('yyyy-mm-dd'),
+  # and to round end-dates up taking into account the unit information implicit to possibly
+  # truncated ('yyyy', 'yyyy-mm') input strings.
+  # Using `lubridate::ceiling_date` instead results in even more code on our part, since
+  # that call assumes that all input dates have a homogeneous precision, which is not the case
+  # for us.
+  #
+  # In any case, the point is moot because we now require users of `dv.papo` to provide Date
+  # objects and this function is a (non-exported) helper to deal with character dates.
+
   label <- attr(data, "label")
 
   data <- substr(data, 1, 10)