Color tab work

.Rbuildignore

@@ -14,6 +14,7 @@ Rplots.pdf
 ^_pkgdown\.yml$
 ^docs$
 ^pkgdown$
+^vignettes/articles$
 ^vignettes-old/$
 ^vignettes-new/$
 README.*

NAMESPACE

@@ -68,6 +68,7 @@ export(get_model)
 export(get_models)
 export(glmlist)
 export(joint)
+export(knit_include)
 export(labeling_points)
 export(loglin2formula)
 export(loglin2string)
@@ -113,6 +114,8 @@ importFrom(grid,seekViewport)
 importFrom(grid,unit)
 importFrom(grid,upViewport)
 importFrom(grid,viewport)
+importFrom(knitr,include_graphics)
+importFrom(knitr,is_html_output)
 importFrom(methods,is)
 importFrom(rgl,translate3d)
 importFrom(stats,as.formula)

R/color_table.R

@@ -13,7 +13,7 @@
 #         Future enhancement: could extend `margins` to accept a list for custom styling.
 #
 # ✔️DONE: Add filename arg, which if not NULL saves the `gt` result as an image via gt::gtsave().
-#         Supports .png, .svg, .pdf, .html, .rtf, .docx formats. Additional args passed via `...`.
+#         Supports .png, .pdf, .html, .rtf, .docx formats. Additional args passed via `...`.
 #
 # ✔️DONE: Refactored as S3 generic with methods for table, xtabs, ftable, structable, data.frame, matrix.
 #         The .color_table_impl() internal function handles the core gt table building.
@@ -90,24 +90,42 @@
 #' **Use in documents**
 #'
 #' In R Markdown (\code{.Rmd}) or Quarto (\code{.qmd}) documents, \pkg{gt} tables
-#' may not render correctly in all output formats. The \code{filename} argument
-#' provides a workaround: save the table as an image, then include it using
-#' \code{\link[knitr]{include_graphics}}. For example:
+#' render natively in \strong{HTML output} — simply return the \code{gt} object from
+#' a chunk and knitr renders it automatically via \pkg{gt}'s built-in
+#' \code{knit_print} method. No \code{filename} argument is needed.
+#'
+#' For \strong{PDF or Word output}, \pkg{gt} does not render natively. Use the
+#' \code{filename} argument to save the table as a \code{.png} image, then include
+#' it with \code{\link[knitr]{include_graphics}}:
 #'
 #' \preformatted{
 #'     color_table(my_table, filename = "my_table.png")
 #'     knitr::include_graphics("my_table.png")
 #' }
 #'
-#' For higher quality output, \code{.svg} format is recommended. You can control
-#' the image dimensions using the \code{vwidth} and \code{vheight} arguments
-#' (passed via \code{...}).
+#' The \code{vwidth} and \code{vheight} arguments (passed via \code{...}) control
+#' the image viewport size in pixels.  Supported save formats are
+#' \code{.png}, \code{.pdf}, \code{.html}, \code{.rtf}, and \code{.docx}.
+#'
+#' For documents that target \strong{multiple output formats}, a small helper that
+#' branches on \code{\link[knitr]{is_html_output}} avoids duplicating code:
+#'
+#' \preformatted{
+#'     gt_obj <- color_table(my_table)
+#'     if (knitr::is_html_output()) {
+#'       gt_obj
+#'     } else {
+#'       gt::gtsave(gt_obj, "my_table.png")
+#'       knitr::include_graphics("my_table.png")
+#'     }
+#' }
 #'
-#' If you need a caption for cross-referencing (especially in Quarto or R Markdown),
-#' you can use `gt::tab_caption()`
+#' If you need a caption or cross-reference label, use \code{gt::tab_caption()}
+#' on the returned object:
 #' \preformatted{
-#'      gt_object |> tab_caption(caption = "Table 1: Pattern of Association in MyTable")
-#'  }
+#'     color_table(my_table) |>
+#'       gt::tab_caption("Table 1: Pattern of association in MyTable")
+#' }
 #'
 #' @return A gt table object that can be further customized
 #'
