Update documentation around inclusion of lockfile

DESCRIPTION

@@ -17,10 +17,11 @@ Imports:
     cli,
     constructive,
     purrr,
-    rlang,
     renv,
+    rlang,
     styler
 Suggests:
+    dplyr,
     knitr,
     rmarkdown,
     shiny,

R/reprex_lockfile.R

@@ -123,10 +123,13 @@
                             session = shiny::getDefaultReactiveDomain()) {
   if (is.null(packages)) {
     packages <- reprex_packages(..., session = session)
+    detect_term <- "detected"
+  } else {
+    detect_term <- "selected"
   }
 
   if (length(packages) == 0L) {
-    cli::cli_warn("No non-base packages detected; the lockfile will record only the R version")
+    cli::cli_warn("No non-base packages {detect_term}; the lockfile will record only the R version")
   }
 
   # Snapshot against a throwaway project so renv never writes infrastructure

R/walk_packages.R

@@ -43,8 +43,7 @@ walk_packages <- function(expr, env, seen = character(), packages = character())
 
   call_name <- rlang::call_name(expr)
 
-  # Shiny calls that are stripped when reproducing code contribute nothing, as
-  # the script is intended to run outside of Shiny. Mirrors `class_call_shiny`.
+  # Shiny calls that are stripped when reproducing code contribute nothing
   if (!is.null(call_name) && call_name %in% IGNORED_SHINY_CALLS) {
     return(packages)
   }
@@ -64,7 +63,10 @@ walk_packages <- function(expr, env, seen = character(), packages = character())
 
   packages <- union(packages, get_pkg_name(expr))
 
-  for (arg in as.list(expr)[-1L]) {
+  # Omitted arguments, such as the empty index in `iris[cond, ]` cannot be walked
+  arguments <- purrr::discard(as.list(expr)[-1L], rlang::is_missing)
+
+  for (arg in arguments) {
     packages <- walk_packages(arg, env, seen, packages)
   }
 

README.md

@@ -15,6 +15,9 @@ Due to the interactiveness of Shiny, this isn't as easy to include out of the bo
 inputs set by the user, and need to be replaced in the reactive expressions to be able to run in an
 environment outside of Shiny.
 
+The script alone reproduces the code, but not the environment it ran in. The packages it depends on
+can also be captured as an `renv` lockfile, so the environment can be rebuilt rather than guessed at.
+
 ## Installation
 
 ``` r
@@ -92,3 +95,47 @@ server <- function(input, output, session) {
 
 shinyApp(ui, server)
 ```
+
+## Pinning Package Versions
+
+`reprex_reactive` emits the `library()` calls a script needs, but not the versions those packages
+were at. `reprex_lockfile` records them, along with the R version and the full recursive dependency
+tree, as an [`renv`](https://rstudio.github.io/renv/) lockfile:
+
+```r
+output$lockfile <- downloadHandler(
+  filename = function() "renv.lock",
+  content = function(file) reprex_lockfile(summary_tbl, lockfile = file)
+)
+```
+
+Whoever receives the lockfile rebuilds the environment with:
+
+```r
+renv::restore(lockfile = "renv.lock")
+```
+
+In a modular application each module can register the reactives it owns, so a whole-application
+lockfile needs no reactives passed up to the top level:
+
+```r
+moduleServer(id, function(input, output, session) {
+  summary_tbl <- reactive(...)
+
+  register_reactives(summary_tbl)
+})
+
+# Elsewhere, covering every registered reactive
+reprex_lockfile(lockfile = file)
+```
+
+`reprex_packages` reports the detected packages, either to display them or to let the user narrow
+the set before pinning it via the `packages` argument.
+
+## Example Application
+
+An example covering all of the above ships with the package:
+
+```r
+shiny::runExample("lockfile", package = "shinyreprex")
+```

inst/examples-shiny/lockfile/app.R

@@ -0,0 +1,165 @@
+library(shiny)
+library(shinyreprex)
+
+# Two modules doing different work with different packages. Each registers the
+# reactive behind its own table, so their scripts carry different `library()`
+# calls while the single download in the navbar pins the union of both.
+
+result_cards <- function(ns) {
+  bslib::layout_columns(
+    bslib::card(bslib::card_header("Output"), tableOutput(ns("table"))),
+    bslib::card(bslib::card_header("Reproducible script"), verbatimTextOutput(ns("code")))
+  )
+}
+
+width_slider <- function(ns) {
+  sliderInput(
+    ns("min_width"),
+    "Minimum petal width",
+    min(iris$Petal.Width),
+    max(iris$Petal.Width),
+    min(iris$Petal.Width),
+    step = 0.1
+  )
+}
+
+#### Summarise with {purrr} ####
+summaryUI <- function(id) {
+  ns <- NS(id)
+
+  bslib::layout_sidebar(
+    sidebar = bslib::sidebar(
+      width_slider(ns),
+      selectInput(
+        ns("summary_fn"),
+        "Summary function",
+        c(Mean = "mean", Median = "median", `Std. dev` = "sd")
+      ),
+      actionButton(ns("update"), "Update", class = "btn-primary")
+    ),
+    result_cards(ns)
+  )
+}
+
+summaryServer <- function(id, columns) {
+  moduleServer(id, function(input, output, session) {
+    filtered <- reactive({
+      iris[iris$Petal.Width >= input$min_width, ]
+    }) |>
+      bindEvent(input$update, ignoreNULL = FALSE)
+
+    summary_tbl <- reactive({
+      purrr::map(
+        columns,
+        dat = filtered(),
+        fn = input$summary_fn,
+        \(col, dat, fn) {
+          aggregate(as.formula(paste(col, "~ Species")), data = dat, FUN = get(fn))
+        }
+      ) |>
+        purrr::reduce(merge, by = "Species")
+    }) |>
+      bindEvent(input$update, ignoreNULL = FALSE)
+
+    register_reactives(summary_tbl)
+
+    output$table <- renderTable(summary_tbl())
+    output$code <- renderText(reprex_reactive(summary_tbl)) |>
+      bindEvent(summary_tbl())
+
+    summary_tbl
+  })
+}
+
+#### Count with {dplyr} ####
+countsUI <- function(id) {
+  ns <- NS(id)
+
+  bslib::layout_sidebar(
+    sidebar = bslib::sidebar(
+      width_slider(ns),
+      actionButton(ns("update"), "Update", class = "btn-primary")
+    ),
+    result_cards(ns)
+  )
+}
+
+countsServer <- function(id) {
+  moduleServer(id, function(input, output, session) {
+    counts_tbl <- reactive({
+      iris |>
+        dplyr::filter(Petal.Width >= input$min_width) |>
+        dplyr::group_by(Species) |>
+        dplyr::summarise(flowers = dplyr::n(), mean_sepal_width = mean(Sepal.Width))
+    }) |>
+      bindEvent(input$update, ignoreNULL = FALSE)
+
+    register_reactives(counts_tbl)
+
+    output$table <- renderTable(counts_tbl())
+    output$code <- renderText(reprex_reactive(counts_tbl)) |>
+      bindEvent(counts_tbl())
+
+    counts_tbl
+  })
+}
+
+#### UI ####
+ui <- bslib::page_navbar(
+  title = "shinyreprex",
+  header = bslib::card(
+    fill = FALSE,
+    class = "mx-4 my-2",
+    bslib::card_header("About"),
+    p(
+      class = "mb-0 text-body-secondary",
+      "Each tab is a module that registers its own reactive with ",
+      code("register_reactives()"), ", so their scripts carry different ",
+      code("library()"), " calls. One lockfile pins the union of both."
+    ),
+    div(
+      class = "d-flex align-items-center",
+      div(
+        class = "mx-3",
+        checkboxGroupInput("packages", "Include in lockfile", inline = TRUE)
+      ),
+      div(
+        class = "mx-3",
+        downloadButton("lockfile", "Download renv.lock", class = "btn-primary")
+      )
+    )
+  ),
+
+  bslib::nav_panel("Summary (purrr)", summaryUI("summary")),
+  bslib::nav_panel("Counts (dplyr)", countsUI("counts"))
+)
+
+#### Server ####
+server <- function(input, output, session) {
+  summary_tbl <- summaryServer("summary", c("Sepal.Length", "Sepal.Width"))
+  counts_tbl <- countsServer("counts")
+
+  detected <- reactive(reprex_packages())
+
+  observe({
+    updateCheckboxGroupInput(
+      session = session,
+      inputId = "packages",
+      choices = detected(),
+      selected = detected(),
+      inline = TRUE
+    )
+  }) |>
+    bindEvent(detected(), once = TRUE)
+
+  output$lockfile <- downloadHandler(
+    filename = function() "renv.lock",
+    content = function(file) {
+      withProgress(message = "Resolving package versions", {
+        reprex_lockfile(packages = input$packages, lockfile = file)
+      })
+    }
+  )
+}
+
+shinyApp(ui, server)

tests/testthat/test-examples-shiny.R

@@ -0,0 +1,69 @@
+app_dir <- function(name) {
+  path <- system.file("examples-shiny", name, package = "shinyreprex")
+  if (!nzchar(path)) skip(paste0("Example app '", name, "' is not installed"))
+  path
+}
+
+set_module_inputs <- function(session) {
+  session$setInputs(
+    `summary-min_width` = 0.5,
+    `summary-summary_fn` = "median",
+    `summary-update` = 1,
+    `counts-min_width` = 1,
+    `counts-update` = 1
+  )
+}
+
+test_that("Each module in the example app generates a script that reproduces its own table", {
+  skip_if_not_installed("shiny")
+  skip_if_not_installed("dplyr")
+
+  shiny::testServer(app_dir("lockfile"), {
+    set_module_inputs(session)
+
+    expect_equal(
+      eval(parse(text = output$`summary-code`), envir = new.env()),
+      summary_tbl()
+    )
+    expect_equal(
+      eval(parse(text = output$`counts-code`), envir = new.env()),
+      counts_tbl()
+    )
+  })
+})
+
+test_that("Each module reports only the packages its own reactive uses", {
+  skip_if_not_installed("shiny")
+  skip_if_not_installed("dplyr")
+
+  shiny::testServer(app_dir("lockfile"), {
+    set_module_inputs(session)
+
+    expect_identical(reprex_packages(summary_tbl), "purrr")
+    expect_identical(reprex_packages(counts_tbl), "dplyr")
+
+    # A no-argument call reads the registry, covering both modules at once.
+    expect_named(
+      registered_reactives(session),
+      c("summary-summary_tbl", "counts-counts_tbl")
+    )
+    expect_setequal(reprex_packages(), c("purrr", "dplyr"))
+  })
+})
+
+test_that("The example app offers a restorable lockfile covering both modules", {
+  skip_on_cran()
+  skip_if_not_installed("shiny")
+  skip_if_not_installed("dplyr")
+  skip_if_not_installed("renv")
+
+  shiny::testServer(app_dir("lockfile"), {
+    set_module_inputs(session)
+
+    # Reading a download output runs its content function and returns the path.
+    parsed <- renv::lockfile_read(output$lockfile)
+
+    expect_identical(parsed$R$Version, as.character(getRversion()))
+    expect_true(all(c("purrr", "dplyr") %in% names(parsed$Packages)))
+  })
+})

tests/testthat/test-reprex_lockfile.R

@@ -21,6 +21,35 @@ test_that("A non-reactive object passed to reprex_packages errors", {
 })
 
 #### reprex_lockfile ####
+test_that("An empty package set warns differently depending on whether it was detected or selected", {
+  skip_on_cran()
+  skip_if_not_installed("renv")
+
+  test_server <- function(input, output, session) {
+    base_only <- reactive(nrow(iris))
+    with_purrr <- reactive(purrr::keep(iris, is.numeric))
+  }
+
+  lock <- tempfile(fileext = ".lock")
+  on.exit(unlink(lock), add = TRUE)
+
+  shiny::testServer(test_server, {
+    # Nothing found in the reactive itself.
+    expect_warning(
+      reprex_lockfile(base_only, lockfile = lock),
+      "No non-base packages detected",
+      fixed = TRUE
+    )
+
+    # Packages were available, but the caller narrowed them away.
+    expect_warning(
+      reprex_lockfile(with_purrr, packages = character(), lockfile = lock),
+      "No non-base packages selected",
+      fixed = TRUE
+    )
+  })
+})
+
 test_that("A restorable lockfile is written covering the reactive's packages", {
   skip_on_cran()
 

tests/testthat/test-walk_packages.R

@@ -88,6 +88,17 @@ test_that("Shiny calls stripped when reproducing code do not pull in shiny", {
   })
 })
 
+test_that("An omitted index, as in a row subset, does not stop the walk", {
+  test_server <- function(input, output, session) {
+    tbl <- reactive(purrr::keep(iris[iris$Petal.Width > input$w, ], is.numeric))
+  }
+
+  shiny::testServer(test_server, {
+    session$setInputs(w = 1)
+    expect_identical(reprex_packages(tbl), "purrr")
+  })
+})
+
 test_that("A reactive using only base functions reports no packages", {
   test_server <- function(input, output, session) {
     tbl <- reactive(nrow(iris))