diff --git a/DESCRIPTION b/DESCRIPTION index a95189358..9b577d1cd 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/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 24e1396b9..17dcba1a3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,8 +5,12 @@ - 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 + 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). ### Bug fixes - `Show only distinct rows` in `tm_data_table` does no longer show an extra count column `n` (#983). 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) diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index a5aed1f83..d14619132 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 @@ -21,7 +26,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` (`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. @@ -272,19 +277,70 @@ ui_g_scatterplotmatrix <- function(id, ...) { min = 0, max = 1, step = .05, value = .5, ticks = FALSE ), - sliderInput( - ns("cex"), "Points size:", - min = 0.2, max = 3, - step = .05, value = .65, 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 + ) ), - checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE) + 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."), # 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).") + ), + 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" + ) + ) ) ) ), @@ -309,7 +365,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." + ) ) ) @@ -321,7 +380,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()) @@ -330,7 +389,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,17 +406,11 @@ 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 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" - } else { - "na.fail" - } + 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) @@ -368,93 +421,123 @@ 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 ) } - # 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 - ) - }, - env = list( - varnames_value = varnames, - cor_method = cor_method, - cor_na_action = cor_na_action, - alpha_value = alpha, - cex_value = cex - ) - ) - ) + if (isTRUE(cor_na_omit)) { + shinyjs::hide("cor_use") + } else { + shinyjs::show("cor_use") + } } 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 + shinyjs::hide("cor_use") + } + + 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_ # nolint line_length_linter. + col <- if (is.na(cv)) "grey50" else if (cv > 0) "firebrick" else "steelblue" + 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() ) - }, - env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) + } else { + 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) # 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 + 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( + 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( + plot.title = ggplot2::element_text(hjust = 0.5, face = "bold"), + 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 }) @@ -500,79 +583,3 @@ srv_g_scatterplotmatrix <- function(id, set_chunk_dims(pws, decorated_output_q) }) } - -#' Get stats for x-y pairs in scatterplot matrix -#' -#' 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`. -#' 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) { - 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:-") - } - } - "-" - } -} diff --git a/R/utils.R b/R/utils.R index 80e5b14b3..dd8bac846 100644 --- a/R/utils.R +++ b/R/utils.R @@ -362,7 +362,6 @@ set_chunk_dims <- function(pws, q_r, inner_classes = NULL) { }) } - validate_qenv <- function(qenv) { validate( need( 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/inst/WORDLIST b/inst/WORDLIST index 901df63fd..77c186314 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -17,3 +17,6 @@ qq reportable sortable tabset +Unchecking +unchecking +dropdown \ No newline at end of file diff --git a/man/get_scatterplotmatrix_stats.Rd b/man/get_scatterplotmatrix_stats.Rd deleted file mode 100644 index 176b24cb1..000000000 --- a/man/get_scatterplotmatrix_stats.Rd +++ /dev/null @@ -1,59 +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{ -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) -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/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index ba9c4c3d9..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{trellis} - output of \code{lattice::splom}) +\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. 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 deleted file mode 100644 index 3554c9c09..000000000 --- a/tests/testthat/test_scatterplotmatrix_get_stats.R +++ /dev/null @@ -1,31 +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 - - 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)) - testthat::expect_true(corr == "NA") - - 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 - - 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")) - testthat::expect_true(startsWith(corr, "tau")) - 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