From 08730aaf0ae680bed9c19c21c5ef1f3eaab18a9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 27 Feb 2024 12:14:24 +0100 Subject: [PATCH] `tm_g_regression` labels are no longer allowed out of bounds (#675) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit # Pull Request Fixes #66 ### Changes description - Adds dependency to imports - Uses `ggrepel` to generate the labels for outliers - Adds option to `tm_g_regression` and encoding panel for size of segment ### Reviewer considerations - Is the new encoding option necessary? - This could be implemented as an optional dependency - with `if (requireNamespace("ggrepel", quietly) { } else { }` - In practice it's never an optional dependency as `ggmosaic` depends directly on it (`with Imports`) --------- Signed-off-by: André Veríssimo <211358+averissimo@users.noreply.github.com> Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> --- .pre-commit-config.yaml | 1 + DESCRIPTION | 2 + NEWS.md | 4 ++ R/tm_a_regression.R | 128 +++++++++++++++++++++++++++++++++++----- inst/WORDLIST | 1 + man/tm_a_regression.Rd | 19 +++++- 6 files changed, 138 insertions(+), 17 deletions(-) diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index a80cd7b49..2cef103a9 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -24,6 +24,7 @@ repos: - dplyr - DT - forcats + - ggrepel - grid - logger - magrittr diff --git a/DESCRIPTION b/DESCRIPTION index f1120ae00..daf55142d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -56,6 +56,7 @@ Suggests: ggExtra, ggpmisc (>= 0.4.3), ggpp, + ggrepel, goftest, gridExtra, htmlwidgets, @@ -82,6 +83,7 @@ Config/Needs/verdepcheck: haleyjeppson/ggmosaic, tidyverse/ggplot2, insightsengineering/teal.widgets, insightsengineering/tern, tidyverse/tibble, tidyverse/tidyr, r-lib/tidyselect, tidymodels/broom, daattali/colourpicker, daattali/ggExtra, aphalo/ggpmisc, aphalo/ggpp, + slowkow/ggrepel, baddstats/goftest, gridExtra, ramnathv/htmlwidgets, jeroen/jsonlite, yihui/knitr, deepayan/lattice, MASS, insightsengineering/nestcolor, r-lib/rlang, insightsengineering/rtables, sparkline, diff --git a/NEWS.md b/NEWS.md index 869fddb6f..050d83f7e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,10 @@ * Updated the package docs and vignettes with the new way of specifying data for `teal::init()`. The `data` argument will accept a `teal_data` object +### Bug fixes + +* Outlier labels no longer appear out of bounds in `tm_a_regression`. + ### Miscellaneous * Removed `teal.slice` dependencies. diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index fbf45f765..e71209ce5 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -22,6 +22,19 @@ #' 5. Cook's distance #' 6. Residuals vs Leverage #' 7. Cook's dist vs Leverage +#' @param label_segment_threshold (`numeric(1)` or `numeric(3)`) +#' Minimum distance between label and point on the plot that triggers the creation of +#' a line segment between the two. +#' This may happen when the label cannot be placed next to the point as it overlaps another +#' label or point. +#' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function. +#' +#' It can take the following forms: +#' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI. +#' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically. +#' +#' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max` +#' argument in `teal.widgets::optionalSliderInputValMinMax`. #' #' @templateVar ggnames `r regression_names` #' @template ggplot2_args_multi @@ -135,33 +148,76 @@ tm_a_regression <- function(label = "Regression Analysis", pre_output = NULL, post_output = NULL, default_plot_type = 1, - default_outlier_label = "USUBJID") { + default_outlier_label = "USUBJID", + label_segment_threshold = c(0.5, 0, 10)) { logger::log_info("Initializing tm_a_regression") + + # Normalize the parameters if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor) if (inherits(response, "data_extract_spec")) response <- list(response) if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + # Start of assertions checkmate::assert_string(label) + checkmate::assert_list(regressor, types = "data_extract_spec") + checkmate::assert_list(response, types = "data_extract_spec") if (!all(vapply(response, function(x) !(x$select$multiple), logical(1)))) { stop("'response' should not allow multiple selection") } - checkmate::assert_list(regressor, types = "data_extract_spec") + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], + upper = plot_width[3], + null.ok = TRUE, + .var.name = "plot_width" + ) + + if (length(alpha) == 1) { + checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") + } + + if (length(size) == 1) { + checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") + } + ggtheme <- match.arg(ggtheme) - checkmate::assert_string(default_outlier_label) + plot_choices <- c( "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" ) checkmate::assert_list(ggplot2_args, types = "ggplot2_args") checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) - checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") - checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) - checkmate::assert_numeric( - plot_width[1], - lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" - ) + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_integerish(default_plot_type, lower = 1, upper = 7) + checkmate::assert_string(default_outlier_label) + + if (length(label_segment_threshold) == 1) { + checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric( + label_segment_threshold[1], + lower = label_segment_threshold[2], + upper = label_segment_threshold[3], + .var.name = "label_segment_threshold" + ) + } + # End of assertions # Send ui args args <- as.list(environment()) @@ -257,6 +313,29 @@ ui_a_regression <- function(id, ...) { title = "Plot settings", teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax( + inputId = ns("label_min_segment"), + label = div( + class = "teal-tooltip", + tagList( + "Label min. segment:", + icon("circle-info"), + span( + class = "tooltiptext", + paste( + "Use the slider to choose the cut-off value to define minimum distance between label and point", + "that generates a line segment.", + "It's only valid when 'Display outlier labels' is checked." + ) + ) + ) + ), + value_min_max = args$label_segment_threshold, + # Extra parameters to sliderInput + ticks = FALSE, + step = .1, + round = FALSE + ), selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", @@ -437,10 +516,23 @@ srv_a_regression <- function(id, ) }) + label_min_segment <- reactive({ + input$label_min_segment + }) + outlier_label <- reactive({ substitute( - expr = geom_text(label = label_col, hjust = 0, vjust = 1, color = "red"), - env = list(label_col = label_col()) + expr = ggrepel::geom_text_repel( + label = label_col, + color = "red", + hjust = 0, + vjust = 1, + max.overlaps = Inf, + min.segment.length = label_min_segment, + segment.alpha = 0.5, + seed = 123 + ), + env = list(label_col = label_col(), label_min_segment = label_min_segment()) ) }) @@ -608,16 +700,20 @@ srv_a_regression <- function(id, plot <- substitute( expr = plot + stat_qq( - geom = "text", + geom = ggrepel::GeomTextRepel, label = label_col %>% data.frame(label = .) %>% dplyr::filter(label != "cooksd == NaN") %>% unlist(), + color = "red", hjust = 0, - vjust = 1, - color = "red" + vjust = 0, + max.overlaps = Inf, + min.segment.length = label_min_segment, + segment.alpha = .5, + seed = 123 ), - env = list(plot = plot, label_col = label_col()) + env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment()) ) } diff --git a/inst/WORDLIST b/inst/WORDLIST index 6815d0d95..a521b3097 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,6 +1,7 @@ Forkers Hoffmann TLG +UI facetting funder pre diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 8777542a4..17caf06a9 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -17,7 +17,8 @@ tm_a_regression( pre_output = NULL, post_output = NULL, default_plot_type = 1, - default_outlier_label = "USUBJID" + default_outlier_label = "USUBJID", + label_segment_threshold = c(0.5, 0, 10) ) } \arguments{ @@ -72,6 +73,22 @@ into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} el }} \item{default_outlier_label}{optional, (\code{character}) The default column selected to label outliers.} + +\item{label_segment_threshold}{(\code{numeric(1)} or \code{numeric(3)}) +Minimum distance between label and point on the plot that triggers the creation of +a line segment between the two. +This may happen when the label cannot be placed next to the point as it overlaps another +label or point. +The value is used as the \code{min.segment.length} parameter to the \code{\link[ggrepel:geom_text_repel]{ggrepel::geom_text_repel()}} function. + +It can take the following forms: +\itemize{ +\item \code{numeric(1)}: Fixed value used for the minimum distance and the slider is not presented in the UI. +\item \code{numeric(3)}: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically. + +It takes the form of \code{c(value, min, max)} and it is passed to the \code{value_min_max} +argument in \code{teal.widgets::optionalSliderInputValMinMax}. +}} } \description{ Scatterplot and Regression Model