@@ -169,7 +187,7 @@ color_table <- function(x, ...) {
 #' @param title Optional table title
 #' @param filename Optional filename to save the table as an image. If provided,
 #'        the table is saved using \code{\link[gt]{gtsave}}. Supported formats include
-#'        \code{.png}, \code{.svg}, \code{.pdf}, \code{.html}, \code{.rtf}, and \code{.docx}.
+#'        \code{.png}, \code{.pdf}, \code{.html}, \code{.rtf}, and \code{.docx}.
 #'        The file format is determined by the file extension. Other arguments can be passed
 #'        to \code{\link[gt]{gtsave}} via `...`.
 #' @export

R/knit_include.R

@@ -0,0 +1,88 @@
+#' Include an HTML-renderable object in any knitr output format
+#'
+#' A pipe-friendly helper for objects that render natively in HTML output
+#' (RStudio Viewer, HTML documents) but need an image fallback for PDF, Word,
+#' and other non-HTML formats.
+#'
+#' Supported classes:
+#'   - `gt_tbl`     (gt package)       -- saved via \code{\link[gt]{gtsave}}
+#'   - `htmlwidget` (htmlwidgets family: plotly, DT, leaflet, dygraphs, ...)
+#'                                     -- saved via
+#'                                        \code{\link[htmlwidgets]{saveWidget}}
+#'                                        + \code{\link[webshot2]{webshot}}
+#'
+#' Packages that handle cross-format output natively (flextable, kableExtra,
+#' huxtable) do NOT need this helper.
+#'
+#' For any other class, \code{x} is returned as-is in all output formats and
+#' knitr's normal printing applies.  This means the function is safe to use in
+#' a pipe on any object: it only intervenes when it knows how to help.
+#'
+#' @param x       Any R object. Specialised handling for \code{gt_tbl} and
+#'                \code{htmlwidget}; all other classes are passed through
+#'                unchanged.
+#' @param file    Base filename (no extension) for temporary files written when
+#'                output is not HTML.  Defaults to a session-unique temp file in
+#'                the current directory so multiple calls don't collide.
+#' @param width   Viewport / screenshot width in pixels (non-HTML only).
+#' @param height  Viewport / screenshot height in pixels (non-HTML only).
+#' @param ...     Additional arguments forwarded to \code{\link[gt]{gtsave}} or
+#'                \code{\link[webshot2]{webshot}}.
+#'
+#' @return For \code{gt_tbl} / \code{htmlwidget} in non-HTML output: the result
+#'         of \code{\link[knitr]{include_graphics}}. Otherwise: \code{x}
+#'         unchanged.
+#'
+#' @examples
+#' \dontrun{
+#' data(HairEyeColor)
+#' HEC <- margin.table(HairEyeColor, 1:2)
+#'
+#' ## gt_tbl from color_table()
+#' color_table(HEC, title = "Hair x Eye Color") |> knit_include()
+#'
+#' ## DT htmlwidget
+#' DT::datatable(mtcars) |> knit_include(width = 900, height = 500)
+#'
+#' ## plotly htmlwidget
+#' plotly::plot_ly(mtcars, x = ~wt, y = ~mpg) |> knit_include()
+#'
+#' ## Any other object passes through unchanged
+#' lm(mpg ~ wt, data = mtcars) |> knit_include()
+#' }
+#'
+#' @importFrom knitr is_html_output include_graphics
+#' @export
+knit_include <- function(x,
+                         file   = tempfile("ki_", tmpdir = "."),
+                         width  = 700,
+                         height = 400,
+                         ...) {
+
+  if (knitr::is_html_output()) {
+    return(x)
+  }
+
+  if (inherits(x, "gt_tbl")) {
+    img <- paste0(file, ".png")
+    gt::gtsave(x, filename = img, vwidth = width, vheight = height, ...)
+    return(knitr::include_graphics(img))
+  }
+
+  if (inherits(x, "htmlwidget")) {
+    if (!requireNamespace("htmlwidgets", quietly = TRUE))
+      stop("Package 'htmlwidgets' is required for htmlwidget objects.")
+    if (!requireNamespace("webshot2", quietly = TRUE))
+      stop("Package 'webshot2' is required for htmlwidget objects in non-HTML output.")
+
+    html <- paste0(file, ".html")
+    img  <- paste0(file, ".png")
+    htmlwidgets::saveWidget(x, html, selfcontained = TRUE)
+    webshot2::webshot(html, img, vwidth = width, vheight = height, ...)
+    return(knitr::include_graphics(img))
+  }
+
+  # Unknown class: return x and let knitr's normal printing handle it,
+  # just as it would outside a pipe.
+  x
+}

_pkgdown.yml

@@ -7,6 +7,12 @@ template:
   params:
     bootswatch: cosmo
 
+articles:
+  - title: "color_table"
+    desc: "Heatmap-style display of frequency tables"
+    contents:
+      - color_table
+
 reference:
 
   - title: Mosaics
@@ -48,6 +54,7 @@ reference:
       - assoc_graph
       - plot.assoc_graph
       - color_table
+      - knit_include
       - mcaplot
 
 

extra/check_pkgs.R

@@ -0,0 +1,2 @@
+for (p in c("DT", "plotly", "htmlwidgets", "webshot2"))
+  cat(p, ":", system.file(package = p) != "", "\n")

extra/color_table_demo-qmd.qmd

@@ -0,0 +1,165 @@
+---
+title: "Using color_table() in Quarto"
+author: "Michael Friendly"
+date: today
+format:
+  html:
+    toc: true
+    toc-float: true
+    embed-resources: true
+  pdf:
+    toc: true
+---
+
+```{r}
+#| label: setup
+#| include: false
+library(vcdExtra)
+```
+
+## Overview
+
+`color_table()` produces a `gt` table object with cell backgrounds shaded by
+observed frequencies or Pearson residuals from an independence model.
+
+**Rendering in Quarto documents:**
+
+| Format | Strategy |
+|--------|----------|
+| HTML   | Return the `gt` object — renders natively via gt's `knit_print` |
+| PDF    | `gt` can render to LaTeX/PDF via `gt::as_latex()`, but the easiest cross-format path is `filename = "…png"` + `knitr::include_graphics()`. Supported formats: `.png`, `.pdf`, `.html`, `.rtf`, `.docx` (not `.svg`) |
+| Word   | Same save-as-image approach |
+
+---
+
+## HTML output — return the gt object directly
+
+For HTML output no `filename` argument is needed.
+
+```{r}
+#| label: html-basic
+data(HairEyeColor)
+HEC <- margin.table(HairEyeColor, 1:2)  # collapse over Sex
+
+color_table(HEC, title = "Hair × Eye Color (residual shading)")
+```
+
+```{r}
+#| label: html-freq
+color_table(HEC, shade = "freq", title = "Hair × Eye Color (frequency shading)")
+```
+
+```{r}
+#| label: html-3way
+color_table(HairEyeColor,
+            formula = Eye ~ Hair + Sex,
+            legend  = TRUE,
+            title   = "Hair × Eye × Sex (complete independence residuals)")
+```
+
+---
+
+## PDF / Word output — save image, then include it
+
+Save the table as a PNG (or SVG) and include with `knitr::include_graphics()`.
+
+```{r}
+#| label: pdf-basic
+#| out-width: 70%
+#| fig-cap: "Hair × Eye Color shaded by residuals"
+color_table(HEC,
+            title    = "Hair × Eye Color",
+            filename = "color_table_hec.png")
+
+knitr::include_graphics("color_table_hec.png")
+```
+
+---
+
+## Easier universal approach — branch on output format
+
+The helper below selects the right strategy automatically.
+
+```{r}
+#| label: helper
+#' Render a color_table result in any knitr/Quarto output format
+#'
+#' @param x      Object accepted by color_table()
+#' @param file   Base filename (no extension) for the saved image.
+#'               Used only for non-HTML output.
+#' @param width  Image viewport width in pixels (non-HTML only)
+#' @param height Image viewport height in pixels (non-HTML only)
+#' @param ...    Additional arguments forwarded to color_table()
+include_color_table <- function(x, ..., file = "color_table_tmp",
+                                width = 600, height = 400) {
+  gt_obj <- color_table(x, ...)
+
+  if (knitr::is_html_output()) {
+    gt_obj
+  } else {
+    img <- paste0(file, ".png")
+    gt::gtsave(gt_obj, filename = img, vwidth = width, vheight = height)
+    knitr::include_graphics(img)
+  }
+}
+```
+
+```{r}
+#| label: universal-demo
+#| out-width: 65%
+#| fig-cap: "Hair × Eye Color — same source renders in HTML and PDF"
+include_color_table(HEC,
+                    title  = "Hair × Eye Color",
+                    file   = "color_table_universal",
+                    width  = 520,
+                    height = 300)
+```
+
+---
+
+## Cross-referencing tables in Quarto
+
+Quarto can cross-reference `gt` tables in HTML output using a labelled chunk
+combined with `gt::tab_caption()`.
+
+```{r}
+#| label: tbl-hairey
+#| tbl-cap: "Hair and Eye Color frequencies"
+HEC |>
+  color_table(title = "Hair × Eye Color") |>
+  gt::tab_caption(caption = "Hair and Eye Color frequencies")
+```
+
+See @tbl-hairey for the colored frequency table.
+
+*(Note: `@tbl-` cross-references work for HTML and PDF Quarto output.
+In PDF, the `gt` object must be returned as a `gt` — Quarto calls
+`gt::as_latex()` internally — or use the save-as-image fallback above.)*
+
+---
+
+## More examples
+
+```{r}
+#| label: residuals-display
+#| out-width: 65%
+#| fig-cap: "Pearson residual values shown in cells"
+include_color_table(HEC,
+                    values = "residuals",
+                    title  = "Hair × Eye — Pearson residuals",
+                    file   = "color_table_resid",
+                    width  = 520,
+                    height = 280)
+```
+
+```{r}
+#| label: presex
+data(PreSex, package = "vcd")
+include_color_table(PreSex,
+                    formula = MaritalStatus ~ PremaritalSex + ExtramaritalSex,
+                    legend  = TRUE,
+                    title   = "Pre/Extra-marital Sex by Marital Status",
+                    file    = "color_table_presex",
+                    width   = 520,
+                    height  = 300)
+```