Add example application showing off lockfile generation

.github/linters/.lintr

@@ -3,3 +3,7 @@ linters: linters_with_defaults(
   object_name_linter = NULL
   ) # see vignette("lintr")
 encoding: "UTF-8"
+# Exclusion paths are resolved relative to this file, not the package root
+exclusions: list(
+    "../../inst/examples-shiny"
+  )

DESCRIPTION

@@ -21,6 +21,7 @@ Imports:
     renv,
     styler
 Suggests:
+    dplyr,
     knitr,
     rmarkdown,
     shiny,

R/reprex_lockfile.R

@@ -123,10 +123,13 @@ reprex_lockfile <- function(...,
                             session = shiny::getDefaultReactiveDomain()) {
   if (is.null(packages)) {
     packages <- reprex_packages(..., session = session)
+    detect_term <- "detected" #nolint
+  } else {
+    detect_term <- "selected" #nolint
   }
 
   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)
   }
 

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)) testthat::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))