From 62b115de2644fa721e139d69654e3c0c10c8b2d6 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 24 Feb 2026 10:58:38 +0100 Subject: [PATCH 01/25] patchwork alternative --- DESCRIPTION | 4 +- R/tm_g_scatterplotmatrix.R | 270 ++++++++++++++---- .../test-shinytest2-tm_g_scatterplotmatrix.R | 2 +- tests/testthat/test-tm_g_scatterplotmatrix.R | 8 +- .../test_scatterplotmatrix_get_stats.R | 30 +- vignettes/decorate-module-output.Rmd | 31 +- vignettes/using-scatterplot-matrix.Rmd | 1 - 7 files changed, 257 insertions(+), 89 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7e4dc4fb7..05fa14326 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,8 +46,8 @@ Imports: gridExtra (>= 2.3), htmlwidgets (>= 1.6.4), jsonlite (>= 1.8.9), - lattice (>= 0.18-4), lifecycle (>= 0.2.0), + patchwork (>= 1.2.0), MASS (>= 7.3-60), rmarkdown (>= 2.23), rtables (>= 0.6.11), @@ -100,7 +100,7 @@ Config/Needs/verdepcheck: haleyjeppson/ggmosaic, tidyverse/ggplot2, tidyverse/tibble, tidyverse/tidyr, daattali/colourpicker, daattali/ggExtra, aphalo/ggpmisc, aphalo/ggpp, slowkow/ggrepel, baddstats/goftest, ramnathv/htmlwidgets, jeroen/jsonlite, yihui/knitr, - daroczig/logger, deepayan/lattice, insightsengineering/nestcolor, + daroczig/logger, thomasp85/patchwork, insightsengineering/nestcolor, r-lib/pkgload, r-lib/rlang, rstudio/rmarkdown, insightsengineering/roxy.shinylive, insightsengineering/rtables, tidyverse/rvest, htmlwidgets/sparkline, rstudio/shinytest2, diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index ae7ad79a8..ecd7b1cfc 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -21,7 +21,7 @@ #' @section Decorating Module: #' #' This module generates the following objects, which can be modified in place using decorators: -#' - `plot` (`trellis` - output of `lattice::splom`) +#' - `plot` (`patchwork` - assembled from individual `ggplot` panels) #' #' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects. #' The name of this list corresponds to the name of the output to which the decorator is applied. @@ -273,9 +273,9 @@ ui_g_scatterplotmatrix <- function(id, ...) { step = .05, value = .5, ticks = FALSE ), sliderInput( - ns("cex"), "Points size:", - min = 0.2, max = 3, - step = .05, value = .65, ticks = FALSE + ns("size"), "Points size:", + min = 0.5, max = 5, + step = .25, value = 1.5, ticks = FALSE ), checkboxInput(ns("cor"), "Add Correlation", value = FALSE), radioButtons( @@ -284,7 +284,7 @@ ui_g_scatterplotmatrix <- function(id, ...) { choiceValues = c("pearson", "kendall", "spearman"), inline = TRUE ), - checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE) + checkboxInput(ns("cor_na_omit"), "Pairwise Complete Observations", value = TRUE) ) ) ), @@ -330,7 +330,7 @@ srv_g_scatterplotmatrix <- function(id, teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's output(s)") ) - qenv <- teal.code::eval_code(obj, "library(dplyr);library(lattice)") + qenv <- teal.code::eval_code(obj, "library(dplyr)") teal.code::eval_code(qenv, as.expression(anl_merged_input()$expr)) }) @@ -347,16 +347,16 @@ srv_g_scatterplotmatrix <- function(id, ANL <- qenv[["ANL"]] cols_names <- merged$anl_input_r()$columns_source$variables - alpha <- input$alpha - cex <- input$cex + alpha_val <- input$alpha + size_val <- input$size add_cor <- input$cor cor_method <- input$cor_method cor_na_omit <- input$cor_na_omit - cor_na_action <- if (isTruthy(cor_na_omit)) { - "na.omit" + cor_use <- if (isTruthy(cor_na_omit)) { + "pairwise.complete.obs" } else { - "na.fail" + "everything" } teal::validate_has_data(ANL, 10) @@ -388,70 +388,219 @@ srv_g_scatterplotmatrix <- function(id, ) } - # create plot teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot") if (add_cor) { shinyjs::show("cor_method") - shinyjs::show("cor_use") shinyjs::show("cor_na_omit") qenv <- teal.code::eval_code( qenv, substitute( expr = { - plot <- lattice::splom( - ANL, - varnames = varnames_value, - panel = function(x, y, ...) { - lattice::panel.splom(x = x, y = y, ...) - cpl <- lattice::current.panel.limits() - lattice::panel.text( - mean(cpl$xlim), - mean(cpl$ylim), - get_scatterplotmatrix_stats( - x, - y, - .f = stats::cor.test, - .f_args = list(method = cor_method, na.action = cor_na_action) - ), - alpha = 0.6, - fontsize = 18, - fontface = "bold" - ) - }, - pch = 16, - alpha = alpha_value, - cex = cex_value - ) + col_names <- names(ANL) + n_vars <- length(col_names) + plot_list <- list() + for (i in seq_len(n_vars)) { + for (j in seq_len(n_vars)) { + vi <- col_names[i] + vj <- col_names[j] + if (i == j) { + # diagonal: density for numeric, bar for factor + if (is.numeric(ANL[[vi]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]])) + + ggplot2::geom_density(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::ggtitle(varnames_value[i]) + + ggplot2::theme_minimal() + + ggplot2::theme( + plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), + axis.text = ggplot2::element_text(size = 7) + ) + } else { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]])) + + ggplot2::geom_bar(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::ggtitle(varnames_value[i]) + + ggplot2::theme_minimal() + + ggplot2::theme( + plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), + axis.text = ggplot2::element_text(size = 7), + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) + ) + } + } else if (i < j) { + # upper triangle: correlation text + if (is.numeric(ANL[[vi]]) && is.numeric(ANL[[vj]])) { + cor_val <- tryCatch( + stats::cor(ANL[[vi]], ANL[[vj]], method = cor_method_value, use = cor_use_value), + error = function(e) NA_real_ + ) + cor_label <- if (is.na(cor_val)) "NA" else sprintf("%.3f", cor_val) + cor_size <- max(3, abs(cor_val) * 8 + 3) + cor_color <- if (is.na(cor_val)) { + "grey50" + } else if (cor_val > 0) { + "firebrick" + } else { + "steelblue" + } + } else { + cor_label <- "-" + cor_size <- 4 + cor_color <- "grey50" + } + p <- ggplot2::ggplot() + + ggplot2::annotate( + "text", + x = 0.5, y = 0.5, + label = cor_label, + size = cor_size, + fontface = "bold", + color = cor_color + ) + + ggplot2::xlim(0, 1) + ggplot2::ylim(0, 1) + + ggplot2::theme_void() + } else { + # lower triangle: scatter/box plot + if (is.numeric(ANL[[vj]]) && is.numeric(ANL[[vi]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], y = .data[[vi]])) + + ggplot2::geom_point(alpha = alpha_value, size = size_value, color = "steelblue") + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::theme_minimal() + + ggplot2::theme(axis.text = ggplot2::element_text(size = 7)) + } else if (is.factor(ANL[[vj]]) && is.numeric(ANL[[vi]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], y = .data[[vi]])) + + ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::theme_minimal() + + ggplot2::theme( + axis.text = ggplot2::element_text(size = 7), + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) + ) + } else if (is.numeric(ANL[[vj]]) && is.factor(ANL[[vi]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]], y = .data[[vj]])) + + ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::theme_minimal() + + ggplot2::theme( + axis.text = ggplot2::element_text(size = 7), + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) + ) + + ggplot2::coord_flip() + } else { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], fill = .data[[vi]])) + + ggplot2::geom_bar(position = "dodge", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL, fill = NULL) + + ggplot2::theme_minimal() + + ggplot2::theme( + axis.text = ggplot2::element_text(size = 7), + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), + legend.position = "none" + ) + } + } + plot_list[[(i - 1) * n_vars + j]] <- p + } + } + plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) }, env = list( varnames_value = varnames, - cor_method = cor_method, - cor_na_action = cor_na_action, - alpha_value = alpha, - cex_value = cex + cor_method_value = cor_method, + cor_use_value = cor_use, + alpha_value = alpha_val, + size_value = size_val ) ) ) } else { shinyjs::hide("cor_method") - shinyjs::hide("cor_use") shinyjs::hide("cor_na_omit") + qenv <- teal.code::eval_code( qenv, substitute( expr = { - plot <- lattice::splom( - ANL, - varnames = varnames_value, - pch = 16, - alpha = alpha_value, - cex = cex_value - ) + col_names <- names(ANL) + n_vars <- length(col_names) + plot_list <- list() + for (i in seq_len(n_vars)) { + for (j in seq_len(n_vars)) { + vi <- col_names[i] + vj <- col_names[j] + if (i == j) { + if (is.numeric(ANL[[vi]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]])) + + ggplot2::geom_density(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::ggtitle(varnames_value[i]) + + ggplot2::theme_minimal() + + ggplot2::theme( + plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), + axis.text = ggplot2::element_text(size = 7) + ) + } else { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]])) + + ggplot2::geom_bar(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::ggtitle(varnames_value[i]) + + ggplot2::theme_minimal() + + ggplot2::theme( + plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), + axis.text = ggplot2::element_text(size = 7), + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) + ) + } + } else { + if (is.numeric(ANL[[vj]]) && is.numeric(ANL[[vi]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], y = .data[[vi]])) + + ggplot2::geom_point(alpha = alpha_value, size = size_value, color = "steelblue") + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::theme_minimal() + + ggplot2::theme(axis.text = ggplot2::element_text(size = 7)) + } else if (is.factor(ANL[[vj]]) && is.numeric(ANL[[vi]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], y = .data[[vi]])) + + ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::theme_minimal() + + ggplot2::theme( + axis.text = ggplot2::element_text(size = 7), + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) + ) + } else if (is.numeric(ANL[[vj]]) && is.factor(ANL[[vi]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]], y = .data[[vj]])) + + ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::theme_minimal() + + ggplot2::theme( + axis.text = ggplot2::element_text(size = 7), + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) + ) + + ggplot2::coord_flip() + } else { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], fill = .data[[vi]])) + + ggplot2::geom_bar(position = "dodge", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL, fill = NULL) + + ggplot2::theme_minimal() + + ggplot2::theme( + axis.text = ggplot2::element_text(size = 7), + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), + legend.position = "none" + ) + } + } + plot_list[[(i - 1) * n_vars + j]] <- p + } + } + plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) }, - env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) + env = list( + varnames_value = varnames, + alpha_value = alpha_val, + size_value = size_val + ) ) ) } @@ -503,19 +652,12 @@ srv_g_scatterplotmatrix <- function(id, #' Get stats for x-y pairs in scatterplot matrix #' +#' @description +#' `r lifecycle::badge("deprecated")` +#' #' Uses [stats::cor.test()] per default for all numerical input variables and converts results #' to character vector. #' Could be extended if different stats for different variable types are needed. -#' Meant to be called from [lattice::panel.text()]. -#' -#' Presently we need to use a formula input for `stats::cor.test` because -#' `na.fail` only gets evaluated when a formula is passed (see below). -#' ``` -#' x = c(1,3,5,7,NA) -#' y = c(3,6,7,8,1) -#' stats::cor.test(x, y, na.action = "na.fail") -#' stats::cor.test(~ x + y, na.action = "na.fail") -#' ``` #' #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length. #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`. @@ -545,6 +687,14 @@ get_scatterplotmatrix_stats <- function(x, y, .f_args = list(), round_stat = 2, round_pval = 4) { + lifecycle::deprecate_warn( + "0.6.1", + "get_scatterplotmatrix_stats()", + details = paste( + "The scatterplot matrix module now uses ggplot2 + patchwork", + "which handles correlation display natively." + ) + ) if (is.numeric(x) && is.numeric(y)) { stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) diff --git a/tests/testthat/test-shinytest2-tm_g_scatterplotmatrix.R b/tests/testthat/test-shinytest2-tm_g_scatterplotmatrix.R index cf624ae7d..88f11a6df 100644 --- a/tests/testthat/test-shinytest2-tm_g_scatterplotmatrix.R +++ b/tests/testthat/test-shinytest2-tm_g_scatterplotmatrix.R @@ -105,7 +105,7 @@ test_that("e2e - tm_g_scatterplotmatrix: Change plot settings", { app_driver <- app_driver_tm_g_scatterplotmatrix() app_driver$set_active_module_input("alpha", 0.7) - app_driver$set_active_module_input("cex", 2) + app_driver$set_active_module_input("size", 2) app_driver$expect_no_validation_error() diff --git a/tests/testthat/test-tm_g_scatterplotmatrix.R b/tests/testthat/test-tm_g_scatterplotmatrix.R index 3af004318..1975b12a2 100644 --- a/tests/testthat/test-tm_g_scatterplotmatrix.R +++ b/tests/testthat/test-tm_g_scatterplotmatrix.R @@ -183,13 +183,13 @@ testthat::describe("tm_g_scatterplotmatrix module server behavior", { "variables-dataset_test_data_singleextract-select" = c("var1", "var2", "var3"), "cor" = FALSE, "alpha" = 0.5, - "cex" = 1 + "size" = 1.5 ) testthat::expect_true(iv_r()$is_valid()) output_result <- output_q() testthat::expect_true(inherits(output_result, "teal_data")) plot_result <- plot_r() - testthat::expect_true(inherits(plot_result, "trellis")) + testthat::expect_s3_class(plot_result, "patchwork") } ) }) @@ -219,13 +219,13 @@ testthat::describe("tm_g_scatterplotmatrix module server behavior", { "variables-dataset_test_data_singleextract-select" = c("var1", "var2"), "cor" = FALSE, "alpha" = 0.5, - "cex" = 1 + "size" = 1.5 ) testthat::expect_true(iv_r()$is_valid()) output_result <- output_q() testthat::expect_true(inherits(output_result, "teal_data")) plot_result <- plot_r() - testthat::expect_true(inherits(plot_result, "trellis")) + testthat::expect_s3_class(plot_result, "patchwork") } ) }) diff --git a/tests/testthat/test_scatterplotmatrix_get_stats.R b/tests/testthat/test_scatterplotmatrix_get_stats.R index 3554c9c09..de99d96d6 100644 --- a/tests/testthat/test_scatterplotmatrix_get_stats.R +++ b/tests/testthat/test_scatterplotmatrix_get_stats.R @@ -5,13 +5,25 @@ testthat::test_that("get_scatterplotmatrix_stats() x-y numeric", { x_na <- x x_na[c(3, 10, 18)] <- NA - corr <- get_scatterplotmatrix_stats(x_na, y, .f = cor.test, .f_args = list(method = "pearson")) + lifecycle::expect_deprecated({ + corr <- get_scatterplotmatrix_stats(x_na, y, .f = cor.test, .f_args = list(method = "pearson")) + }) testthat::expect_true(is.character(corr)) - corr <- get_scatterplotmatrix_stats(x_na, y, .f = cor.test, .f_args = list(method = "pearson", na.action = na.fail)) + lifecycle::expect_deprecated({ + corr <- get_scatterplotmatrix_stats( + x_na, y, + .f = cor.test, .f_args = list(method = "pearson", na.action = na.fail) + ) + }) testthat::expect_true(corr == "NA") - corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "pearson", na.action = na.fail)) + lifecycle::expect_deprecated({ + corr <- get_scatterplotmatrix_stats( + x, y, + .f = cor.test, .f_args = list(method = "pearson", na.action = na.fail) + ) + }) testthat::expect_true(corr != "NA") }) @@ -22,10 +34,16 @@ testthat::test_that("get_scatterplotmatrix_stats() x-y character", { x_na <- x x_na[c(3, 10, 18)] <- NA - corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "pearson")) + lifecycle::expect_deprecated({ + corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "pearson")) + }) testthat::expect_true(startsWith(corr, "cor")) - corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "kendall")) + lifecycle::expect_deprecated({ + corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "kendall")) + }) testthat::expect_true(startsWith(corr, "tau")) - corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "spearman")) + lifecycle::expect_deprecated({ + corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "spearman")) + }) testthat::expect_true(startsWith(corr, "rho")) }) diff --git a/vignettes/decorate-module-output.Rmd b/vignettes/decorate-module-output.Rmd index 321224e3e..ce374d2b8 100644 --- a/vignettes/decorate-module-output.Rmd +++ b/vignettes/decorate-module-output.Rmd @@ -48,7 +48,7 @@ You can also refer the table shown below to know which module outputs can be dec | `tm_g_distribution` | histogram_plot (ggplot), qq_plot (ggplot), summary_table (datatables), test_table (datatables) | | `tm_g_response` | plot (ggplot) | | `tm_g_scatterplot` | plot (ggplot) | -| `tm_g_scatterplotmatrix` | plot (trellis) | +| `tm_g_scatterplotmatrix` | plot (patchwork) | | `tm_missing_data` | summary_plot (grob), combination_plot (grob), by_subject_plot (ggplot), table (datatables) | | `tm_outliers` | box_plot (ggplot), density_plot (ggplot), cumulative_plot (ggplot), table (datatables) | | `tm_t_crosstable` | table (ElementaryTable) | @@ -57,9 +57,9 @@ Also, note that there are five different types of objects that can be decorated: 1. `ElementaryTable` 2. `ggplot` -3. `grob` -4. `datatables` -5. `trellis` +3. `patchwork` +4. `grob` +5. `datatables` *Tip:* A general tip before trying to decorate the output from the module is to copy the reproducible code and running them in a separate R session to @@ -426,12 +426,13 @@ url <- roxy.shinylive::create_shinylive_url(code) knitr::include_url(url, height = "800px") ``` -## Decorating `trellis` +## Decorating `patchwork` -Here's an example to showcase how you can edit an output of class `trellis`. -`rtables` modifiers like `rtables::insert_rrow` can be applied to modify this object. +Here's an example to showcase how you can edit an output of class `patchwork`. +Since `patchwork` objects support ggplot2-style addition, you can use `patchwork::plot_annotation()` and +standard ggplot2 theme modifications. -```{r decorate_trellis, message=FALSE} +```{r decorate_patchwork, message=FALSE} library(teal.modules.general) data <- teal_data(join_keys = default_cdisc_join_keys[c("ADSL", "ADRS")]) @@ -441,19 +442,19 @@ data <- within(data, { ADRS <- rADRS }) -trellis_subtitle_decorator <- function(default_caption = "I am a good decorator") { +patchwork_title_decorator <- function(default_title = "I am a good decorator") { teal_transform_module( - label = "Caption", - ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Footnote", value = default_caption), + label = "Title", + ui = function(id) shiny::textInput(shiny::NS(id, "title"), "Plot Title", value = default_title), server = function(id, data) { moduleServer(id, function(input, output, session) { reactive({ data() |> within( { - plot <- update(plot, sub = footnote) + plot <- plot + patchwork::plot_annotation(title = plot_title) }, - footnote = input$footnote + plot_title = input$title ) }) }) @@ -494,7 +495,7 @@ app <- init( ) ), decorators = list( - plot = trellis_subtitle_decorator("I am a Scatterplot matrix") + plot = patchwork_title_decorator("I am a Scatterplot matrix") ) ) ) @@ -509,7 +510,7 @@ if (interactive()) { code <- paste0(c( "interactive <- function() TRUE", knitr::knit_code$get("setup"), - knitr::knit_code$get("decorate_trellis") + knitr::knit_code$get("decorate_patchwork") ), collapse = "\n") url <- roxy.shinylive::create_shinylive_url(code) diff --git a/vignettes/using-scatterplot-matrix.Rmd b/vignettes/using-scatterplot-matrix.Rmd index 7bda48acc..37e285d2e 100644 --- a/vignettes/using-scatterplot-matrix.Rmd +++ b/vignettes/using-scatterplot-matrix.Rmd @@ -24,7 +24,6 @@ various types of datasets using the scatter plot matrix module `tm_g_scatterplot ```{r library, echo=TRUE, message=FALSE, warning=FALSE, results="hide"} library(teal.modules.general) # used to create the app library(dplyr) # used to modify data sets -library(lattice) ``` ## 2 - Create data sets From 98f83d821edfddbff90a228c6fbbf4dd4ef75ad7 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Tue, 24 Feb 2026 10:07:14 +0000 Subject: [PATCH 02/25] [skip style] [skip vbump] Restyle files --- R/tm_g_scatterplotmatrix.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index ecd7b1cfc..052d3a6d1 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -460,7 +460,8 @@ srv_g_scatterplotmatrix <- function(id, fontface = "bold", color = cor_color ) + - ggplot2::xlim(0, 1) + ggplot2::ylim(0, 1) + + ggplot2::xlim(0, 1) + + ggplot2::ylim(0, 1) + ggplot2::theme_void() } else { # lower triangle: scatter/box plot From b89a623c0eec2c2e6d2df16033be80a88ba77e4e Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Tue, 24 Feb 2026 10:15:25 +0000 Subject: [PATCH 03/25] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/get_scatterplotmatrix_stats.Rd | 13 ++----------- man/tm_g_scatterplotmatrix.Rd | 2 +- 2 files changed, 3 insertions(+), 12 deletions(-) diff --git a/man/get_scatterplotmatrix_stats.Rd b/man/get_scatterplotmatrix_stats.Rd index 176b24cb1..52b6f9e15 100644 --- a/man/get_scatterplotmatrix_stats.Rd +++ b/man/get_scatterplotmatrix_stats.Rd @@ -29,20 +29,11 @@ Default \code{stats::cor.test}.} Character with stats. For \code{\link[stats:cor.test]{stats::cor.test()}} correlation coefficient and p-value. } \description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} + Uses \code{\link[stats:cor.test]{stats::cor.test()}} per default for all numerical input variables and converts results to character vector. Could be extended if different stats for different variable types are needed. -Meant to be called from \code{\link[lattice:llines]{lattice::panel.text()}}. -} -\details{ -Presently we need to use a formula input for \code{stats::cor.test} because -\code{na.fail} only gets evaluated when a formula is passed (see below). - -\if{html}{\out{
}}\preformatted{x = c(1,3,5,7,NA) -y = c(3,6,7,8,1) -stats::cor.test(x, y, na.action = "na.fail") -stats::cor.test(~ x + y, na.action = "na.fail") -}\if{html}{\out{
}} } \examples{ set.seed(1) diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index ba9c4c3d9..8fd182eb5 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -64,7 +64,7 @@ For more examples, please see the vignette "Using scatterplot matrix" via This module generates the following objects, which can be modified in place using decorators: \itemize{ -\item \code{plot} (\code{trellis} - output of \code{lattice::splom}) +\item \code{plot} (\code{patchwork} - assembled from individual \code{ggplot} panels) } A Decorator is applied to the specific output using a named list of \code{teal_transform_module} objects. From f71fa938ea1d78cb30e26cee6936e644d2d91b74 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Mar 2026 09:26:32 +0100 Subject: [PATCH 04/25] applied feedback --- R/tm_g_scatterplotmatrix.R | 381 ++++++++++++++++--------------------- 1 file changed, 167 insertions(+), 214 deletions(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index cc9c3dc57..e5b0fca72 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -284,7 +284,18 @@ ui_g_scatterplotmatrix <- function(id, ...) { choiceValues = c("pearson", "kendall", "spearman"), inline = TRUE ), - checkboxInput(ns("cor_na_omit"), "Pairwise Complete Observations", value = TRUE) + selectInput( + ns("cor_use"), + "NA handling:", + choices = c( + "Everything" = "everything", + "All observations" = "all.obs", + "Complete observations" = "complete.obs", + "NA or complete" = "na.or.complete", + "Pairwise complete" = "pairwise.complete.obs" + ), + selected = "pairwise.complete.obs" + ) ) ) ), @@ -351,13 +362,7 @@ srv_g_scatterplotmatrix <- function(id, size_val <- input$size add_cor <- input$cor cor_method <- input$cor_method - cor_na_omit <- input$cor_na_omit - - cor_use <- if (isTruthy(cor_na_omit)) { - "pairwise.complete.obs" - } else { - "everything" - } + cor_use <- input$cor_use teal::validate_has_data(ANL, 10) teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) @@ -368,23 +373,19 @@ srv_g_scatterplotmatrix <- function(id, # check character columns. If any, then those are converted to factors check_char <- vapply(ANL[, cols_names], is.character, logical(1)) if (any(check_char)) { - qenv <- teal.code::eval_code( + qenv <- within( qenv, - substitute( - expr = ANL <- ANL[, cols_names] %>% - dplyr::mutate_if(is.character, as.factor) %>% - droplevels(), - env = list(cols_names = cols_names) - ) + ANL <- ANL[, cols_names] %>% + dplyr::mutate_if(is.character, as.factor) %>% + droplevels(), + cols_names = cols_names ) } else { - qenv <- teal.code::eval_code( + qenv <- within( qenv, - substitute( - expr = ANL <- ANL[, cols_names] %>% - droplevels(), - env = list(cols_names = cols_names) - ) + ANL <- ANL[, cols_names] %>% + droplevels(), + cols_names = cols_names ) } @@ -393,216 +394,168 @@ srv_g_scatterplotmatrix <- function(id, if (add_cor) { shinyjs::show("cor_method") - shinyjs::show("cor_na_omit") + shinyjs::show("cor_use") - qenv <- teal.code::eval_code( + qenv <- within( qenv, - substitute( - expr = { - col_names <- names(ANL) - n_vars <- length(col_names) - plot_list <- list() - for (i in seq_len(n_vars)) { - for (j in seq_len(n_vars)) { - vi <- col_names[i] - vj <- col_names[j] - if (i == j) { - # diagonal: density for numeric, bar for factor - if (is.numeric(ANL[[vi]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]])) + - ggplot2::geom_density(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::ggtitle(varnames_value[i]) + - ggplot2::theme_minimal() + - ggplot2::theme( - plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), - axis.text = ggplot2::element_text(size = 7) - ) - } else { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]])) + - ggplot2::geom_bar(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::ggtitle(varnames_value[i]) + - ggplot2::theme_minimal() + - ggplot2::theme( - plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), - axis.text = ggplot2::element_text(size = 7), - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) - ) - } - } else if (i < j) { - # upper triangle: correlation text - if (is.numeric(ANL[[vi]]) && is.numeric(ANL[[vj]])) { - cor_val <- tryCatch( - stats::cor(ANL[[vi]], ANL[[vj]], method = cor_method_value, use = cor_use_value), - error = function(e) NA_real_ - ) - cor_label <- if (is.na(cor_val)) "NA" else sprintf("%.3f", cor_val) - cor_size <- max(3, abs(cor_val) * 8 + 3) - cor_color <- if (is.na(cor_val)) { - "grey50" - } else if (cor_val > 0) { - "firebrick" - } else { - "steelblue" - } - } else { - cor_label <- "-" - cor_size <- 4 - cor_color <- "grey50" - } - p <- ggplot2::ggplot() + - ggplot2::annotate( - "text", - x = 0.5, y = 0.5, - label = cor_label, - size = cor_size, - fontface = "bold", - color = cor_color - ) + - ggplot2::xlim(0, 1) + - ggplot2::ylim(0, 1) + - ggplot2::theme_void() + { + col_names <- names(ANL) + n_vars <- length(col_names) + plot_list <- list() + for (i in seq_len(n_vars)) { + for (j in seq_len(n_vars)) { + col_name_i <- col_names[i] + col_name_j <- col_names[j] + if (i == j) { + # diagonal: density for numeric, bar for factor + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_i]])) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::ggtitle(varnames_value[i]) + p <- if (is.numeric(ANL[[col_name_i]])) { + p + ggplot2::geom_density(fill = "steelblue", alpha = 0.5) } else { - # lower triangle: scatter/box plot - if (is.numeric(ANL[[vj]]) && is.numeric(ANL[[vi]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], y = .data[[vi]])) + - ggplot2::geom_point(alpha = alpha_value, size = size_value, color = "steelblue") + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::theme_minimal() + - ggplot2::theme(axis.text = ggplot2::element_text(size = 7)) - } else if (is.factor(ANL[[vj]]) && is.numeric(ANL[[vi]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], y = .data[[vi]])) + - ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::theme_minimal() + - ggplot2::theme( - axis.text = ggplot2::element_text(size = 7), - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) - ) - } else if (is.numeric(ANL[[vj]]) && is.factor(ANL[[vi]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]], y = .data[[vj]])) + - ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::theme_minimal() + - ggplot2::theme( - axis.text = ggplot2::element_text(size = 7), - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) - ) + - ggplot2::coord_flip() + p + + ggplot2::geom_bar(fill = "steelblue", alpha = 0.5) + + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) + } + } else if (i < j) { + # upper triangle: correlation text + if (is.numeric(ANL[[col_name_i]]) && is.numeric(ANL[[col_name_j]])) { + cor_val <- tryCatch( + stats::cor(ANL[[col_name_i]], ANL[[col_name_j]], method = cor_method_value, use = cor_use_value), + error = function(e) NA_real_ + ) + cor_label <- if (is.na(cor_val)) "NA" else sprintf("%.3f", cor_val) + cor_size <- max(3, abs(cor_val) * 8 + 3) + cor_color <- if (is.na(cor_val)) { + "grey50" + } else if (cor_val > 0) { + "firebrick" } else { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], fill = .data[[vi]])) + - ggplot2::geom_bar(position = "dodge", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL, fill = NULL) + - ggplot2::theme_minimal() + - ggplot2::theme( - axis.text = ggplot2::element_text(size = 7), - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), - legend.position = "none" - ) + "steelblue" } + } else { + cor_label <- "-" + cor_size <- 4 + cor_color <- "grey50" + } + p <- ggplot2::ggplot() + + ggplot2::annotate( + "text", + x = 0.5, y = 0.5, + label = cor_label, + size = cor_size, + fontface = "bold", + color = cor_color + ) + + ggplot2::xlim(0, 1) + + ggplot2::ylim(0, 1) + + ggplot2::theme_void() + } else { + # lower triangle: scatter/box plot + if (is.numeric(ANL[[col_name_j]]) && is.numeric(ANL[[col_name_i]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], y = .data[[col_name_i]])) + + ggplot2::geom_point(alpha = alpha_value, size = size_value, color = "steelblue") + + ggplot2::labs(x = NULL, y = NULL) + } else if (is.factor(ANL[[col_name_j]]) && is.numeric(ANL[[col_name_i]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], y = .data[[col_name_i]])) + + ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) + } else if (is.numeric(ANL[[col_name_j]]) && is.factor(ANL[[col_name_i]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_i]], y = .data[[col_name_j]])) + + ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::coord_flip() + } else { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], fill = .data[[col_name_i]])) + + ggplot2::geom_bar(position = "dodge", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL, fill = NULL) + + ggplot2::theme( + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), + legend.position = "none" + ) } - plot_list[[(i - 1) * n_vars + j]] <- p } + plot_list[[(i - 1) * n_vars + j]] <- p } - plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) - }, - env = list( - varnames_value = varnames, - cor_method_value = cor_method, - cor_use_value = cor_use, - alpha_value = alpha_val, - size_value = size_val - ) - ) + } + plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) & + ggplot2::theme_minimal() & + ggplot2::theme( + plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), + axis.text = ggplot2::element_text(size = 7) + ) + }, + varnames_value = varnames, + cor_method_value = cor_method, + cor_use_value = cor_use, + alpha_value = alpha_val, + size_value = size_val ) } else { shinyjs::hide("cor_method") - shinyjs::hide("cor_na_omit") + shinyjs::hide("cor_use") - qenv <- teal.code::eval_code( + qenv <- within( qenv, - substitute( - expr = { - col_names <- names(ANL) - n_vars <- length(col_names) - plot_list <- list() - for (i in seq_len(n_vars)) { - for (j in seq_len(n_vars)) { - vi <- col_names[i] - vj <- col_names[j] - if (i == j) { - if (is.numeric(ANL[[vi]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]])) + - ggplot2::geom_density(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::ggtitle(varnames_value[i]) + - ggplot2::theme_minimal() + - ggplot2::theme( - plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), - axis.text = ggplot2::element_text(size = 7) - ) - } else { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]])) + - ggplot2::geom_bar(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::ggtitle(varnames_value[i]) + - ggplot2::theme_minimal() + - ggplot2::theme( - plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), - axis.text = ggplot2::element_text(size = 7), - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) - ) - } + { + col_names <- names(ANL) + n_vars <- length(col_names) + plot_list <- list() + for (i in seq_len(n_vars)) { + for (j in seq_len(n_vars)) { + col_name_i <- col_names[i] + col_name_j <- col_names[j] + if (i == j) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_i]])) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::ggtitle(varnames_value[i]) + p <- if (is.numeric(ANL[[col_name_i]])) { + p + ggplot2::geom_density(fill = "steelblue", alpha = 0.5) } else { - if (is.numeric(ANL[[vj]]) && is.numeric(ANL[[vi]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], y = .data[[vi]])) + - ggplot2::geom_point(alpha = alpha_value, size = size_value, color = "steelblue") + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::theme_minimal() + - ggplot2::theme(axis.text = ggplot2::element_text(size = 7)) - } else if (is.factor(ANL[[vj]]) && is.numeric(ANL[[vi]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], y = .data[[vi]])) + - ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::theme_minimal() + - ggplot2::theme( - axis.text = ggplot2::element_text(size = 7), - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) - ) - } else if (is.numeric(ANL[[vj]]) && is.factor(ANL[[vi]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vi]], y = .data[[vj]])) + - ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::theme_minimal() + - ggplot2::theme( - axis.text = ggplot2::element_text(size = 7), - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1) - ) + - ggplot2::coord_flip() - } else { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[vj]], fill = .data[[vi]])) + - ggplot2::geom_bar(position = "dodge", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL, fill = NULL) + - ggplot2::theme_minimal() + - ggplot2::theme( - axis.text = ggplot2::element_text(size = 7), - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), - legend.position = "none" - ) - } + p + + ggplot2::geom_bar(fill = "steelblue", alpha = 0.5) + + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) + } + } else { + if (is.numeric(ANL[[col_name_j]]) && is.numeric(ANL[[col_name_i]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], y = .data[[col_name_i]])) + + ggplot2::geom_point(alpha = alpha_value, size = size_value, color = "steelblue") + + ggplot2::labs(x = NULL, y = NULL) + } else if (is.factor(ANL[[col_name_j]]) && is.numeric(ANL[[col_name_i]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], y = .data[[col_name_i]])) + + ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) + } else if (is.numeric(ANL[[col_name_j]]) && is.factor(ANL[[col_name_i]])) { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_i]], y = .data[[col_name_j]])) + + ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL) + + ggplot2::coord_flip() + } else { + p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], fill = .data[[col_name_i]])) + + ggplot2::geom_bar(position = "dodge", alpha = 0.5) + + ggplot2::labs(x = NULL, y = NULL, fill = NULL) + + ggplot2::theme( + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), + legend.position = "none" + ) } - plot_list[[(i - 1) * n_vars + j]] <- p } + plot_list[[(i - 1) * n_vars + j]] <- p } - plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) - }, - env = list( - varnames_value = varnames, - alpha_value = alpha_val, - size_value = size_val - ) - ) + } + plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) & + ggplot2::theme_minimal() & + ggplot2::theme( + plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), + axis.text = ggplot2::element_text(size = 7) + ) + }, + varnames_value = varnames, + alpha_value = alpha_val, + size_value = size_val ) } qenv From dccf03e1646d17e53d60e0c81cdda66352a36fbe Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Mar 2026 14:50:22 +0100 Subject: [PATCH 05/25] remove duplication --- R/tm_a_regression.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index e54f2aef2..3dca32fad 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -230,7 +230,6 @@ tm_a_regression <- function(label = "Regression Analysis", checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices))) checkmate::assert_string(default_outlier_label) - assert_decorators(decorators) if (length(label_segment_threshold) == 1) { checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE) From 6c10564456649ec78f50f7578cc78cc167f312e1 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Mar 2026 15:00:04 +0100 Subject: [PATCH 06/25] improve calidate_qenv --- R/utils.R | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/R/utils.R b/R/utils.R index 80e5b14b3..7b22607e2 100644 --- a/R/utils.R +++ b/R/utils.R @@ -362,12 +362,13 @@ set_chunk_dims <- function(pws, q_r, inner_classes = NULL) { }) } - validate_qenv <- function(qenv) { - validate( - need( - inherits(qenv, "qenv"), - sub("when evaluating qenv", "when evaluating", qenv$message, fixed = TRUE) + if (inherits(qenv, "qenv.error")) { + validate( + need( + FALSE, + sub("when evaluating qenv", "when evaluating", qenv$message, fixed = TRUE) + ) ) - ) + } } From 4b0dd87ad5895bd57d68dc80301f7953d8c85fdc Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Mar 2026 15:09:48 +0100 Subject: [PATCH 07/25] rename file to keep the same naming convention --- ...atrix_get_stats.R => test-tm_g_scatterplotmatrix_get_stats.R} | 1 + 1 file changed, 1 insertion(+) rename tests/testthat/{test_scatterplotmatrix_get_stats.R => test-tm_g_scatterplotmatrix_get_stats.R} (99%) diff --git a/tests/testthat/test_scatterplotmatrix_get_stats.R b/tests/testthat/test-tm_g_scatterplotmatrix_get_stats.R similarity index 99% rename from tests/testthat/test_scatterplotmatrix_get_stats.R rename to tests/testthat/test-tm_g_scatterplotmatrix_get_stats.R index de99d96d6..f3e5ceb49 100644 --- a/tests/testthat/test_scatterplotmatrix_get_stats.R +++ b/tests/testthat/test-tm_g_scatterplotmatrix_get_stats.R @@ -47,3 +47,4 @@ testthat::test_that("get_scatterplotmatrix_stats() x-y character", { }) testthat::expect_true(startsWith(corr, "rho")) }) + From fe96a1d7a262a5620fd13a0c9342ca0407cd846d Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Mar 2026 15:11:02 +0100 Subject: [PATCH 08/25] revert changes on validate_qenv --- R/utils.R | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/R/utils.R b/R/utils.R index 7b22607e2..dd8bac846 100644 --- a/R/utils.R +++ b/R/utils.R @@ -363,12 +363,10 @@ set_chunk_dims <- function(pws, q_r, inner_classes = NULL) { } validate_qenv <- function(qenv) { - if (inherits(qenv, "qenv.error")) { - validate( - need( - FALSE, - sub("when evaluating qenv", "when evaluating", qenv$message, fixed = TRUE) - ) + validate( + need( + inherits(qenv, "qenv"), + sub("when evaluating qenv", "when evaluating", qenv$message, fixed = TRUE) ) - } + ) } From 725ed2456cf3b59b56d8e17d32fb75f271a26b9a Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 10 Mar 2026 10:09:10 +0100 Subject: [PATCH 09/25] remove get_scatterplotmatrix_stats --- NAMESPACE | 1 - NEWS.md | 8 +++ _pkgdown.yml | 1 - man/get_scatterplotmatrix_stats.Rd | 50 ------------------- .../test-tm_g_scatterplotmatrix_get_stats.R | 50 ------------------- 5 files changed, 8 insertions(+), 102 deletions(-) delete mode 100644 man/get_scatterplotmatrix_stats.Rd delete mode 100644 tests/testthat/test-tm_g_scatterplotmatrix_get_stats.R diff --git a/NAMESPACE b/NAMESPACE index 526def0d8..4e5991d45 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,7 +12,6 @@ S3method(teal.reporter::to_rmd,markdown_internal) S3method(tools::toHTML,markdown_internal) export(add_facet_labels) export(geom_mosaic) -export(get_scatterplotmatrix_stats) export(tm_a_pca) export(tm_a_regression) export(tm_data_table) diff --git a/NEWS.md b/NEWS.md index 6cf39fca8..ec0495cd4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,14 @@ - Improve `tm_missing_data` visualization (#495). - Multiple decorators can be applied to the same output object (#978). - Introduced `tm_gtsummary()`, a new module for generating tables using the [gtsummary](https://cran.r-project.org/package=gtsummary) package (#973). +- `tm_g_scatterplotmatrix()` has been rewritten to use `ggplot2` and `patchwork` + instead of `lattice`. Panel text scales automatically with the number of + variables so labels remain readable at any matrix size. Plot construction has + been optimised to pass per-column vectors instead of the full data frame to + each panel, reducing render time for large variable sets. NA handling retains + the familiar **Omit NAs** checkbox (default, `use = "pairwise.complete.obs"`); + unchecking it reveals a dropdown with all five `stats::cor()` `use` options. + `get_scatterplotmatrix_stats()` has been removed (#986). # teal.modules.general 0.5.1 diff --git a/_pkgdown.yml b/_pkgdown.yml index 69ace7c96..e22eb4698 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -43,4 +43,3 @@ reference: - title: Utilities functions contents: - add_facet_labels - - get_scatterplotmatrix_stats diff --git a/man/get_scatterplotmatrix_stats.Rd b/man/get_scatterplotmatrix_stats.Rd deleted file mode 100644 index 52b6f9e15..000000000 --- a/man/get_scatterplotmatrix_stats.Rd +++ /dev/null @@ -1,50 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_scatterplotmatrix.R -\name{get_scatterplotmatrix_stats} -\alias{get_scatterplotmatrix_stats} -\title{Get stats for x-y pairs in scatterplot matrix} -\usage{ -get_scatterplotmatrix_stats( - x, - y, - .f = stats::cor.test, - .f_args = list(), - round_stat = 2, - round_pval = 4 -) -} -\arguments{ -\item{x, y}{(\code{numeric}) vectors of data values. \code{x} and \code{y} must have the same length.} - -\item{.f}{(\code{function}) function that accepts x and y as formula input \code{~ x + y}. -Default \code{stats::cor.test}.} - -\item{.f_args}{(\code{list}) of arguments to be passed to \code{.f}.} - -\item{round_stat}{(\code{integer(1)}) optional, number of decimal places to use when rounding the estimate.} - -\item{round_pval}{(\code{integer(1)}) optional, number of decimal places to use when rounding the p-value.} -} -\value{ -Character with stats. For \code{\link[stats:cor.test]{stats::cor.test()}} correlation coefficient and p-value. -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} - -Uses \code{\link[stats:cor.test]{stats::cor.test()}} per default for all numerical input variables and converts results -to character vector. -Could be extended if different stats for different variable types are needed. -} -\examples{ -set.seed(1) -x <- runif(25, 0, 1) -y <- runif(25, 0, 1) -x[c(3, 10, 18)] <- NA - -get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) -get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( - method = "pearson", - na.action = na.fail -)) - -} diff --git a/tests/testthat/test-tm_g_scatterplotmatrix_get_stats.R b/tests/testthat/test-tm_g_scatterplotmatrix_get_stats.R deleted file mode 100644 index f3e5ceb49..000000000 --- a/tests/testthat/test-tm_g_scatterplotmatrix_get_stats.R +++ /dev/null @@ -1,50 +0,0 @@ -testthat::test_that("get_scatterplotmatrix_stats() x-y numeric", { - set.seed(1) - x <- runif(25, 0, 1) - y <- runif(25, 0, 1) - x_na <- x - x_na[c(3, 10, 18)] <- NA - - lifecycle::expect_deprecated({ - corr <- get_scatterplotmatrix_stats(x_na, y, .f = cor.test, .f_args = list(method = "pearson")) - }) - testthat::expect_true(is.character(corr)) - - lifecycle::expect_deprecated({ - corr <- get_scatterplotmatrix_stats( - x_na, y, - .f = cor.test, .f_args = list(method = "pearson", na.action = na.fail) - ) - }) - testthat::expect_true(corr == "NA") - - lifecycle::expect_deprecated({ - corr <- get_scatterplotmatrix_stats( - x, y, - .f = cor.test, .f_args = list(method = "pearson", na.action = na.fail) - ) - }) - testthat::expect_true(corr != "NA") -}) - -testthat::test_that("get_scatterplotmatrix_stats() x-y character", { - x <- LETTERS[runif(25, 0, 10)] - y <- LETTERS[runif(25, 0, 10)] - - x_na <- x - x_na[c(3, 10, 18)] <- NA - - lifecycle::expect_deprecated({ - corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "pearson")) - }) - testthat::expect_true(startsWith(corr, "cor")) - lifecycle::expect_deprecated({ - corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "kendall")) - }) - testthat::expect_true(startsWith(corr, "tau")) - lifecycle::expect_deprecated({ - corr <- get_scatterplotmatrix_stats(x, y, .f = cor.test, .f_args = list(method = "spearman")) - }) - testthat::expect_true(startsWith(corr, "rho")) -}) - From a95fe74546ae874c3d58c8e5b3ab6e92e6f546d4 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 11 Mar 2026 14:35:11 +0100 Subject: [PATCH 10/25] apply feedback for tm_g_scatterplotmatrix --- R/tm_g_scatterplotmatrix.R | 401 +++++++++++++------------------------ 1 file changed, 141 insertions(+), 260 deletions(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index e5b0fca72..da13aaa0f 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -7,6 +7,11 @@ #' @note For more examples, please see the vignette "Using scatterplot matrix" via #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`. #' +#' @note When *Add Correlation* is enabled, a simple **Omit NAs** checkbox +#' controls NA handling (checked = `"pairwise.complete.obs"`, matching the +#' historical default). Unchecking it reveals a dropdown with all five +#' `stats::cor()` `use` options for advanced control. +#' #' @inheritParams teal::module #' @inheritParams tm_g_scatterplot #' @inheritParams shared_params @@ -272,29 +277,63 @@ ui_g_scatterplotmatrix <- function(id, ...) { min = 0, max = 1, step = .05, value = .5, ticks = FALSE ), - sliderInput( - ns("size"), "Points size:", - min = 0.5, max = 5, - step = .25, value = 1.5, ticks = FALSE - ), checkboxInput(ns("cor"), "Add Correlation", value = FALSE), - radioButtons( - ns("cor_method"), "Select Correlation Method", - choiceNames = c("Pearson", "Kendall", "Spearman"), - choiceValues = c("pearson", "kendall", "spearman"), - inline = TRUE + shinyjs::hidden( + radioButtons( + ns("cor_method"), "Select Correlation Method", + choiceNames = c("Pearson", "Kendall", "Spearman"), + choiceValues = c("pearson", "kendall", "spearman"), + inline = TRUE + ) ), - selectInput( - ns("cor_use"), - "NA handling:", - choices = c( - "Everything" = "everything", - "All observations" = "all.obs", - "Complete observations" = "complete.obs", - "NA or complete" = "na.or.complete", - "Pairwise complete" = "pairwise.complete.obs" - ), - selected = "pairwise.complete.obs" + shinyjs::hidden( + checkboxInput( + ns("cor_na_omit"), + label = tags$span( + "Omit NAs", + bslib::popover( + icon("circle-info"), + title = "NA handling", + tags$p(tags$b("Checked:"), "use pairwise complete observations (each pair correlated over rows where both values are present)."), + tags$p(tags$b("Unchecked:"), "reveals a dropdown with all five", tags$code("stats::cor()"), "use= options."), + options = list(trigger = "hover focus") + ) + ), + value = TRUE + ) + ), + shinyjs::hidden( + selectInput( + ns("cor_use"), + label = tags$span( + "NA handling:", + bslib::popover( + icon("circle-info"), + title = "NA handling options", + tags$dl( + tags$dt("Everything"), + tags$dd("Return NA for a pair if either variable contains any missing value."), + tags$dt("All observations"), + tags$dd("Assume no NAs are present; throws an error if any are found."), + tags$dt("Complete observations"), + tags$dd("Listwise deletion – only rows with no NAs across all selected variables."), + tags$dt("NA or complete"), + tags$dd("Like complete observations but returns NA instead of an error when no complete cases exist."), + tags$dt("Pairwise complete"), + tags$dd("Use all rows where both variables in a pair are non-missing (maximises available data).") + ), + options = list(trigger = "hover focus") + ) + ), + choices = c( + "Everything" = "everything", + "All observations" = "all.obs", + "Complete observations" = "complete.obs", + "NA or complete" = "na.or.complete", + "Pairwise complete" = "pairwise.complete.obs" + ), + selected = "everything" + ) ) ) ) @@ -320,7 +359,10 @@ srv_g_scatterplotmatrix <- function(id, data_extract = list(variables = variables), datasets = data, select_validation_rule = list( - variables = ~ if (length(.) <= 1) "Please select at least 2 columns." + variables = shinyvalidate::compose_rules( + ~ if (length(.) <= 1) "Please select at least 2 columns.", + ~ if (length(.) > 5) "Please select at most 5 columns." + ) ) ) @@ -332,7 +374,7 @@ srv_g_scatterplotmatrix <- function(id, anl_merged_input <- teal.transform::merge_expression_srv( datasets = data, selector_list = selector_list - ) + ) |> debounce(500) anl_merged_q <- reactive({ req(anl_merged_input()) @@ -359,10 +401,10 @@ srv_g_scatterplotmatrix <- function(id, cols_names <- merged$anl_input_r()$columns_source$variables alpha_val <- input$alpha - size_val <- input$size add_cor <- input$cor cor_method <- input$cor_method - cor_use <- input$cor_use + cor_na_omit <- input$cor_na_omit + cor_use <- if (isTRUE(cor_na_omit)) "pairwise.complete.obs" else input$cor_use teal::validate_has_data(ANL, 10) teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) @@ -394,170 +436,86 @@ srv_g_scatterplotmatrix <- function(id, if (add_cor) { shinyjs::show("cor_method") - shinyjs::show("cor_use") - - qenv <- within( - qenv, - { - col_names <- names(ANL) - n_vars <- length(col_names) - plot_list <- list() - for (i in seq_len(n_vars)) { - for (j in seq_len(n_vars)) { - col_name_i <- col_names[i] - col_name_j <- col_names[j] - if (i == j) { - # diagonal: density for numeric, bar for factor - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_i]])) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::ggtitle(varnames_value[i]) - p <- if (is.numeric(ANL[[col_name_i]])) { - p + ggplot2::geom_density(fill = "steelblue", alpha = 0.5) - } else { - p + - ggplot2::geom_bar(fill = "steelblue", alpha = 0.5) + - ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) - } - } else if (i < j) { - # upper triangle: correlation text - if (is.numeric(ANL[[col_name_i]]) && is.numeric(ANL[[col_name_j]])) { - cor_val <- tryCatch( - stats::cor(ANL[[col_name_i]], ANL[[col_name_j]], method = cor_method_value, use = cor_use_value), - error = function(e) NA_real_ - ) - cor_label <- if (is.na(cor_val)) "NA" else sprintf("%.3f", cor_val) - cor_size <- max(3, abs(cor_val) * 8 + 3) - cor_color <- if (is.na(cor_val)) { - "grey50" - } else if (cor_val > 0) { - "firebrick" - } else { - "steelblue" - } - } else { - cor_label <- "-" - cor_size <- 4 - cor_color <- "grey50" - } - p <- ggplot2::ggplot() + - ggplot2::annotate( - "text", - x = 0.5, y = 0.5, - label = cor_label, - size = cor_size, - fontface = "bold", - color = cor_color - ) + - ggplot2::xlim(0, 1) + - ggplot2::ylim(0, 1) + - ggplot2::theme_void() - } else { - # lower triangle: scatter/box plot - if (is.numeric(ANL[[col_name_j]]) && is.numeric(ANL[[col_name_i]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], y = .data[[col_name_i]])) + - ggplot2::geom_point(alpha = alpha_value, size = size_value, color = "steelblue") + - ggplot2::labs(x = NULL, y = NULL) - } else if (is.factor(ANL[[col_name_j]]) && is.numeric(ANL[[col_name_i]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], y = .data[[col_name_i]])) + - ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) - } else if (is.numeric(ANL[[col_name_j]]) && is.factor(ANL[[col_name_i]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_i]], y = .data[[col_name_j]])) + - ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::coord_flip() - } else { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], fill = .data[[col_name_i]])) + - ggplot2::geom_bar(position = "dodge", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL, fill = NULL) + - ggplot2::theme( - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), - legend.position = "none" - ) - } - } - plot_list[[(i - 1) * n_vars + j]] <- p - } - } - plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) & - ggplot2::theme_minimal() & - ggplot2::theme( - plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), - axis.text = ggplot2::element_text(size = 7) - ) - }, - varnames_value = varnames, - cor_method_value = cor_method, - cor_use_value = cor_use, - alpha_value = alpha_val, - size_value = size_val - ) + shinyjs::show("cor_na_omit") + if (isTRUE(cor_na_omit)) { + shinyjs::hide("cor_use") + } else { + shinyjs::show("cor_use") + } } else { shinyjs::hide("cor_method") + shinyjs::hide("cor_na_omit") shinyjs::hide("cor_use") + } - qenv <- within( - qenv, - { - col_names <- names(ANL) - n_vars <- length(col_names) - plot_list <- list() - for (i in seq_len(n_vars)) { - for (j in seq_len(n_vars)) { - col_name_i <- col_names[i] - col_name_j <- col_names[j] - if (i == j) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_i]])) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::ggtitle(varnames_value[i]) - p <- if (is.numeric(ANL[[col_name_i]])) { - p + ggplot2::geom_density(fill = "steelblue", alpha = 0.5) - } else { - p + - ggplot2::geom_bar(fill = "steelblue", alpha = 0.5) + - ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) - } - } else { - if (is.numeric(ANL[[col_name_j]]) && is.numeric(ANL[[col_name_i]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], y = .data[[col_name_i]])) + - ggplot2::geom_point(alpha = alpha_value, size = size_value, color = "steelblue") + - ggplot2::labs(x = NULL, y = NULL) - } else if (is.factor(ANL[[col_name_j]]) && is.numeric(ANL[[col_name_i]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], y = .data[[col_name_i]])) + - ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) - } else if (is.numeric(ANL[[col_name_j]]) && is.factor(ANL[[col_name_i]])) { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_i]], y = .data[[col_name_j]])) + - ggplot2::geom_boxplot(fill = "steelblue", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL) + - ggplot2::coord_flip() - } else { - p <- ggplot2::ggplot(ANL, ggplot2::aes(x = .data[[col_name_j]], fill = .data[[col_name_i]])) + - ggplot2::geom_bar(position = "dodge", alpha = 0.5) + - ggplot2::labs(x = NULL, y = NULL, fill = NULL) + - ggplot2::theme( - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), - legend.position = "none" - ) - } - } - plot_list[[(i - 1) * n_vars + j]] <- p + qenv <- within( + qenv, + { + add_cor <- add_cor_value + cor_method <- cor_method_value + cor_use <- cor_use_value + alpha <- alpha_value + varnames <- varnames_value + + col_names <- names(ANL) + n_vars <- length(col_names) + base_size <- max(6L, 14L - n_vars) + + num_idx <- which(vapply(ANL, is.numeric, logical(1L))) + cor_mat <- if (add_cor && length(num_idx) >= 2L) { + tryCatch( + stats::cor(ANL[num_idx], method = cor_method, use = cor_use), + error = function(e) NULL + ) + } + + make_panel <- function(i, j) { + xi <- ANL[[col_names[i]]] + xj <- ANL[[col_names[j]]] + if (i == j) { + p <- ggplot2::ggplot(data.frame(x = xi), ggplot2::aes(x = x)) + + ggplot2::labs(x = NULL, y = NULL, title = varnames[i]) + if (is.numeric(xi)) { + p <- p + ggplot2::geom_density(fill = "steelblue", alpha = alpha) + } else { + p <- p + ggplot2::geom_bar(fill = "steelblue", alpha = alpha) } + } else if (i < j && add_cor) { + cv <- if (!is.null(cor_mat) && is.numeric(xi) && is.numeric(xj)) cor_mat[col_names[i], col_names[j]] else NA_real_ + col <- if (is.na(cv)) "grey50" else if (cv > 0) "firebrick" else "steelblue" + ggplot2::ggplot() + + ggplot2::annotate("text", x = 0.5, y = 0.5, fontface = "bold", color = col, + label = if (!is.na(cv)) sprintf("%.2f", cv) else if (is.numeric(xi) && is.numeric(xj)) "NA" else "-", + size = if (!is.na(cv)) max(3, abs(cv) * 8 + 3) else if (is.numeric(xi) && is.numeric(xj)) 3 else 4) + + ggplot2::xlim(0, 1) + ggplot2::ylim(0, 1) + ggplot2::theme_void() + } else { + p <- ggplot2::ggplot(data.frame(x = xj, y = xi)) + ggplot2::labs(x = NULL, y = NULL) + ggplot2::aes(x = x, y = y) + n_num <- is.numeric(xi) + is.numeric(xj) + if (n_num == 2) p <- p + ggplot2::geom_point(color = "steelblue", alpha = alpha) + if (n_num == 1) p <- p + ggplot2::geom_boxplot(fill = "steelblue", alpha = alpha) + if (n_num == 0) p <- p + ggplot2::geom_bar(position = "dodge", alpha = alpha) + ggplot2::labs(fill = NULL) + p } - plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) & - ggplot2::theme_minimal() & - ggplot2::theme( - plot.title = ggplot2::element_text(hjust = 0.5, size = 9, face = "bold"), - axis.text = ggplot2::element_text(size = 7) - ) - }, - varnames_value = varnames, - alpha_value = alpha_val, - size_value = size_val - ) - } + } + + plot_list <- unlist( + lapply(seq_len(n_vars), function(i) lapply(seq_len(n_vars), function(j) make_panel(i, j))), + recursive = FALSE + ) + plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) & + ggplot2::theme_minimal(base_size = base_size) & + ggplot2::theme( + plot.title = ggplot2::element_text(hjust = 0.5, face = "bold"), + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), + legend.position = "none" + ) + }, + add_cor_value = add_cor, + cor_method_value = cor_method, + cor_use_value = cor_use, + alpha_value = alpha_val, + varnames_value = varnames + ) qenv }) @@ -603,80 +561,3 @@ srv_g_scatterplotmatrix <- function(id, set_chunk_dims(pws, decorated_output_q) }) } - -#' Get stats for x-y pairs in scatterplot matrix -#' -#' @description -#' `r lifecycle::badge("deprecated")` -#' -#' Uses [stats::cor.test()] per default for all numerical input variables and converts results -#' to character vector. -#' Could be extended if different stats for different variable types are needed. -#' -#' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length. -#' @param .f (`function`) function that accepts x and y as formula input `~ x + y`. -#' Default `stats::cor.test`. -#' @param .f_args (`list`) of arguments to be passed to `.f`. -#' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate. -#' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value. -#' -#' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value. -#' -#' @examples -#' set.seed(1) -#' x <- runif(25, 0, 1) -#' y <- runif(25, 0, 1) -#' x[c(3, 10, 18)] <- NA -#' -#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) -#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( -#' method = "pearson", -#' na.action = na.fail -#' )) -#' -#' @export -#' -get_scatterplotmatrix_stats <- function(x, y, - .f = stats::cor.test, - .f_args = list(), - round_stat = 2, - round_pval = 4) { - lifecycle::deprecate_warn( - "0.6.1", - "get_scatterplotmatrix_stats()", - details = paste( - "The scatterplot matrix module now uses ggplot2 + patchwork", - "which handles correlation display natively." - ) - ) - if (is.numeric(x) && is.numeric(y)) { - stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) - - if (anyNA(stat)) { - "NA" - } else if (all(c("estimate", "p.value") %in% names(stat))) { - paste( - c( - paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)), - paste0("P:", round(stat$p.value, round_pval)) - ), - collapse = "\n" - ) - } else { - stop("function not supported") - } - } else { - if ("method" %in% names(.f_args)) { - if (.f_args$method == "pearson") { - return("cor:-") - } - if (.f_args$method == "kendall") { - return("tau:-") - } - if (.f_args$method == "spearman") { - return("rho:-") - } - } - "-" - } -} From 48818368c76ae13b155406aaf68c50fe20cd3f62 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 11 Mar 2026 14:39:24 +0100 Subject: [PATCH 11/25] change patchwork to ggplot object --- R/tm_g_scatterplotmatrix.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index da13aaa0f..eabecb277 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -26,7 +26,7 @@ #' @section Decorating Module: #' #' This module generates the following objects, which can be modified in place using decorators: -#' - `plot` (`patchwork` - assembled from individual `ggplot` panels) +#' - `plot` (`ggplot` - assembled from individual `ggplot` panels) #' #' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects. #' The name of this list corresponds to the name of the output to which the decorator is applied. From ad3e2751607743453fb7cbd93cd140136adb5dc2 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 11 Mar 2026 14:40:45 +0100 Subject: [PATCH 12/25] make it even more clear --- R/tm_g_scatterplotmatrix.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index eabecb277..8ade6b185 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -26,7 +26,7 @@ #' @section Decorating Module: #' #' This module generates the following objects, which can be modified in place using decorators: -#' - `plot` (`ggplot` - assembled from individual `ggplot` panels) +#' - `plot` (`ggplot` - a `patchwork` assembled from individual `ggplot` panels) #' #' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects. #' The name of this list corresponds to the name of the output to which the decorator is applied. From 5cd18af517e10e043e1c52dadf72784bff5aad52 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 11 Mar 2026 14:54:00 +0100 Subject: [PATCH 13/25] bring old geoms styyle --- R/tm_g_scatterplotmatrix.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 8ade6b185..2da644efe 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -489,11 +489,11 @@ srv_g_scatterplotmatrix <- function(id, size = if (!is.na(cv)) max(3, abs(cv) * 8 + 3) else if (is.numeric(xi) && is.numeric(xj)) 3 else 4) + ggplot2::xlim(0, 1) + ggplot2::ylim(0, 1) + ggplot2::theme_void() } else { - p <- ggplot2::ggplot(data.frame(x = xj, y = xi)) + ggplot2::labs(x = NULL, y = NULL) + ggplot2::aes(x = x, y = y) + p <- ggplot2::ggplot(data.frame(x = xj, y = xi)) + ggplot2::labs(x = NULL, y = NULL) n_num <- is.numeric(xi) + is.numeric(xj) - if (n_num == 2) p <- p + ggplot2::geom_point(color = "steelblue", alpha = alpha) - if (n_num == 1) p <- p + ggplot2::geom_boxplot(fill = "steelblue", alpha = alpha) - if (n_num == 0) p <- p + ggplot2::geom_bar(position = "dodge", alpha = alpha) + ggplot2::labs(fill = NULL) + if (n_num == 2) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_point(color = "steelblue", alpha = alpha) + if (n_num == 1) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_boxplot(fill = "steelblue", alpha = alpha) + if (n_num == 0) p <- p + ggplot2::aes(x = x, fill = y) + ggplot2::geom_bar(position = "dodge", alpha = alpha) + ggplot2::labs(fill = NULL) p } } From 292ef4d42adbecd123891a999a7df5d4089285b6 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Wed, 11 Mar 2026 14:59:20 +0100 Subject: [PATCH 14/25] Apply suggestion from @m7pr Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- NEWS.md | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index ec0495cd4..2f6666809 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,9 +9,7 @@ - Introduced `tm_gtsummary()`, a new module for generating tables using the [gtsummary](https://cran.r-project.org/package=gtsummary) package (#973). - `tm_g_scatterplotmatrix()` has been rewritten to use `ggplot2` and `patchwork` instead of `lattice`. Panel text scales automatically with the number of - variables so labels remain readable at any matrix size. Plot construction has - been optimised to pass per-column vectors instead of the full data frame to - each panel, reducing render time for large variable sets. NA handling retains + variables so labels remain readable at any matrix size. NA handling retains the familiar **Omit NAs** checkbox (default, `use = "pairwise.complete.obs"`); unchecking it reveals a dropdown with all five `stats::cor()` `use` options. `get_scatterplotmatrix_stats()` has been removed (#986). From 082fe54293dc6db2e1b27105ea6222f9dbbd7c8a Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Wed, 11 Mar 2026 14:59:42 +0100 Subject: [PATCH 15/25] Apply suggestion from @m7pr Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- NEWS.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index 2f6666809..d79d5802b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,8 +5,6 @@ - Modules now return a `teal_report` object that contains the data, code and reporter. All the reporter buttons were removed from the modules' UI. - Support case when both variables are categorical in association and bivariate plots. - Improve `tm_missing_data` visualization (#495). -- Multiple decorators can be applied to the same output object (#978). -- Introduced `tm_gtsummary()`, a new module for generating tables using the [gtsummary](https://cran.r-project.org/package=gtsummary) package (#973). - `tm_g_scatterplotmatrix()` has been rewritten to use `ggplot2` and `patchwork` instead of `lattice`. Panel text scales automatically with the number of variables so labels remain readable at any matrix size. NA handling retains From 1c9fa93d62a436744bb80b4b50f938076263ee77 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 11 Mar 2026 14:39:59 +0000 Subject: [PATCH 16/25] [skip style] [skip vbump] Restyle files --- R/tm_g_scatterplotmatrix.R | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 2da644efe..5a6e282c1 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -451,14 +451,14 @@ srv_g_scatterplotmatrix <- function(id, qenv <- within( qenv, { - add_cor <- add_cor_value + add_cor <- add_cor_value cor_method <- cor_method_value - cor_use <- cor_use_value - alpha <- alpha_value - varnames <- varnames_value + cor_use <- cor_use_value + alpha <- alpha_value + varnames <- varnames_value col_names <- names(ANL) - n_vars <- length(col_names) + n_vars <- length(col_names) base_size <- max(6L, 14L - n_vars) num_idx <- which(vapply(ANL, is.numeric, logical(1L))) @@ -481,15 +481,20 @@ srv_g_scatterplotmatrix <- function(id, p <- p + ggplot2::geom_bar(fill = "steelblue", alpha = alpha) } } else if (i < j && add_cor) { - cv <- if (!is.null(cor_mat) && is.numeric(xi) && is.numeric(xj)) cor_mat[col_names[i], col_names[j]] else NA_real_ + cv <- if (!is.null(cor_mat) && is.numeric(xi) && is.numeric(xj)) cor_mat[col_names[i], col_names[j]] else NA_real_ col <- if (is.na(cv)) "grey50" else if (cv > 0) "firebrick" else "steelblue" ggplot2::ggplot() + - ggplot2::annotate("text", x = 0.5, y = 0.5, fontface = "bold", color = col, - label = if (!is.na(cv)) sprintf("%.2f", cv) else if (is.numeric(xi) && is.numeric(xj)) "NA" else "-", - size = if (!is.na(cv)) max(3, abs(cv) * 8 + 3) else if (is.numeric(xi) && is.numeric(xj)) 3 else 4) + - ggplot2::xlim(0, 1) + ggplot2::ylim(0, 1) + ggplot2::theme_void() + ggplot2::annotate("text", + x = 0.5, y = 0.5, fontface = "bold", color = col, + label = if (!is.na(cv)) sprintf("%.2f", cv) else if (is.numeric(xi) && is.numeric(xj)) "NA" else "-", + size = if (!is.na(cv)) max(3, abs(cv) * 8 + 3) else if (is.numeric(xi) && is.numeric(xj)) 3 else 4 + ) + + ggplot2::xlim(0, 1) + + ggplot2::ylim(0, 1) + + ggplot2::theme_void() } else { - p <- ggplot2::ggplot(data.frame(x = xj, y = xi)) + ggplot2::labs(x = NULL, y = NULL) + p <- ggplot2::ggplot(data.frame(x = xj, y = xi)) + + ggplot2::labs(x = NULL, y = NULL) n_num <- is.numeric(xi) + is.numeric(xj) if (n_num == 2) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_point(color = "steelblue", alpha = alpha) if (n_num == 1) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_boxplot(fill = "steelblue", alpha = alpha) @@ -505,16 +510,16 @@ srv_g_scatterplotmatrix <- function(id, plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) & ggplot2::theme_minimal(base_size = base_size) & ggplot2::theme( - plot.title = ggplot2::element_text(hjust = 0.5, face = "bold"), + plot.title = ggplot2::element_text(hjust = 0.5, face = "bold"), axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), legend.position = "none" ) }, - add_cor_value = add_cor, + add_cor_value = add_cor, cor_method_value = cor_method, - cor_use_value = cor_use, - alpha_value = alpha_val, - varnames_value = varnames + cor_use_value = cor_use, + alpha_value = alpha_val, + varnames_value = varnames ) qenv }) From 6deb5bd49fc5dfaf78ebe40e88c9b6d54f7f737a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 11 Mar 2026 14:49:38 +0000 Subject: [PATCH 17/25] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/tm_g_scatterplotmatrix.Rd | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index 8fd182eb5..5fdf03dd2 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -58,13 +58,18 @@ providing the overview of correlations and distributions across selected data. \note{ For more examples, please see the vignette "Using scatterplot matrix" via \code{vignette("using-scatterplot-matrix", package = "teal.modules.general")}. + +When \emph{Add Correlation} is enabled, a simple \strong{Omit NAs} checkbox +controls NA handling (checked = \code{"pairwise.complete.obs"}, matching the +historical default). Unchecking it reveals a dropdown with all five +\code{stats::cor()} \code{use} options for advanced control. } \section{Decorating Module}{ This module generates the following objects, which can be modified in place using decorators: \itemize{ -\item \code{plot} (\code{patchwork} - assembled from individual \code{ggplot} panels) +\item \code{plot} (\code{ggplot} - a \code{patchwork} assembled from individual \code{ggplot} panels) } A Decorator is applied to the specific output using a named list of \code{teal_transform_module} objects. From edb7bee05e37d4856bbb14037f6e0104b45737b0 Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 12 Mar 2026 12:04:52 +0100 Subject: [PATCH 18/25] remove non-ascii string --- R/tm_g_scatterplotmatrix.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 2da644efe..d143c496d 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -316,7 +316,7 @@ ui_g_scatterplotmatrix <- function(id, ...) { tags$dt("All observations"), tags$dd("Assume no NAs are present; throws an error if any are found."), tags$dt("Complete observations"), - tags$dd("Listwise deletion – only rows with no NAs across all selected variables."), + tags$dd("Listwise deletion - only rows with no NAs across all selected variables."), tags$dt("NA or complete"), tags$dd("Like complete observations but returns NA instead of an error when no complete cases exist."), tags$dt("Pairwise complete"), From 2a92e9421c9092b374f133a4b44df2aff3f12884 Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 12 Mar 2026 13:39:45 +0100 Subject: [PATCH 19/25] update WORDLIST --- inst/WORDLIST | 3 +++ 1 file changed, 3 insertions(+) diff --git a/inst/WORDLIST b/inst/WORDLIST index 901df63fd..df7336851 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -17,3 +17,6 @@ qq reportable sortable tabset +Unchecking +Unchecking +dropdown \ No newline at end of file From c4a9036548a52293347adc34c22d6c923a39ea8f Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 12 Mar 2026 14:05:45 +0100 Subject: [PATCH 20/25] lintr --- R/tm_g_scatterplotmatrix.R | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index d6e974d99..fa9e69333 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -294,8 +294,14 @@ ui_g_scatterplotmatrix <- function(id, ...) { bslib::popover( icon("circle-info"), title = "NA handling", - tags$p(tags$b("Checked:"), "use pairwise complete observations (each pair correlated over rows where both values are present)."), - tags$p(tags$b("Unchecked:"), "reveals a dropdown with all five", tags$code("stats::cor()"), "use= options."), + tags$p( + tags$b("Checked:"), + "use pairwise complete observations (each pair correlated over rows where both values are present)." + ), , + tags$p( + tags$b("Unchecked:"), + "reveals a dropdown with all five", tags$code("stats::cor()"), "use= options." + ), options = list(trigger = "hover focus") ) ), @@ -318,7 +324,7 @@ ui_g_scatterplotmatrix <- function(id, ...) { tags$dt("Complete observations"), tags$dd("Listwise deletion - only rows with no NAs across all selected variables."), tags$dt("NA or complete"), - tags$dd("Like complete observations but returns NA instead of an error when no complete cases exist."), + tags$dd("Like complete observations but returns NA instead of an error when no complete cases exist."), # nolint line_length_linter. tags$dt("Pairwise complete"), tags$dd("Use all rows where both variables in a pair are non-missing (maximises available data).") ), @@ -481,13 +487,13 @@ srv_g_scatterplotmatrix <- function(id, p <- p + ggplot2::geom_bar(fill = "steelblue", alpha = alpha) } } else if (i < j && add_cor) { - cv <- if (!is.null(cor_mat) && is.numeric(xi) && is.numeric(xj)) cor_mat[col_names[i], col_names[j]] else NA_real_ + cv <- if (!is.null(cor_mat) && is.numeric(xi) && is.numeric(xj)) cor_mat[col_names[i], col_names[j]] else NA_real_ # nolint line_length_linter. col <- if (is.na(cv)) "grey50" else if (cv > 0) "firebrick" else "steelblue" ggplot2::ggplot() + ggplot2::annotate("text", x = 0.5, y = 0.5, fontface = "bold", color = col, - label = if (!is.na(cv)) sprintf("%.2f", cv) else if (is.numeric(xi) && is.numeric(xj)) "NA" else "-", - size = if (!is.na(cv)) max(3, abs(cv) * 8 + 3) else if (is.numeric(xi) && is.numeric(xj)) 3 else 4 + label = if (!is.na(cv)) sprintf("%.2f", cv) else if (is.numeric(xi) && is.numeric(xj)) "NA" else "-", # nolint line_length_linter. + size = if (!is.na(cv)) max(3, abs(cv) * 8 + 3) else if (is.numeric(xi) && is.numeric(xj)) 3 else 4 # nolint line_length_linter. ) + ggplot2::xlim(0, 1) + ggplot2::ylim(0, 1) + @@ -496,9 +502,9 @@ srv_g_scatterplotmatrix <- function(id, p <- ggplot2::ggplot(data.frame(x = xj, y = xi)) + ggplot2::labs(x = NULL, y = NULL) n_num <- is.numeric(xi) + is.numeric(xj) - if (n_num == 2) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_point(color = "steelblue", alpha = alpha) - if (n_num == 1) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_boxplot(fill = "steelblue", alpha = alpha) - if (n_num == 0) p <- p + ggplot2::aes(x = x, fill = y) + ggplot2::geom_bar(position = "dodge", alpha = alpha) + ggplot2::labs(fill = NULL) + if (n_num == 2) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_point(color = "steelblue", alpha = alpha) # nolint line_length_linter. + if (n_num == 1) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_boxplot(fill = "steelblue", alpha = alpha) # nolint line_length_linter. + if (n_num == 0) p <- p + ggplot2::aes(x = x, fill = y) + ggplot2::geom_bar(position = "dodge", alpha = alpha) + ggplot2::labs(fill = NULL) # nolint line_length_linter. p } } From 4d51a4daf8d30dda5443e2b594be5fa7f5598d78 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 12 Mar 2026 13:08:24 +0000 Subject: [PATCH 21/25] [skip style] [skip vbump] Restyle files --- R/tm_g_scatterplotmatrix.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index fa9e69333..04b5f4f45 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -297,7 +297,7 @@ ui_g_scatterplotmatrix <- function(id, ...) { tags$p( tags$b("Checked:"), "use pairwise complete observations (each pair correlated over rows where both values are present)." - ), , + ), , tags$p( tags$b("Unchecked:"), "reveals a dropdown with all five", tags$code("stats::cor()"), "use= options." From e664cedbc6cada408e8d0b12c9f07b470da7ece2 Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 12 Mar 2026 14:10:57 +0100 Subject: [PATCH 22/25] wordlist typo --- inst/WORDLIST | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/WORDLIST b/inst/WORDLIST index df7336851..77c186314 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -18,5 +18,5 @@ reportable sortable tabset Unchecking -Unchecking +unchecking dropdown \ No newline at end of file From 202c0dc8ab24dbb9237769eb6d4cfc1ff8333267 Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 12 Mar 2026 15:03:03 +0100 Subject: [PATCH 23/25] Empty-Commit From 8bf32362f8f9b4d751b8f034b3af4a2494982b92 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 16 Mar 2026 12:16:18 +0100 Subject: [PATCH 24/25] typo --- R/tm_g_scatterplotmatrix.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 04b5f4f45..b86ff874f 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -297,7 +297,7 @@ ui_g_scatterplotmatrix <- function(id, ...) { tags$p( tags$b("Checked:"), "use pairwise complete observations (each pair correlated over rows where both values are present)." - ), , + ), tags$p( tags$b("Unchecked:"), "reveals a dropdown with all five", tags$code("stats::cor()"), "use= options." From 25947520085386b25e1dcb063605603dee1ba1ff Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 16 Mar 2026 12:37:30 +0100 Subject: [PATCH 25/25] last touches on axes --- R/tm_g_scatterplotmatrix.R | 35 +++++++++++++++++++++++------------ 1 file changed, 23 insertions(+), 12 deletions(-) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index b86ff874f..d14619132 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -489,15 +489,17 @@ srv_g_scatterplotmatrix <- function(id, } else if (i < j && add_cor) { cv <- if (!is.null(cor_mat) && is.numeric(xi) && is.numeric(xj)) cor_mat[col_names[i], col_names[j]] else NA_real_ # nolint line_length_linter. col <- if (is.na(cv)) "grey50" else if (cv > 0) "firebrick" else "steelblue" - ggplot2::ggplot() + - ggplot2::annotate("text", - x = 0.5, y = 0.5, fontface = "bold", color = col, - label = if (!is.na(cv)) sprintf("%.2f", cv) else if (is.numeric(xi) && is.numeric(xj)) "NA" else "-", # nolint line_length_linter. - size = if (!is.na(cv)) max(3, abs(cv) * 8 + 3) else if (is.numeric(xi) && is.numeric(xj)) 3 else 4 # nolint line_length_linter. - ) + - ggplot2::xlim(0, 1) + - ggplot2::ylim(0, 1) + - ggplot2::theme_void() + return( + ggplot2::ggplot() + + ggplot2::annotate("text", + x = 0.5, y = 0.5, fontface = "bold", color = col, + label = if (!is.na(cv)) sprintf("%.2f", cv) else if (is.numeric(xi) && is.numeric(xj)) "NA" else "-", # nolint line_length_linter. + size = if (!is.na(cv)) max(3, abs(cv) * 8 + 3) else if (is.numeric(xi) && is.numeric(xj)) 3 else 4 # nolint line_length_linter. + ) + + ggplot2::xlim(0, 1) + + ggplot2::ylim(0, 1) + + ggplot2::theme_void() + ) } else { p <- ggplot2::ggplot(data.frame(x = xj, y = xi)) + ggplot2::labs(x = NULL, y = NULL) @@ -505,8 +507,19 @@ srv_g_scatterplotmatrix <- function(id, if (n_num == 2) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_point(color = "steelblue", alpha = alpha) # nolint line_length_linter. if (n_num == 1) p <- p + ggplot2::aes(x = x, y = y) + ggplot2::geom_boxplot(fill = "steelblue", alpha = alpha) # nolint line_length_linter. if (n_num == 0) p <- p + ggplot2::aes(x = x, fill = y) + ggplot2::geom_bar(position = "dodge", alpha = alpha) + ggplot2::labs(fill = NULL) # nolint line_length_linter. - p } + p <- p + ggplot2::theme_minimal(base_size = base_size) + if (i == n_vars) { + p <- p + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) + if (!is.numeric(xj)) { + p <- p + ggplot2::scale_x_discrete( + labels = function(x) ifelse(nchar(x) > 10, paste0(substr(x, 1, 9), "\u2026"), x) + ) + } + } else { + p <- p + ggplot2::theme(axis.text.x = ggplot2::element_blank(), axis.ticks.x = ggplot2::element_blank()) + } + p } plot_list <- unlist( @@ -514,10 +527,8 @@ srv_g_scatterplotmatrix <- function(id, recursive = FALSE ) plot <- patchwork::wrap_plots(plot_list, ncol = n_vars, nrow = n_vars) & - ggplot2::theme_minimal(base_size = base_size) & ggplot2::theme( plot.title = ggplot2::element_text(hjust = 0.5, face = "bold"), - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), legend.position = "none" ) },