Merge pull request #26 from dataheld/screenshots2gifs

add more screenshots

.gitignore

@@ -5,6 +5,7 @@
 docs/
 man/*.Rd
 !man/figures/
+man/figures/niffler_screenshots
 ~*.xlsx
 ~*.xlsm
 # {shinytest2}: Ignore new debug snapshots for `$expect_values()`

DESCRIPTION

@@ -17,7 +17,7 @@ Authors@R:
     )
 Description:
     Helpers for shiny development.
-URL: https://github.com/dataheld/niffler
+URL: https://github.com/dataheld/niffler, https://niffler.maxheld.de
 BugReports: https://github.com/dataheld/niffler/issues
 License: file LICENSE
 Encoding: UTF-8
@@ -26,20 +26,21 @@ Language: en
 Roxygen: list(markdown = TRUE)
 Imports:
     checkmate,
+    fs,
     glue,
     purrr,
     rlang,
     shiny,
+    testthat
 Suggests:
     bslib,
     brio,
     elf,
-    fs,
     roxygen2,
     shinytest2,
     showimage,
-    testthat,
-    withr
+    withr,
+    magick
 Remotes:
     dataheld/elf
 Config/testthat/edition: 3

NAMESPACE

@@ -1,21 +1,31 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(format,rd_section_nifflerInsertSnaps)
 S3method(roxygen2::roxy_tag_parse,roxy_tag_nifflerExamplesShiny)
+S3method(roxygen2::roxy_tag_parse,roxy_tag_nifflerInsertSnaps)
 S3method(roxygen2::roxy_tag_rd,roxy_tag_nifflerExamplesShiny)
+S3method(roxygen2::roxy_tag_rd,roxy_tag_nifflerInsertSnaps)
 export(abort_if_not_reactive)
 export(abort_if_reactive)
 export(counter_button_app)
 export(counter_button_server)
 export(counter_button_ui)
+export(dir_ls_snaps)
 export(examples_app)
 export(get_screenshot_args_attr)
 export(get_screenshot_from_app)
+export(glue_regexp_snaps)
+export(image_animate_snaps)
+export(image_write_snaps)
 export(mixed_react_tree_app)
 export(mixed_react_tree_server)
 export(mixed_react_tree_ui)
 export(module2app)
 export(module2app_server)
 export(module2app_ui)
+export(snaps2fig)
+export(snaps2md)
+export(snaps2rd)
 export(x_counter_button_app)
 export(x_counter_button_server)
 export(x_counter_button_ui)

R/helpers.R

@@ -23,3 +23,12 @@ examples_app <- function(example = "01_hello") {
 skip_if_load_all2 <- function() {
   elf::skip_if_pkg_installed_but_not_via_loadall("niffler")
 }
+
+skip_example_screenshots <- function() {
+  testthat::skip(
+    message = paste(
+      "Setting up example screenshots.",
+      "These need not be tested themselves, but are used in other tests."
+    )
+  )
+}

R/shiny2screenshot.R

@@ -18,14 +18,14 @@ NULL
 
 #' @rdname tag_shiny
 #' @details
-#' - `@nifflerExamplesShiny${1:# example code}`
+#' - `@nifflerExamplesShiny$ {1:# example code}`
 #'    R code which returns a shiny app.
 #'    A screenshot of the shiny app is added to the documentation,
 #'    along with the code required to create the screenshot and
 #'    launch the app interactively.
 #'    Wraps @examples.
 #' @usage
-#' # @nifflerExamplesShiny${1:# example code}
+#' # @nifflerExamplesShiny ${1:# example code}
 #' @name nifflerExamplesShiny
 NULL
 
@@ -68,8 +68,6 @@ check_installed_shinytest2 <- function() {
   )
 }
 
-# TODO add link to snapshot-reuse function
-# https://github.com/dataheld/niffler/issues/13.
 #' Get screenshot from shiny app
 #'
 #' Wrapper around [shinytest2::AppDriver()].
@@ -125,10 +123,10 @@ get_screenshot_from_app <- function(appDir,
         glue::glue(
           "The screenshot could not be generated.",
           "Please check the logs for errors.",
-          sep = " "
+          .sep = " "
         )
       },
-      quiet = FALSE
+      quiet = TRUE
     )
   }
   f_screenshot()
@@ -149,3 +147,246 @@ get_screenshot_from_app_strictly <- function(appDir,
   withr::defer(driver$stop())
   driver$get_screenshot(file = file)
 }
+
+# nifflerInsertSnaps tag ====
+
+#' @rdname tag_shiny
+#' @details
+#' - `@nifflerInsertSnaps
+#'    ${1:test_file}
+#'    ${2:name}
+#'    ${3:auto_numbered}
+#'    ${4:variant}
+#'    ${5:fps}`
+#'    Instead of re-creating screenshots,
+#'    insert reused screenshots created by
+#'    [shinytest2](https://rstudio.github.io/shinytest2/) snapshot testing.
+#'    For arguments and defaults, see [snaps2fig()].
+#'    You can also use [snaps2md()] directly, without a custom tag.
+#' @usage
+#' # @nifflerInsertSnaps
+#' # ${1:test_file}
+#' # ${2:name}
+#' # ${3:auto_numbered}
+#' # ${4:variant}
+#' # ${5:fps}
+#' @nifflerInsertSnaps
+#' helpers
+#' bins
+#' FALSE
+#' linux
+#' @name nifflerInsertSnaps
+NULL
+
+#' @exportS3Method roxygen2::roxy_tag_parse
+roxy_tag_parse.roxy_tag_nifflerInsertSnaps <- function(x) {
+  check_installed_roxygen2()
+  roxygen2::tag_words(x, min = 1, max = 5)
+}
+
+#' @exportS3Method roxygen2::roxy_tag_rd
+roxy_tag_rd.roxy_tag_nifflerInsertSnaps <- function(x, base_path, env) {
+  args <- as.list(x[["val"]])
+  if (length(args) >= 2) args[[3]] <- as.logical(args[[3]])
+  roxygen2::rd_section(
+    type = "nifflerInsertSnaps",
+    value = rlang::exec(snaps2rd, !!!args)
+  )
+}
+
+#' @export
+format.rd_section_nifflerInsertSnaps <- function(x, ...) {
+  paste0(
+    "\\section{Screenshots from Tests}{\n",
+    "\\if{html}",
+    x$value,
+    "\\if{latex}{Screenshots cannot be shown in this output format.}",
+    "}\n"
+  )
+}
+
+#' Get screenshots from snapshots
+#'
+#' Retrieves screenshots from
+#' [testthat](https://testthat.r-lib.org)'s `_snaps/` directory.
+#' If several files match `dir_ls_snaps()`,
+#' they are merged into an animated gif.
+#' @family documentation
+#' @name get_screenshot_from_snaps
+NULL
+
+#' @describeIn get_screenshot_from_snaps
+#' Save screenshots to `man/figures` and return *relative* path from there.
+#' @inheritParams glue_regexp_snaps
+#' @export
+snaps2fig <- function(test_file = character(),
+                      name = NULL,
+                      auto_numbered = TRUE,
+                      variant = shinytest2::platform_variant(),
+                      fps = 5,
+                      ...) {
+  snaps_paths <- dir_ls_snaps(
+    test_file = test_file,
+    regexp = glue_regexp_snaps(
+      name = name,
+      auto_numbered = auto_numbered
+    ),
+    variant = variant
+  )
+  if (length(snaps_paths) == 0) {
+    rlang::abort(
+      "No images were found."
+    )
+  }
+  snaps_img <- image_animate_snaps(snaps = snaps_paths, fps = fps, ...)
+  path_for_results <- fs::path(
+    "man",
+    "figures",
+    "niffler_screenshots",
+    test_file,
+    if (!is.null(name)) name,
+    ext = unique(magick::image_info(snaps_img)$format)
+  )
+  fs::dir_create(path = fs::path_dir(path_for_results))
+  # side effect happens here
+  res <- image_write_snaps(snaps_img, path = path_for_results)
+  # roxygen2/man markdown expects relative paths from here
+  fs::path_rel(res, start = "man/figures")
+}
+
+snap_alt_text <- function() "Screenshot from App"
+
+#' @describeIn get_screenshot_from_snaps
+#' Save screenshots to `man/figures` and return markdown image markup,
+#' to be inserted in roxygen2 documentation.
+#' @param ... Arguments passed on to other functions.
+#' @export
+snaps2md <- function(...) {
+  path <- snaps2fig(...)
+  paste0("![", snap_alt_text(), "](", path, ")", collapse = "")
+}
+
+#' @describeIn get_screenshot_from_snaps
+#' Save screenshots to `man/figures` and return R documentation image markup,
+#' to be inserted in R documentation.
+#' For a custom roxygen2 tag with equivalent funcionality,
+#' see [nifflerInsertSnaps()].
+#' @export
+snaps2rd <- function(...) {
+  path <- snaps2fig(...)
+  paste0(
+    "{\\figure{",
+    path,
+    "}{options: width='100\\%' alt=",
+    snap_alt_text(),
+    "}}",
+    collapse = ""
+  )
+}
+
+#' @describeIn get_screenshot_from_snaps
+#' List all testthat `_snaps/` screenshots
+#' Finds all files for a variant, file and name.
+#'
+#' @section Matching several screenshots:
+#' You can deposit several screenshots of a shiny app using
+#' [shinytest2::AppDriver] in testing.
+#' Use [dir_ls_snaps()] to identify all the resulting images.
+#' Typically used for *consecutive* screenshots.
+#' @param test_file
+#' Name of the test file, in which the snapshots are generated,
+#' *without*:
+#' - the extension
+#' - the `test-` prefix.
+#' If you're using testthat convention,
+#' this will be the name of the file in `R/`,
+#' which you are currently testing.
+#' @inheritParams shinytest2::AppDriver
+#' @inheritParams testthat::expect_snapshot_file
+#' @inheritParams fs::dir_ls
+#' @export
+dir_ls_snaps <- function(test_file = character(),
+                         regexp = glue_regexp_snaps(),
+                         variant = shinytest2::platform_variant()) {
+  checkmate::assert_string(test_file)
+  test_path <- testthat::test_path("_snaps", variant, test_file)
+  fs::dir_ls(
+    test_path,
+    all = FALSE,
+    recurse = FALSE,
+    type = "file",
+    regexp = regexp
+  )
+}
+
+#' Build the regular expression to match consecutive screenshots
+#'
+#' [shinytest2::AppDriver] uses several schemes to
+#' name consecutive screenshot files.
+#' Use this regex to capture paths of screenshots.
+#' @param name
+#' The `name` passed to [shinytest2::AppDriver] to be used for screenshots.
+#' Can be `NULL`, for no filtering by name.
+#' @param auto_numbered
+#' If `TRUE`, filter for snapshot files automatically numbered
+#' according to the scheme used by [shinytest2::AppDriver].
+#' If you pass a `name` only to `shinytest2::AppDriver$new()` (recommended),
+#' and then invoke several `shinytest2::AppDriver$expect_snapshot()`,
+#' they resulting snapshots will all have the same name,
+#' appended by a counter from `000` to `999`.
+#' If `FALSE`, any filename `{name}*.png` will be selected.
+#' You may need to set `FALSE`
+#' if you pass a name to`shinytest2::AppDriver$expect_snapshot()`
+#' directly.
+#' @family documentation
+#' @export
+glue_regexp_snaps <- function(name = NULL, auto_numbered = TRUE) {
+  checkmate::assert_string(name, null.ok = TRUE)
+  checkmate::assert_flag(auto_numbered)
+  glue::glue(
+    "^.*[\\\\/]",  # path
+    if (is.null(name)) "" else "{name}",
+    if (!is.null(name) && auto_numbered) "-" else "",
+    if (auto_numbered) "\\d{{3}}" else ".*",
+    # shinytest2 only defaults to png
+    "\\.png$"
+  )
+}
+
+#' @describeIn get_screenshot_from_snaps
+#' Read in screenshot.
+#' If several, animate into a gif.
+#' @param snaps
+#' Vector of file names, as returned by [dir_ls_snaps()]
+#' @inheritParams magick::image_animate
+#' @inheritDotParams magick::image_animate
+#' @return For [image_animate_snaps()] A `magick-image`.
+#' @export
+image_animate_snaps <- function(snaps = fs::path(), fps = 5, ...) {
+  if (any(!fs::file_exists(snaps))) rlang::abort("File could not be found.")
+  names(snaps) <- fs::path_file(snaps)
+  check_installed_magick()
+  # stripping helps to avoid spurious diffs
+  res <- magick::image_read(snaps, strip = TRUE)
+  if (length(snaps) == 1) {
+    res
+  } else {
+    magick::image_animate(res, fps = fps, ...)
+  }
+}
+
+#' @describeIn get_screenshot_from_snaps
+#' Write out (merged) screenshots to new path.
+#' @inheritParams magick::image_write
+#' @return For [image_write_snaps()], path to the (merged) screenshots.
+#' @export
+image_write_snaps <- function(image, path = withr::local_tempfile()) {
+  magick::image_write(image = image, path = path)
+}
+
+check_installed_magick <- function() {
+  rlang::check_installed(
+    "magick",
+    reason = "magick is needed show `snaps`."
+  )
+}

inst/examples/snaps2fig/example.R

@@ -0,0 +1,7 @@
+#' An example documentation with inserted snaps
+#' @nifflerInsertSnaps
+#' helpers
+#' bins
+#' FALSE
+#' linux
+bins_app <- function() examples_app()