WIP: Fixes example testing via shinytest2

NEWS.md

@@ -3,6 +3,7 @@
 ### Enhancements
 
 - 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.
 
 # teal.modules.general 0.5.1
 

R/custom_mosaic.R

@@ -0,0 +1,75 @@
+#' Minimal mosaic plot
+#'
+#' Provides a minimal mosaic plot implementation using ggplot2.
+#' @param data_name Name of the data frame to use.
+#' @param x_var Name of the variable to use on the x-axis.
+#' @param y_var Name of the variable to use for fill colors.
+#' @param reduce_plot_call Function that takes multiple ggplot2 layers and combines them into a single plot call.
+#' @return An expression that creates a mosaic plot when evaluated.
+#' @keywords internal
+.create_mosaic_layers <- function(data_name, x_var, y_var, reduce_plot_call) {
+  data_call <- substitute(
+    mosaic_data <- data_name %>%
+      # Count combinations of X and Y
+      dplyr::count(x_var, y_var) %>%
+      # Compute total for each X group
+      dplyr::mutate(
+        .by = x_var,
+        x_total = sum(n),
+        prop = n / x_total
+      ) %>%
+      # Compute total sample size to turn counts into widths
+      dplyr::mutate(N_total = sum(x_total)) %>%
+      # Convert counts to x widths
+      dplyr::mutate(
+        .by = x_var,
+        x_width = x_total / unique(N_total),
+        x_width_last = dplyr::if_else(dplyr::row_number() == dplyr::n(), x_width, 0)
+      ) %>%
+      # Compute x-min/x-max for each group
+      dplyr::mutate(
+        xmin = cumsum(dplyr::lag(x_width_last, default = 0)),
+        xmax = xmin + x_width
+      ) %>%
+      # Compute y-min/y-max for stacked proportions
+      dplyr::arrange(x_var, y_var) %>%
+      dplyr::mutate(
+        .by = x_var,
+        ymin = c(0, head(cumsum(prop), -1)),
+        ymax = cumsum(prop)
+      ),
+    env = list(x_var = as.name(x_var), y_var = as.name(y_var), data_name = as.name(data_name))
+  )
+
+  layer_rect <- substitute(
+    ggplot2::geom_rect(
+      ggplot2::aes(
+        xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = y_var
+      ),
+      color = "white"
+    ),
+    env = list(y_var = as.name(y_var))
+  )
+
+  layer_scale_x <- substitute(
+    ggplot2::scale_x_continuous(
+      breaks = mosaic_data %>%
+        dplyr::distinct(x_var, xmin, xmax) %>%
+        dplyr::mutate(mid = (xmin + xmax) / 2) %>%
+        dplyr::pull(mid),
+      labels = mosaic_data %>%
+        dplyr::distinct(x_var) %>%
+        dplyr::pull(x_var),
+      expand = c(0, 0)
+    ),
+    env = list(x_var = as.name(x_var))
+  )
+
+  bquote(
+    .(data_call) %>%
+      ggplot2::ggplot() +
+      .(layer_rect) +
+      .(layer_scale_x) +
+      ggplot2::scale_y_continuous(expand = c(0, 0), labels = scales::percent_format(scale = 100))
+  )
+}

R/tm_file_viewer.R

@@ -31,7 +31,7 @@
 #'         folder = system.file("sample_files", package = "teal.modules.general"),
 #'         png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
 #'         txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
-#'         url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"
+#'         url = "https://www.fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"
 #'       )
 #'     )
 #'   )

R/tm_g_bivariate.R

@@ -927,7 +927,12 @@ bivariate_ggplot_call <- function(x_class,
     )
     # Factor and character plots
   } else if (x_class == "factor" && y_class == "factor") {
-    stop("Categorical variables 'x' and 'y' are currently not supported.")
+    plot_call <- .create_mosaic_layers(
+      data_name,
+      x_var = x,
+      y_var = y,
+      reduce_plot_call = reduce_plot_call
+    )
   } else {
     stop("x y type combination not allowed")
   }

R/tm_variable_browser.R

@@ -886,7 +886,7 @@ get_plotted_data <- function(input, plot_var, data) {
       teal.reporter::teal_card(obj),
       teal.reporter::teal_card("## Module's output(s)")
     )
-  teal.code::eval_code(obj, "library(ggplot2)") |>
+  teal.code::eval_code(obj, "library(ggplot2)\nlibrary(dplyr)") |>
     within(
       {
         ANL <- dplyr::select(dataset_name, varname)

R/utils.R

@@ -234,6 +234,7 @@ variable_type_icons <- function(var_type) {
   ))
 }
 
+#' JavaScript expression to check if a tab is active
 #'
 #' @param id (`character(1)`) the id of the tab panel with tabs.
 #' @param name (`character(1)`) the name of the tab.

tests/testthat/test_bivariate_ggplot_call.R

@@ -18,35 +18,24 @@ testthat::test_that("bivariate_ggplot_call with numerics", {
   )
 })
 
-testthat::test_that("bivariate_ggplot_call with factor, char, logical", {
-  error_message <- "Categorical variables 'x' and 'y' are currently not supported."
-  testthat::expect_error(
-    bivariate_ggplot_call("factor", "factor") %>% deparse(width.cutoff = 300),
-    error_message
-  )
-  testthat::expect_error(
-    bivariate_ggplot_call("logical", "factor") %>% deparse(width.cutoff = 300),
-    error_message
-  )
-  testthat::expect_error(
-    bivariate_ggplot_call("character", "factor") %>% deparse(width.cutoff = 300),
-    error_message
-  )
-  testthat::expect_error(
-    bivariate_ggplot_call("logical", "character") %>% deparse(width.cutoff = 300),
-    error_message
-  )
-  testthat::expect_error(
-    bivariate_ggplot_call("character", "logical") %>% deparse(width.cutoff = 300),
-    error_message
-  )
-  testthat::expect_error(
-    bivariate_ggplot_call("logical", "logical") %>% deparse(width.cutoff = 300),
-    error_message
-  )
-  testthat::expect_error(
-    bivariate_ggplot_call("character", "character") %>% deparse(width.cutoff = 300),
-    error_message
+testthat::describe("bivariate_ggplot_call with arguments:", {
+  possible_classes <- c("factor", "logical", "character")
+  comb <- expand.grid(a = possible_classes, b = possible_classes, stringsAsFactors = FALSE)
+  apply(
+    comb,
+    1,
+    function(x) {
+      it(sprintf("%s and %s", x[[1]], x[[2]]), {
+        testthat::expect_match(
+          deparse(
+            bivariate_ggplot_call(x[[1]], x[[2]], data_name = "ANL", x = "x", y = "y"),
+            width.cutoff = 300
+          ),
+          "mosaic_data <- ",
+          all = FALSE
+        )
+      })
+    }
   )
 })