From e121e333cfeadb89254cfc51b117ad3afd5d78af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?zxBIB=20Lech=C3=B3n=2CMiguel=20=28MED=20BDS=29=20EXTERNAL?= Date: Tue, 10 Dec 2024 11:52:08 +0100 Subject: [PATCH 1/6] De-export POC S3 symbols. --- R/aaa_preface.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/aaa_preface.R b/R/aaa_preface.R index 2fa830c..4bd7410 100644 --- a/R/aaa_preface.R +++ b/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") From 36e8fea00370fc82c7b9605577fd56040ef981a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?zxBIB=20Lech=C3=B3n=2CMiguel=20=28MED=20BDS=29=20EXTERNAL?= Date: Tue, 10 Dec 2024 12:00:21 +0100 Subject: [PATCH 2/6] Rerun roxygen. --- NAMESPACE | 3 --- 1 file changed, 3 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a4834a8..253282b 100644 --- a/NAMESPACE +++ b/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) From 39b4daf5591d41789ff310304b0191053f240376 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?zxBIB=20Lech=C3=B3n=2CMiguel=20=28MED=20BDS=29=20EXTERNAL?= Date: Tue, 10 Dec 2024 12:02:13 +0100 Subject: [PATCH 3/6] [lineplot] Warn app creators against non-finite values in numeric visits. --- R/mod_lineplot.R | 51 +++++++++++++++++++++++++++++++++--------------- 1 file changed, 35 insertions(+), 16 deletions(-) diff --git a/R/mod_lineplot.R b/R/mod_lineplot.R index 7718e16..b800660 100644 --- a/R/mod_lineplot.R +++ b/R/mod_lineplot.R @@ -1679,23 +1679,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 `%s` in dataset `%s` 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.
", - "You can examine the affected variable with this command: 
unique(%s[['%s']])
", - "Notice the blank value in the resulting output:", - "
%s
" - ), - 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 `%s` in dataset `%s` 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.
", + "You can examine the affected variable with this command: 
unique(%s[['%s']])
", + "Notice the blank value in the resulting output:", + "
%s
" + ), + 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 `%s` in dataset `%s` contains non-finite (`NA`, `Inf`) values.", + "The lineplot module does not support those, since they can't be placed along the X axis.
", + "You can examine the affected variable with this command: 
unique(%s[['%s']])
", + "Notice the offending value in the resulting output:", + "
%s
" + ), + visit_var, bm_dataset_name, bm_dataset_name, visit_var, + paste(capture.output(unique(ds[[visit_var]])), collapse = "\n") + ) + ) + } } } From b98607ae3dc831c7eec66052bd3e5a0968300bff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?zxBIB=20Lech=C3=B3n=2CMiguel=20=28MED=20BDS=29=20EXTERNAL?= Date: Tue, 10 Dec 2024 14:15:38 +0100 Subject: [PATCH 4/6] Move pseudolog projection out of lineplot for reuse. --- R/mod_lineplot.R | 38 ++------------------------------------ R/utils-misc.R | 35 +++++++++++++++++++++++++++++++++++ 2 files changed, 37 insertions(+), 36 deletions(-) diff --git a/R/mod_lineplot.R b/R/mod_lineplot.R index b800660..bd6a659 100644 --- a/R/mod_lineplot.R +++ b/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 } diff --git a/R/utils-misc.R b/R/utils-misc.R index 3aca135..17f21cc 100644 --- a/R/utils-misc.R +++ b/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) + ) +} + From 4dbd89607be9a8aed1de6d01a3f9d83f88e09d19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?zxBIB=20Lech=C3=B3n=2CMiguel=20=28MED=20BDS=29=20EXTERNAL?= Date: Tue, 10 Dec 2024 14:16:32 +0100 Subject: [PATCH 5/6] [boxplot] Toggle between linear and log10 projection through checkbox. --- R/mod_boxplot.R | 23 ++++++++++++++++++----- man/boxplot_chart.Rd | 2 +- man/boxplot_composed.Rd | 2 +- 3 files changed, 20 insertions(+), 7 deletions(-) diff --git a/R/mod_boxplot.R b/R/mod_boxplot.R index 4f06111..af2198c 100644 --- a/R/mod_boxplot.R +++ b/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 diff --git a/man/boxplot_chart.Rd b/man/boxplot_chart.Rd index 7f6e49e..9d2d962 100644 --- a/man/boxplot_chart.Rd +++ b/man/boxplot_chart.Rd @@ -4,7 +4,7 @@ \alias{boxplot_chart} \title{ggplot for a set of faceted boxplots} \usage{ -boxplot_chart(ds, violin, show_points, title_data = NULL) +boxplot_chart(ds, violin, show_points, log_project_y, title_data = NULL) } \arguments{ \item{ds}{\code{data.frame()} diff --git a/man/boxplot_composed.Rd b/man/boxplot_composed.Rd index b21fdf7..f7db4e4 100644 --- a/man/boxplot_composed.Rd +++ b/man/boxplot_composed.Rd @@ -10,7 +10,7 @@ \alias{bp_get_significance_output} \title{Composes data selection and charting for boxplot} \usage{ -bp_get_boxplot_output(ds, violin, show_points, title_data) +bp_get_boxplot_output(ds, violin, show_points, log_project_y, title_data) bp_get_listings_output(ds, closest_point) From 47d6a4c8c6e50d201d13e677fbe4255616d0f47a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?zxBIB=20Lech=C3=B3n=2CMiguel=20=28MED=20BDS=29=20EXTERNAL?= Date: Tue, 10 Dec 2024 14:36:03 +0100 Subject: [PATCH 6/6] [boxplot] Test Y axis log projection. --- .../boxplot/boxplot-y-axis-log-projection.svg | 460 ++++++++++++++++++ tests/testthat/test-boxplot.R | 16 +- 2 files changed, 472 insertions(+), 4 deletions(-) create mode 100644 tests/testthat/_snaps/boxplot/boxplot-y-axis-log-projection.svg diff --git a/tests/testthat/_snaps/boxplot/boxplot-y-axis-log-projection.svg b/tests/testthat/_snaps/boxplot/boxplot-y-axis-log-projection.svg new file mode 100644 index 0000000..aa1ba39 --- /dev/null +++ b/tests/testthat/_snaps/boxplot/boxplot-y-axis-log-projection.svg @@ -0,0 +1,460 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +SA + + + + + + + + + + +SB + + + + + + + + + + +PA + +PA + + + + + + + + + + +PB + +PA + + + + + + + + + + +PA + +PB + + + + + + + + + + +PB + +PB + + + + +MA +MB + + +MA +MB +1 +2 +3 +4 +5 +6 +7 +10 + + + + + + + + +3 +4 +5 +6 +7 +8 +9 +10 + + + + + + + + +18 +20 +22 +24 +26 +28 +30 + + + + + + + +20 +22 +24 +26 +28 +30 +32 + + + + + + + +main_group +value + + diff --git a/tests/testthat/test-boxplot.R b/tests/testthat/test-boxplot.R index c22659b..7c3c154 100644 --- a/tests/testthat/test-boxplot.R +++ b/tests/testthat/test-boxplot.R @@ -273,14 +273,14 @@ local({ test_that("boxplot_chart produces a boxplot", { vdiffr::expect_doppelganger( "boxplot", - boxplot_chart(df, FALSE, FALSE) + boxplot_chart(df, FALSE, FALSE, FALSE) ) }) test_that("boxplot_chart produces a violinplot", { vdiffr::expect_doppelganger( "violin plot", - boxplot_chart(df, TRUE, FALSE) + boxplot_chart(df, TRUE, FALSE, FALSE) ) }) @@ -288,7 +288,15 @@ local({ set.seed(1) vdiffr::expect_doppelganger( "boxplot individual points", - boxplot_chart(df, FALSE, TRUE) + boxplot_chart(df, FALSE, TRUE, FALSE) + ) + }) + + test_that("boxplot_chart produces a boxplot with a log-projected Y axis", { + set.seed(1) + vdiffr::expect_doppelganger( + "boxplot Y-axis log projection", + boxplot_chart(df, FALSE, FALSE, TRUE) ) }) }) @@ -301,7 +309,7 @@ test_that("boxplot_chart injects a dummy main group when there is none", { value = 1:10 ) - p <- boxplot_chart(df, FALSE, FALSE) + p <- boxplot_chart(df, FALSE, FALSE, FALSE) expect_true(CNT$MAIN_GROUP %in% names(p$data)) })