diff --git a/DESCRIPTION b/DESCRIPTION index 8427ea1..15f9451 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -56,6 +56,8 @@ Suggests: dplyr, systemfonts, scales, - extrafont + extrafont, + gt, + webshot2 VignetteBuilder: knitr Config/testthat/edition: 3 diff --git a/R/gg_record.R b/R/gg_record.R index 9daf285..bccb3f8 100644 --- a/R/gg_record.R +++ b/R/gg_record.R @@ -1,8 +1,8 @@ #' @title Record and generate plot histories #' #' @description Record plots created over time and generate a GIF of the plots -#' made in the 'R' session. Overrides the print methods for ggplot and patchwork objects -#' from the 'ggplot2' and 'patchwork' packages respectively. +#' made in the 'R' session. Overrides the print methods for ggplot, patchwork, and gt_tbl objects +#' from the 'ggplot2', 'patchwork', and 'gt' packages respectively. #' #' @rdname Recording #' @@ -12,6 +12,7 @@ #' @param device_ext file extension to use for images created. Does not usually need to be populated manually. #' @return Used initialize recording, nothing returned #' @inheritParams ggplot2::ggsave +#' @inheritParams webshot2::webshot #' #' @importFrom ggplot2 ggsave #' @@ -40,7 +41,9 @@ gg_record <- function(dir = NULL, dpi = 300, limitsize = TRUE, device_ext = NULL, - bg = NULL + bg = NULL, + expand = 5, + zoom = 2 ){ if (is.null(dir)) { @@ -92,6 +95,9 @@ gg_record <- function(dir = NULL, GG_RECORDING_ENV$bg <- bg GG_RECORDING_ENV$limitsize <- limitsize + GG_RECORDING_ENV$expand <- expand + GG_RECORDING_ENV$zoom <- zoom + GG_RECORDING_ENV$shims_registered <- FALSE register_camcorder_shims() @@ -202,11 +208,13 @@ gg_playback <- #' @description resize the film for recording, reprints and saves last plot #' #' @inheritParams ggplot2::ggsave +#' @inheritParams webshot2::webshot #' @export #' #' @return Returns the last plot generated, resized to new dimensions #' -gg_resize_film <- function(height = NA, width = NA, units = NA, dpi = NA){ +gg_resize_film <- function(height = NA, width = NA, units = NA, dpi = NA, + scale = NA, limitsize = NA, expand = NA, zoom = NA){ if(!is.na(height)){ GG_RECORDING_ENV$image_height <- height @@ -221,6 +229,19 @@ gg_resize_film <- function(height = NA, width = NA, units = NA, dpi = NA){ if(!is.na(dpi)){ GG_RECORDING_ENV$image_dpi <- dpi } + if(!is.na(scale)){ + GG_RECORDING_ENV$scale <- scale + } + if(!is.na(limitsize)){ + GG_RECORDING_ENV$limitsize <- limitsize + } + + if(!all(is.na(expand))){ + GG_RECORDING_ENV$expand <- expand + } + if(!is.na(zoom)){ + GG_RECORDING_ENV$zoom <- zoom + } print(GG_RECORDING_ENV$last_plot) invisible() diff --git a/R/recording.R b/R/recording.R index 0fec4b0..539db0c 100644 --- a/R/recording.R +++ b/R/recording.R @@ -89,6 +89,75 @@ record_patchwork <- function(x,...) { } +#' Record gt tables +#' +#' @description Record gt tables as png using webshot2. +#' +#' @param x gt table to save +#' @param ... allow for traditionally pass arguments to printing that are ignored +#' +#' @noRd +#' +record_gt <- function(x, ...) { + + rlang::check_installed("webshot2", reason = "to record gt tables") + + table_dims <- dim(x[["_data"]]) + if (GG_RECORDING_ENV$limitsize && (table_dims[1] > 100 || table_dims[2] > 30)) { + rlang::abort(c( + "Table dimensions exceed 100x30", + i = "Render a subset with `gt_preview()` or use `limitsize = FALSE`" + )) + } + + plot_files <- + file.path(GG_RECORDING_ENV$recording_dir, paste0( + format(Sys.time(), "%Y_%m_%d_%H_%M_%OS6"), + ".", + c("html", "png") # webshot() only supports png for raster + )) + + # Convert to pixel for webshot() + as_pixel <- function(x) { + if (is.na(x)) { + return(NULL) + } + ratio <- switch( + GG_RECORDING_ENV$image_units, + "cm" = 1/2.54, + "mm" = 1/25.4, + "px" = 1, + "in" = 1 + ) + dpi_scaling <- if (GG_RECORDING_ENV$image_units == "px") { + 1 + } else { + GG_RECORDING_ENV$image_dpi + } + round(x * ratio * dpi_scaling) + } + + suppressMessages({ + gt::gtsave(data = x, filename = plot_files[1]) + # Doesn't suppress webshot() messages + # - known issue: https://github.com/rstudio/webshot2/issues/24 + webshot2::webshot( + url = plot_files[1], + file = plot_files[2], + vwidth = as_pixel(GG_RECORDING_ENV$image_width) %||% formals(webshot2::webshot)$vwidth, + vheight = as_pixel(GG_RECORDING_ENV$image_height) %||% formals(webshot2::webshot)$vheight, + selector = "table", + expand = GG_RECORDING_ENV$expand, + zoom = GG_RECORDING_ENV$zoom + ) + }) + + preview_film() + + GG_RECORDING_ENV$last_plot <- x + +} + #' Record Plots - generic #' #' @description For plot types that don't have a special print method, use this diff --git a/R/shims.R b/R/shims.R index 386e865..c83ca15 100644 --- a/R/shims.R +++ b/R/shims.R @@ -34,6 +34,15 @@ register_camcorder_shims <- function(){ ) } + if("package:gt" %in% search()){ + registerS3method( + genname = "print", + class = "gt_tbl", + method = "record_gt", + envir = getNamespace("camcorder") + ) + } + GG_RECORDING_ENV$shims_registered <- TRUE } @@ -63,6 +72,15 @@ detach_camcorder_shims <- function(){ ) } + if("package:gt" %in% search()){ + registerS3method( + genname = "print", + class = "gt_tbl", + method = "print.gt_tbl", + envir = getNamespace("gt") + ) + } + GG_RECORDING_ENV$shims_registered <- FALSE } diff --git a/man/Recording.Rd b/man/Recording.Rd index 199b536..86bbccb 100644 --- a/man/Recording.Rd +++ b/man/Recording.Rd @@ -17,7 +17,9 @@ gg_record( dpi = 300, limitsize = TRUE, device_ext = NULL, - bg = NULL + bg = NULL, + expand = 5, + zoom = 2 ) gg_playback( @@ -37,7 +39,16 @@ gg_playback( ... ) -gg_resize_film(height = NA, width = NA, units = NA, dpi = NA) +gg_resize_film( + height = NA, + width = NA, + units = NA, + dpi = NA, + scale = NA, + limitsize = NA, + expand = NA, + zoom = NA +) gg_stop_recording() } @@ -64,6 +75,23 @@ specifying dimensions in pixels.} \item{bg}{Background colour. If \code{NULL}, uses the \code{plot.background} fill value from the plot theme.} +\item{expand}{A numeric vector specifying how many pixels to expand the +clipping rectangle by. If one number, the rectangle will be expanded by +that many pixels on all sides. If four numbers, they specify the top, +right, bottom, and left, in that order. When taking screenshots of multiple +URLs, this parameter can also be a list with same length as \code{url} with +each element of the list containing a single number or four numbers to use +for the corresponding URL.} + +\item{zoom}{A number specifying the zoom factor. A zoom factor of 2 will +result in twice as many pixels vertically and horizontally. Note that using +2 is not exactly the same as taking a screenshot on a HiDPI (Retina) +device: it is like increasing the zoom to 200% in a desktop browser and +doubling the height and width of the browser window. This differs from +using a HiDPI device because some web pages load different, +higher-resolution images when they know they will be displayed on a HiDPI +device (but using zoom will not report that there is a HiDPI device).} + \item{name}{name of gif.} \item{first_image_duration}{n units of frame_duration to show the first image for.} @@ -104,8 +132,8 @@ Returns nothing. used for side effect. } \description{ Record plots created over time and generate a GIF of the plots - made in the 'R' session. Overrides the print methods for ggplot and patchwork objects - from the 'ggplot2' and 'patchwork' packages respectively. + made in the 'R' session. Overrides the print methods for ggplot, patchwork, and gt_tbl objects + from the 'ggplot2', 'patchwork', and 'gt' packages respectively. resize the film for recording, reprints and saves last plot diff --git a/tests/testthat/_snaps/gt/camcorder_playback_gt.gif b/tests/testthat/_snaps/gt/camcorder_playback_gt.gif new file mode 100644 index 0000000..b993997 Binary files /dev/null and b/tests/testthat/_snaps/gt/camcorder_playback_gt.gif differ diff --git a/tests/testthat/_snaps/gt/camcorder_preview_gt.png b/tests/testthat/_snaps/gt/camcorder_preview_gt.png new file mode 100644 index 0000000..6e370e6 Binary files /dev/null and b/tests/testthat/_snaps/gt/camcorder_preview_gt.png differ diff --git a/tests/testthat/_snaps/gt/camcorder_preview_gt_resize.png b/tests/testthat/_snaps/gt/camcorder_preview_gt_resize.png new file mode 100644 index 0000000..c7bbeb4 Binary files /dev/null and b/tests/testthat/_snaps/gt/camcorder_preview_gt_resize.png differ diff --git a/tests/testthat/_snaps/gt/camcorder_tests_gt_ggplot.gif b/tests/testthat/_snaps/gt/camcorder_tests_gt_ggplot.gif new file mode 100644 index 0000000..d524253 Binary files /dev/null and b/tests/testthat/_snaps/gt/camcorder_tests_gt_ggplot.gif differ diff --git a/tests/testthat/test-gt.R b/tests/testthat/test-gt.R new file mode 100644 index 0000000..7160980 --- /dev/null +++ b/tests/testthat/test-gt.R @@ -0,0 +1,219 @@ +skip_if_not_installed("webshot2") + +test_that("recording a basic gt works", { + + withr::with_package("gt",code = { + + rec_dir <- file.path(tempdir(),"camcorder_tests_gt") + + if(dir.exists(rec_dir)){ + unlink(rec_dir,recursive = TRUE) + } + + gg_record(dir = rec_dir) + on.exit(gg_stop_recording()) + + exibble_gt <- gt::gt(exibble) + record_gt(exibble_gt) + + expect_equal( + GG_RECORDING_ENV$last_plot, + exibble_gt + ) + + ## Recording created directory + expect_true(dir.exists(rec_dir)) + + ## Recording adds html and png files + expect_equal(file_ext(list.files(rec_dir)), c("html", "png")) + + skip_on_ci() + + file.rename( + list.files(rec_dir,full.names = TRUE,pattern = "\\.png$"), + file.path(tempdir(),"camcorder_preview_gt.png") + ) + expect_snapshot_file( + path = file.path(tempdir(),"camcorder_preview_gt.png") + ) + + }) +}) + +test_that("recording a gt with webshot options works", { + + withr::with_package("gt",code = { + + rec_dir <- file.path(tempdir(),"camcorder_tests_gt") + + if(dir.exists(rec_dir)){ + unlink(rec_dir,recursive = TRUE) + } + + gg_record(dir = rec_dir, expand = 20, zoom = .5) + on.exit(gg_stop_recording()) + + exibble_gt <- gt::gt(exibble) + record_gt(exibble_gt) + + skip_on_ci() + + file.rename( + list.files(rec_dir,full.names = TRUE,pattern = "\\.png$"), + file.path(tempdir(),"camcorder_preview_gt_resize.png") + ) + expect_snapshot_file( + path = file.path(tempdir(),"camcorder_preview_gt_resize.png") + ) + + }) +}) + +test_that("recording gt works - gif output", { + + skip_on_cran() + + skip_on_ci() + + withr::with_package("gt",code = { + + rec_dir <- file.path(tempdir(),"camcorder_tests_gt") + + if(dir.exists(rec_dir)){ + unlink(rec_dir,recursive = TRUE) + } + + gg_record( + dir = rec_dir, + device = "png", + width = 600, + height = 800, + units = "px", + zoom = 1 + ) + on.exit(gg_stop_recording()) + + # Examples from: https://gt.rstudio.com/articles/creating-summary-lines.html + # 1) + exibble_gt <- gt::gt(exibble) + record_gt(exibble_gt) + # 2) + gg_resize_film(width = 800) + # 3) + exibble_a <- + exibble[, c("num", "char", "currency", "row", "group")] |> + gt::gt(rowname_col = "row", groupname_col = "group") |> + gt::sub_missing() + record_gt(exibble_a) + # 4) + exibble_b <- + exibble_a |> + summary_rows( + groups = everything(), + columns = num, + fns = list( + average = "mean", + total = "sum", + SD = "sd" + ) + ) + record_gt(exibble_b) + # 5) + gg_resize_film(expand = 20, zoom = 2) + + playback_file <- file.path(tempdir(),"camcorder_playback_gt.gif") + + gg_playback( + name = playback_file, + first_image_duration = 1, + last_image_duration = 3, + frame_duration = 1, + image_resize = 800 + ) + + expect_true(file.exists(playback_file)) + + expect_snapshot_file( + path = file.path(tempdir(),"camcorder_playback_gt.gif") + ) + + }) +}) + +test_that("recording gt and ggplot together works - gif output", { + + skip_on_cran() + + skip_on_ci() + + withr::with_package("gt",code = { + + rec_dir <- file.path(tempdir(),"camcorder_tests_gt_ggplot") + + if(dir.exists(rec_dir)){ + unlink(rec_dir,recursive = TRUE) + } + + gg_record(dir = rec_dir) + on.exit(gg_stop_recording()) + + # safety check for rendering large tables + gt_big <- gt::gt(ggplot2::diamonds) + expect_error( + expect_message( + record_gt(gt_big), + "Table dimensions exceed" + ), + "use `limitsize = FALSE`" + ) + + # 1) + gt_1 <- gt::gt(ggplot2::diamonds) |> + gt_preview() + record_gt(gt_1) + # 2) + gt_2 <- gt::gt(ggplot2::diamonds) |> + gt::gt_preview() |> + gt::cols_hide(-c(cut, price)) + record_gt(gt_2) + # 3) + gt_3 <- aggregate(ggplot2::diamonds, price ~ cut, "mean") |> + gt::gt() |> + gt::cols_label(price = "average price") + record_gt(gt_3) + # 4) + ggplot_1 <- aggregate(ggplot2::diamonds, price ~ cut, "mean") |> + ggplot2::ggplot(ggplot2::aes(cut, price)) + + ggplot2::geom_col( + ggplot2::aes(fill = ifelse(grepl("Good", cut), "salmon", "grey35")), + show.legend = FALSE + ) + + ggplot2::scale_fill_identity() + record_ggplot(ggplot_1) + # 5) + gt_4 <- aggregate(ggplot2::diamonds, price ~ cut, "mean") |> + gt::gt() |> + gt::cols_label(price = "average price") |> + gt::tab_style( + style = list(gt::cell_fill(color = "salmon")), + locations = gt::cells_body(rows = 2:3) + ) + record_gt(gt_4) + + playback_file <- file.path(tempdir(),"camcorder_tests_gt_ggplot.gif") + + gg_playback( + name = playback_file, + first_image_duration = 1, + last_image_duration = 3, + frame_duration = 1 + ) + + expect_true(file.exists(playback_file)) + + expect_snapshot_file( + path = file.path(tempdir(),"camcorder_tests_gt_ggplot.gif") + ) + + }) +})