diff --git a/.github/linters/.lintr b/.github/linters/.lintr index c5aa6ca..70a8e9f 100644 --- a/.github/linters/.lintr +++ b/.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" + ) diff --git a/DESCRIPTION b/DESCRIPTION index b6ee3db..e597929 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,6 +21,7 @@ Imports: renv, styler Suggests: + dplyr, knitr, rmarkdown, shiny, diff --git a/R/reprex_lockfile.R b/R/reprex_lockfile.R index ca5941a..44d398e 100644 --- a/R/reprex_lockfile.R +++ b/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 diff --git a/R/walk_packages.R b/R/walk_packages.R index 64a6785..796a41b 100644 --- a/R/walk_packages.R +++ b/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) } diff --git a/inst/examples-shiny/lockfile/app.R b/inst/examples-shiny/lockfile/app.R new file mode 100644 index 0000000..95ccfa2 --- /dev/null +++ b/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) diff --git a/tests/testthat/test-examples-shiny.R b/tests/testthat/test-examples-shiny.R new file mode 100644 index 0000000..59fe2f4 --- /dev/null +++ b/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))) + }) +}) diff --git a/tests/testthat/test-reprex_lockfile.R b/tests/testthat/test-reprex_lockfile.R index c7a5a35..7d07034 100644 --- a/tests/testthat/test-reprex_lockfile.R +++ b/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() diff --git a/tests/testthat/test-walk_packages.R b/tests/testthat/test-walk_packages.R index 1595118..182f4c0 100644 --- a/tests/testthat/test-walk_packages.R +++ b/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))