Merge pull request #36 from Boehringer-Ingelheim/rc/0.1.1

Rc/0.1.1

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: dv.explorer.parameter
 Type: Package
 Title: Parameter exploration modules
-Version: 0.1.0
+Version: 0.1.1
 Authors@R: c(
         person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),
         person(given = "Luis", family = "Moris Fernandez", role = c("aut", "cre"), email = "[email protected]"),

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(boxplot_UI)
 export(boxplot_server)
 export(corr_hm_UI)

NEWS.md

@@ -1,3 +1,10 @@
+# dv.explorer.parameter 0.1.1
+
+* boxplot:
+    * Provide a checkbox under the "Other" UI menu to log-project the Y axis.
+* lineplot:
+    * Warn app creators against non-finite values in numeric visits.
+
 # dv.explorer.parameter 0.1.0
 
 * boxplot, correlation heatmap, forest plot, roc, scatter plot, scatter plot matrix, waterfall plus heatmap:

R/aaa_preface.R

@@ -50,18 +50,14 @@ 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`
 
-#' @export
 #' @keywords internal
 `[.pack_of_constants` <- function(pack, name) {
   stop("Invalid pack_of_constants method")

R/mod_boxplot.R

@@ -14,6 +14,7 @@ BP <- poc( # nolint
     OTHER_BUTTON = "other_button",
     VIOLIN_CHECK = "violin_check",
     SHOW_POINTS_CHECK = "show_points_check",
+    Y_PROJECTION_CHECK = "y_projection_check",
     CHART = "chart",
     TAB_TABLES = "tab_tables",
     TABLE_SINGLE_LISTING = "table_single_listing",
@@ -43,6 +44,7 @@ BP <- poc( # nolint
       OTHER_BUTTON = "Other",
       VIOLIN_CHECK = "Violin plot",
       SHOW_POINTS_CHECK = "Show individual points",
+      Y_PROJECTION_CHECK = "Y-axis logarithmic projection",
       TABLE_LISTING = "Data Listing",
       TABLE_SINGLE_LISTING = "Single Listing",
       TABLE_COUNT = "Data Count",
@@ -118,7 +120,8 @@ boxplot_UI <- function(id) { # nolint
   other_menu <- drop_menu_helper(
     ns(BP$ID$OTHER_BUTTON), BP$MSG$LABEL$OTHER_BUTTON,
     shiny::checkboxInput(inputId = ns(BP$ID$VIOLIN_CHECK), BP$MSG$LABEL$VIOLIN_CHECK),
-    shiny::checkboxInput(inputId = ns(BP$ID$SHOW_POINTS_CHECK), BP$MSG$LABEL$SHOW_POINTS_CHECK)
+    shiny::checkboxInput(inputId = ns(BP$ID$SHOW_POINTS_CHECK), BP$MSG$LABEL$SHOW_POINTS_CHECK),
+    shiny::checkboxInput(inputId = ns(BP$ID$Y_PROJECTION_CHECK), BP$MSG$LABEL$Y_PROJECTION_CHECK)
   )
 
   state_menu <- drop_menu_helper(
@@ -400,6 +403,9 @@ boxplot_server <- function(id,
     inputs[[BP$ID$SHOW_POINTS_CHECK]] <- shiny::reactive({
       input[[BP$ID$SHOW_POINTS_CHECK]]
     })
+    inputs[[BP$ID$Y_PROJECTION_CHECK]] <- shiny::reactive({
+      input[[BP$ID$Y_PROJECTION_CHECK]]
+    })
     inputs[[BP$ID$CHART_CLICK]] <- shiny::reactive({
       input[[BP$ID$CHART_CLICK]]
     })
@@ -574,6 +580,7 @@ boxplot_server <- function(id,
         ds = data_subset(),
         violin = inputs[[BP$ID$VIOLIN_CHECK]](),
         show_points = inputs[[BP$ID$SHOW_POINTS_CHECK]](),
+        log_project_y = inputs[[BP$ID$Y_PROJECTION_CHECK]](),
         title_data = bp_title_data()
       )
     )
@@ -1024,7 +1031,7 @@ bp_subset_data <- function(cat,
 #'
 #' @keywords internal
 #'
-boxplot_chart <- function(ds, violin, show_points, title_data = NULL) {
+boxplot_chart <- function(ds, violin, show_points, log_project_y, title_data = NULL) {
   is_main_grouped <- CNT$MAIN_GROUP %in% names(ds)
   is_sub_grouped <- CNT$SUB_GROUP %in% names(ds)
   is_page_grouped <- CNT$PAGE_GROUP %in% names(ds)
@@ -1101,7 +1108,7 @@ boxplot_chart <- function(ds, violin, show_points, title_data = NULL) {
     title_data$main_grp, title_data$sub_grp, title_data$page_grp
   )
 
-  p +
+  p <- p +
     ggplot2::facet_grid(
       rows = rows,
       cols = cols,
@@ -1118,6 +1125,12 @@ boxplot_chart <- function(ds, violin, show_points, title_data = NULL) {
       strip.text.x = ggplot2::element_text(size = STYLE$STRIP_TEXT_SIZE),
       strip.text.y = ggplot2::element_text(size = STYLE$STRIP_TEXT_SIZE)
     )
+
+  if (isTRUE(log_project_y)) {
+    p <- p + ggplot2::scale_y_continuous(trans = pseudo_log_projection(base = 10))
+  }
+
+  return(p)
 }
 
 #' Subsets a data.frame based on the values of a one-rowed data.frame
@@ -1297,8 +1310,8 @@ NULL
 
 #' @rdname boxplot_composed
 #' @inheritParams boxplot_chart
-bp_get_boxplot_output <- function(ds, violin, show_points, title_data) {
-  boxplot_chart(ds, violin, show_points, title_data)
+bp_get_boxplot_output <- function(ds, violin, show_points, log_project_y, title_data) {
+  boxplot_chart(ds, violin, show_points, log_project_y, title_data)
 }
 
 #' @rdname boxplot_composed

R/mod_lineplot.R

@@ -150,40 +150,6 @@ lp_selected_line_mask <- function(data, selected_points) {
   res
 }
 
-# Pseudolog projection. Alternative to log projection that handles non-positive values.
-# (see https://win-vector.com/2012/03/01/modeling-trick-the-signed-pseudo-logarithm/amp/)
-#
-# We could use `scales::pseudo_log_trans(base = 10)`, but its default breaks are bad and won't get fixed:
-#  https://github.com/r-lib/scales/issues/219
-# We could also take the object returned by that function and modify its `breaks` field, but the structure of ggtplot2
-# transform objects is not documented and we can't assume it will remain stable.
-# The ggplot2 manual (`?ggplot2::scale_y_continuous`) says transformations must be created through calls to
-# `scales::trans_new` (ggplot2 >= 3.5.0) or `scales::new_transform` (ggplot2 >= 3.5.0).
-lp_pseudo_log <- function(x, base = 10) asinh(x / 2) / log(base)
-lp_inverse_pseudo_log <- function(x, base = 10) 2 * sinh(x * log(base))
-
-lp_pseudo_log_projection <- function(base = 10) {
-  breaks <- function(x) {
-    res <- NULL
-    if (all(x >= 0)) {
-      res <- scales::log_breaks(base)(x)
-    } else if (all(x <= 0)) {
-      res <- -scales::log_breaks(base)(abs(x))
-    } else {
-      max_limit <- max(c(2, abs(x)))
-      breaks <- scales::log_breaks(base)(c(1, max_limit))
-      res <- unique(c(-breaks, 0, breaks))
-    }
-    return(res)
-  }
-
-  scales::trans_new(
-    name = paste0("pseudolog-", format(base)),
-    transform = lp_pseudo_log, inverse = lp_inverse_pseudo_log,
-    breaks = breaks, domain = c(-Inf, Inf)
-  )
-}
-
 lineplot_chart <- function(data, title = NULL, ref_line_data = NULL, log_project_y_axis = FALSE, time_var_is_cdisc = FALSE,
                            alpha = 1) {
   trace_grp1 <- CNT$PAR
@@ -348,7 +314,7 @@ lineplot_chart <- function(data, title = NULL, ref_line_data = NULL, log_project
   if (isTRUE(log_project_y_axis)) {
     # we use the deprecated `trans` argument instead of `transform`
     # because the latter is only supported in ggplot2 >= 3.5.0
-    fig <- fig + ggplot2::scale_y_continuous(trans = lp_pseudo_log_projection(base = 10))
+    fig <- fig + ggplot2::scale_y_continuous(trans = pseudo_log_projection(base = 10))
   }
 
   fig
@@ -1025,7 +991,7 @@ lineplot_server <- function(id,
       log_projection_col_name <- character(0)
       if (should_log_project) {
         log_projection_col_name <- "_pseudolog_projection"
-        df[[log_projection_col_name]] <- lp_pseudo_log(df[[y_var]])
+        df[[log_projection_col_name]] <- pseudo_log(df[[y_var]])
         y_var <- log_projection_col_name
       }
 
@@ -1679,23 +1645,42 @@ check_mod_lineplot <- function(
     ds <- datasets[[bm_dataset_name]]
     for (visit_var in c(visit_vars, cdisc_visit_vars)) {
       var_data <- ds[[visit_var]]
-      levs <- unique(var_data)
-      CM$assert(
-        container = err,
-        cond = all(nchar(trimws(levs)) > 0),
-        msg = sprintf(
-          paste(
-            "The visit variable `<b>%s</b>` in dataset `<b>%s</b>` contains missing (blank) values.",
-            "The lineplot module does not support those, since they lead to blank options in the visit selector",
-            "and to missing X axis labels on the resulting plot, which may be puzzling to up users.<br>",
-            "You can examine the affected variable with this command: <pre>unique(%s[['%s']])</pre>",
-            "Notice the blank value in the resulting output:",
-            "<pre>%s</pre>"
-          ),
-          visit_var, bm_dataset_name, bm_dataset_name, visit_var,
-          paste(capture.output(unique(ds[["VISIT"]])), collapse = "\n")
+      vals <- unique(var_data)
+
+      if (is.character(vals)) {
+        CM$assert(
+          container = err,
+          cond = all(nchar(trimws(vals)) > 0),
+          msg = sprintf(
+            paste(
+              "The visit variable `<b>%s</b>` in dataset `<b>%s</b>` contains missing (blank) values.",
+              "The lineplot module does not support those, since they lead to blank options in the visit selector",
+              "and to missing X axis labels on the resulting plot, which may be puzzling to up users.<br>",
+              "You can examine the affected variable with this command: <pre>unique(%s[['%s']])</pre>",
+              "Notice the blank value in the resulting output:",
+              "<pre>%s</pre>"
+            ),
+            visit_var, bm_dataset_name, bm_dataset_name, visit_var,
+            paste(capture.output(unique(ds[[visit_var]])), collapse = "\n")
+          )
         )
-      )
+      } else if (is.numeric(vals)) {
+        CM$assert(
+          container = err,
+          cond = all(is.finite(vals)),
+          msg = sprintf(
+            paste(
+              "The numeric visit variable `<b>%s</b>` in dataset `<b>%s</b>` contains non-finite (`NA`, `Inf`) values.",
+              "The lineplot module does not support those, since they can't be placed along the X axis.<br>",
+              "You can examine the affected variable with this command: <pre>unique(%s[['%s']])</pre>",
+              "Notice the offending value in the resulting output:",
+              "<pre>%s</pre>"
+            ),
+            visit_var, bm_dataset_name, bm_dataset_name, visit_var,
+            paste(capture.output(unique(ds[[visit_var]])), collapse = "\n")
+          )
+        )
+      }
     }
   }
 

R/utils-misc.R

@@ -159,3 +159,38 @@ drop_columns_by_name <- function(df, col_names) {
   df[col_names] <- list(NULL)
   return(df)
 }
+
+# Pseudolog projection. Alternative to log projection that handles non-positive values.
+# (see https://win-vector.com/2012/03/01/modeling-trick-the-signed-pseudo-logarithm/amp/)
+#
+# We could use `scales::pseudo_log_trans(base = 10)`, but its default breaks are bad and won't get fixed:
+#  https://github.com/r-lib/scales/issues/219
+# We could also take the object returned by that function and modify its `breaks` field, but the structure of ggtplot2
+# transform objects is not documented and we can't assume it will remain stable.
+# The ggplot2 manual (`?ggplot2::scale_y_continuous`) says transformations must be created through calls to
+# `scales::trans_new` (ggplot2 >= 3.5.0) or `scales::new_transform` (ggplot2 >= 3.5.0).
+pseudo_log <- function(x, base = 10) asinh(x / 2) / log(base)
+inverse_pseudo_log <- function(x, base = 10) 2 * sinh(x * log(base))
+
+pseudo_log_projection <- function(base = 10) {
+  breaks <- function(x) {
+    res <- NULL
+    if (all(x >= 0)) {
+      res <- scales::log_breaks(base)(x)
+    } else if (all(x <= 0)) {
+      res <- -scales::log_breaks(base)(abs(x))
+    } else {
+      max_limit <- max(c(2, abs(x)))
+      breaks <- scales::log_breaks(base)(c(1, max_limit))
+      res <- unique(c(-breaks, 0, breaks))
+    }
+    return(res)
+  }
+
+  scales::trans_new(
+    name = paste0("pseudolog-", format(base)),
+    transform = pseudo_log, inverse = inverse_pseudo_log,
+    breaks = breaks, domain = c(-Inf, Inf)
+  )
+}
+