├── .github ├── .gitignore └── workflows │ └── R-CMD-check.yaml ├── vignettes ├── .gitignore ├── special-topics.Rmd ├── code-distribution.Rmd └── code-generation.Rmd ├── R ├── globals.R ├── imports.R ├── zzz.R ├── print.R ├── output-code.R ├── display.R ├── observe.R ├── archive.R ├── utils-format.R ├── render.R ├── format.R ├── utils.R ├── report.R └── metareactive.R ├── pkgdown └── extra.css ├── tests ├── testthat.R └── testthat │ ├── test-ast.R │ ├── assets │ └── template.Rmd │ ├── _snaps │ ├── report │ │ └── template.Rmd │ ├── render.md │ ├── metareactive.md │ └── format.md │ ├── test-utils.R │ ├── test-deparsing.R │ ├── test-metamodes.R │ ├── test-observe.R │ ├── test-archive.R │ ├── test-format.R │ ├── test-report.R │ ├── test-expandchain.R │ ├── test-metareactive.R │ ├── test-expansion.R │ ├── test-render.R │ └── test-comments.R ├── inst ├── examples │ ├── anova │ │ └── app.R │ ├── cranview │ │ └── app.R │ ├── hello-distribution │ │ ├── report.Rmd │ │ └── app.R │ ├── contingency │ │ ├── full.Rmd │ │ ├── model.Rmd │ │ ├── plot.Rmd │ │ └── app.R │ ├── hello-generation │ │ └── app.R │ ├── modules │ │ └── app.R │ └── interactive-lm │ │ └── app.R ├── lib │ └── output-code │ │ └── output-code.js └── report-template.Rmd ├── .gitignore ├── .Rbuildignore ├── shinymeta.Rproj ├── man ├── withMetaMode.Rd ├── knit_print.shinyMetaExpr.Rd ├── metaExpr.Rd ├── buildScriptBundle.Rd ├── metaAction.Rd ├── outputCodeButton.Rd ├── formatCode.Rd ├── displayCodeModal.Rd ├── metaObserve.Rd ├── dotdot.Rd ├── metaRender.Rd ├── metaReactive.Rd └── expandChain.Rd ├── _pkgdown.yml ├── DESCRIPTION ├── NAMESPACE ├── NEWS.md └── README.md /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /R/globals.R: -------------------------------------------------------------------------------- 1 | utils::globalVariables(c("!!", "as.symbol<-", "!<-")) 2 | -------------------------------------------------------------------------------- /pkgdown/extra.css: -------------------------------------------------------------------------------- 1 | img { 2 | border: 1px solid #ddd; box-shadow:5px 5px 5px #eee; 3 | } 4 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(shinymeta) 3 | 4 | test_check("shinymeta") 5 | -------------------------------------------------------------------------------- /inst/examples/anova/app.R: -------------------------------------------------------------------------------- 1 | # https://github.com/cpsievert/DIY_ANOVA 2 | shiny::runGitHub("DIY_ANOVA", "cpsievert") 3 | -------------------------------------------------------------------------------- /inst/examples/cranview/app.R: -------------------------------------------------------------------------------- 1 | # https://github.com/cpsievert/cranview 2 | shiny::runGitHub("cranview", "cpsievert") 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | inst/doc 2 | .Rproj.user 3 | .Rhistory 4 | .RData 5 | .Ruserdata 6 | .DS_Store 7 | sandbox 8 | doc 9 | Meta 10 | docs 11 | -------------------------------------------------------------------------------- /tests/testthat/test-ast.R: -------------------------------------------------------------------------------- 1 | test_that("walk_ast can handle missing args", { 2 | expr <- quote(mtcars[1:5, ]) 3 | expect_identical( 4 | expr, walk_ast(expr, identity) 5 | ) 6 | }) 7 | -------------------------------------------------------------------------------- /inst/examples/hello-distribution/report.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "My great report" 3 | output: pdf_document 4 | --- 5 | 6 | This is nice 7 | 8 | ```{r, message=FALSE} 9 | {{code}} 10 | ``` 11 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | examples 4 | ^_pkgdown\.yml$ 5 | ^docs$ 6 | ^pkgdown$ 7 | ^\.travis\.yml$ 8 | ^tools$ 9 | ^sandbox$ 10 | ^doc$ 11 | ^Meta$ 12 | ^\.github$ 13 | ^vignettes$ 14 | -------------------------------------------------------------------------------- /tests/testthat/assets/template.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "A test template" 3 | output: html_document 4 | --- 5 | 6 | {{desc}} 7 | 8 | ```{r} 9 | {{code_chunk}} 10 | ``` 11 | 12 | The result is `r {{code_inline}}`. 13 | 14 | The values are {{x}} and {{y}}. 15 | -------------------------------------------------------------------------------- /inst/examples/contingency/full.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "My analysis" 3 | output: html_document 4 | --- 5 | 6 | ```{r, include=FALSE} 7 | knitr::opts_chunk$set(message = FALSE) 8 | ``` 9 | 10 | A full output of your analysis 11 | 12 | ```{r} 13 | {{code}} 14 | ``` 15 | -------------------------------------------------------------------------------- /inst/examples/contingency/model.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "My awesome test" 3 | output: html_document 4 | --- 5 | 6 | ```{r, include=FALSE} 7 | knitr::opts_chunk$set(message = FALSE) 8 | ``` 9 | 10 | A test of `{{xvar}}` vs `{{yvar}}` 11 | 12 | ```{r} 13 | {{code}} 14 | ``` 15 | -------------------------------------------------------------------------------- /R/imports.R: -------------------------------------------------------------------------------- 1 | #' @importFrom sourcetools tokenize_string 2 | #' @importFrom shiny reactive getDefaultReactiveDomain isolate tags div 3 | #' @importFrom utils head zip getFromNamespace 4 | #' @importFrom rlang expr exprs quo enquo new_quosure quo_get_expr %||% is_syntactic_literal 5 | NULL 6 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/report/template.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "A test template" 3 | output: html_document 4 | --- 5 | 6 | # Weekly report 7 | 8 | Looks like `cars` hasn't changed since last week. 9 | 10 | ```{r} 11 | plot(cars) 12 | ``` 13 | 14 | The result is `r 1 + 1`. 15 | 16 | The values are 1 and 2. 17 | -------------------------------------------------------------------------------- /inst/examples/contingency/plot.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Mosaic chart" 3 | output: html_document 4 | --- 5 | 6 | ```{r, include=FALSE} 7 | knitr::opts_chunk$set(message = FALSE) 8 | ``` 9 | 10 | To read more about this visualization, see 11 | 12 | ```{r} 13 | {{code}} 14 | ``` 15 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/render.md: -------------------------------------------------------------------------------- 1 | # metaRender: works with a render pipeline 2 | 3 | # top-level comment 4 | data <- dplyr::sample_n(diamonds, 1000) 5 | ggplot(data, aes(carat, price)) + 6 | geom_point() 7 | 8 | --- 9 | 10 | # top-level comment 11 | data <- dplyr::sample_n(diamonds, 1000) 12 | ggplot(data, aes(carat, price)) + 13 | geom_point() 14 | 15 | -------------------------------------------------------------------------------- /inst/lib/output-code/output-code.js: -------------------------------------------------------------------------------- 1 | $(document).on("click", ".shinymeta-output-code button", function() { 2 | var id = $(this).parents(".shinymeta-output-code").find(".shiny-bound-output").attr("id"); 3 | // Invalidate `input$id_output_code` whenever the button of 4 | // shinymeta::outputCodeButton(plotOutput("id")) is pressed 5 | if (id) { 6 | Shiny.setInputValue(id + "_output_code", 'true', {priority: 'event'}); 7 | } 8 | }); 9 | -------------------------------------------------------------------------------- /inst/report-template.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Some ggplot2 code" 3 | author: "" 4 | output: 5 | pdf_document: default 6 | html_document: 7 | code_folding: "hide" 8 | --- 9 | 10 | ```{r setup, include = FALSE} 11 | knitr::opts_chunk$set( 12 | out.width = "100%", 13 | tidy = TRUE 14 | ) 15 | ``` 16 | 17 | Here is the first output: 18 | 19 | ```{r} 20 | {{plot1}} 21 | ``` 22 | 23 | And the second one: 24 | 25 | ```{r} 26 | {{plot2}} 27 | ``` 28 | -------------------------------------------------------------------------------- /shinymeta.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageCheckArgs: --as-cran 22 | PackageRoxygenize: rd,collate,namespace 23 | -------------------------------------------------------------------------------- /man/withMetaMode.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/metareactive.R 3 | \name{withMetaMode} 4 | \alias{withMetaMode} 5 | \title{Evaluate an expression with meta mode activated} 6 | \usage{ 7 | withMetaMode(expr, mode = TRUE) 8 | } 9 | \arguments{ 10 | \item{expr}{an expression.} 11 | 12 | \item{mode}{whether or not to evaluate expression in meta mode.} 13 | } 14 | \value{ 15 | The result of evaluating \code{expr}. 16 | } 17 | \description{ 18 | Evaluate an expression with meta mode activated 19 | } 20 | \seealso{ 21 | \code{\link[=expandChain]{expandChain()}} 22 | } 23 | -------------------------------------------------------------------------------- /man/knit_print.shinyMetaExpr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.R 3 | \name{knit_print.shinyMetaExpr} 4 | \alias{knit_print.shinyMetaExpr} 5 | \title{Knitr S3 methods} 6 | \usage{ 7 | knit_print.shinyMetaExpr(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{Object to knit_print} 11 | 12 | \item{...}{Additional knit_print arguments} 13 | } 14 | \value{ 15 | The deparsed code expression (as a string). 16 | } 17 | \description{ 18 | This S3 method allows \code{\link[=metaExpr]{metaExpr()}}s to print themselves in 19 | knitr/rmarkdown documents. 20 | } 21 | \keyword{internal} 22 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/metareactive.md: -------------------------------------------------------------------------------- 1 | # doesn't break metaprogramming with quosures 2 | 3 | # A comment in a quosure 4 | local_x 5 | 6 | --- 7 | 8 | { 9 | # A comment in a quosure 10 | local_x 11 | } * -1L 12 | 13 | --- 14 | 15 | result1 <<- { 16 | if ({ 17 | # A comment in a quosure 18 | local_x 19 | } == 123L) { 20 | "ok" 21 | } 22 | } 23 | 24 | # metaAction: unquotes properly 25 | 26 | x <- TRUE 27 | 28 | --- 29 | 30 | mr <- FALSE 31 | y <- mr 32 | 33 | # metaAction: can contain code that uses !! 34 | 35 | foo <- 1 36 | x <- rlang::expr(!!foo) 37 | 38 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/rstudio/shiny-workflows 2 | # 3 | # NOTE: This Shiny team GHA workflow is overkill for most R packages. 4 | # For most R packages it is better to use https://github.com/r-lib/actions 5 | on: 6 | push: 7 | branches: [main, rc-**] 8 | pull_request: 9 | branches: [main] 10 | schedule: 11 | - cron: '0 9 * * 1' # every monday 12 | 13 | name: Package checks 14 | 15 | jobs: 16 | website: 17 | uses: rstudio/shiny-workflows/.github/workflows/website.yaml@v1 18 | with: 19 | check-title: false 20 | routine: 21 | uses: rstudio/shiny-workflows/.github/workflows/routine.yaml@v1 22 | R-CMD-check: 23 | uses: rstudio/shiny-workflows/.github/workflows/R-CMD-check.yaml@v1 24 | -------------------------------------------------------------------------------- /inst/examples/hello-generation/app.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinymeta) 3 | library(dplyr) 4 | 5 | ui <- fluidPage( 6 | selectInput("dataset", "Dataset", c("iris", "pressure")), 7 | numericInput("n", "n", 5), 8 | verbatimTextOutput("code"), 9 | verbatimTextOutput("text"), 10 | plotOutput("plot") 11 | ) 12 | 13 | server <- function(input, output, session) { 14 | df <- metaReactive({ 15 | get(..(input$dataset), "package:datasets") 16 | }) 17 | 18 | filtered <- metaReactive({ 19 | ..(df()) %>% head(..(input$n)) 20 | }) 21 | 22 | output$text <- renderPrint({ 23 | summary(filtered()) 24 | }) 25 | 26 | output$plot <- renderPlot({ 27 | plot(filtered()) 28 | }) 29 | 30 | output$code <- renderPrint({ 31 | expandChain(filtered()) 32 | }) 33 | } 34 | 35 | shinyApp(ui, server) 36 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onLoad <- function(libname, pkgname) { 2 | # Turn on this top secret feature of Shiny! Shhhhh! 3 | options(shiny.allowoutputreads = TRUE) 4 | 5 | registerMethods(list( 6 | # c(package, genname, class) 7 | c("knitr", "knit_print", "shinyMetaExpr") 8 | )) 9 | } 10 | 11 | # https://github.com/rstudio/htmltools/blob/cb452a837/R/tags.R#L22-L57 12 | registerMethods <- function(methods) { 13 | lapply(methods, function(method) { 14 | pkg <- method[[1]] 15 | generic <- method[[2]] 16 | class <- method[[3]] 17 | func <- get(paste(generic, class, sep=".")) 18 | if (pkg %in% loadedNamespaces()) { 19 | registerS3method(generic, class, func, envir = asNamespace(pkg)) 20 | } 21 | setHook( 22 | packageEvent(pkg, "onLoad"), 23 | function(...) { 24 | registerS3method(generic, class, func, envir = asNamespace(pkg)) 25 | } 26 | ) 27 | }) 28 | } 29 | -------------------------------------------------------------------------------- /R/print.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | print.shinyMetaExpr <- function(x, ...) { 3 | print(formatCode(x), ...) 4 | invisible(x) 5 | } 6 | 7 | #' @export 8 | print.shinyMetaDeparsed <- function(x, ...) { 9 | print(formatCode(x), ...) 10 | invisible(x) 11 | } 12 | 13 | #' @export 14 | print.shinyMetaFormatted <- function(x, ...) { 15 | cat(x, sep = "\n") 16 | invisible(x) 17 | } 18 | 19 | #' @export 20 | print.shinyMetaString <- function(x, ...) { 21 | print(deparseCode(x), ...) 22 | } 23 | 24 | #' @export 25 | as.character.shinyMetaExpr <- function(x, ...) { 26 | as.character(deparseCode(x), ...) 27 | } 28 | 29 | #' @export 30 | format.shinyMetaExpr <- function(x, ...) { 31 | format(deparseCode(x), ...) 32 | } 33 | 34 | #' Knitr S3 methods 35 | #' 36 | #' This S3 method allows [metaExpr()]s to print themselves in 37 | #' knitr/rmarkdown documents. 38 | #' 39 | #' @param x Object to knit_print 40 | #' @param ... Additional knit_print arguments 41 | #' @return The deparsed code expression (as a string). 42 | #' @export 43 | #' @keywords internal 44 | knit_print.shinyMetaExpr <- function(x, ...) { 45 | deparseCode(x) 46 | } 47 | -------------------------------------------------------------------------------- /tests/testthat/test-utils.R: -------------------------------------------------------------------------------- 1 | test_that("knit_expand_safe ignores calling environment", { 2 | 3 | foo <- "bar" 4 | expect_error( 5 | knit_expand_safe(text = "{{ foo }}"), 6 | "foo" 7 | ) 8 | expect_identical( 9 | knit_expand_safe(text = "{{ foo }}", vars = list(foo = foo)), 10 | "bar" 11 | ) 12 | 13 | # matches_before is (at the time of this writing) a local variable in the 14 | # knit_expand_safe, which is the parent.frame of knit_expand call. By default, 15 | # knit_expand would be able to "see" that variable; knit_expand_safe is 16 | # supposed to prevent that. 17 | expect_error( 18 | knit_expand_safe(text = "{{ matches_before }}"), 19 | "matches_before" 20 | ) 21 | 22 | expect_identical( 23 | local({ x <- "whatever"; knit_expand_safe(text = "{{ x }}", vars = list(x = x)) }), 24 | "whatever" 25 | ) 26 | 27 | expect_identical( 28 | knit_expand_safe(text = "{{ toupper('hello') }}"), 29 | "HELLO" 30 | ) 31 | 32 | # Use one of knit_expand_safe's parameter names as a var 33 | expect_identical( 34 | knit_expand_safe(text = "{{ text }}", vars = list(text = "something")), 35 | "something" 36 | ) 37 | }) 38 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: https://rstudio.github.io/shinymeta 2 | destination: docs 3 | 4 | toc: 5 | depth: 3 6 | 7 | navbar: 8 | type: default 9 | left: 10 | - text: Code generation 11 | href: articles/code-generation.html 12 | - text: Code distribution 13 | href: articles/code-distribution.html 14 | - text: Special topics 15 | href: articles/special-topics.html 16 | - text: Reference 17 | href: reference/index.html 18 | - text: News 19 | href: news/index.html 20 | 21 | reference: 22 | - title: Meta-reactives 23 | description: | 24 | These functions create meta-reactive(s), for capturing domain logic within a reactive expression 25 | contents: 26 | - metaReactive 27 | - metaObserve 28 | - metaRender 29 | - metaExpr 30 | - metaAction 31 | - withMetaMode 32 | 33 | - title: Code generation 34 | description: | 35 | Functions for generating code from meta-reactives. 36 | contents: 37 | - expandChain 38 | - formatCode 39 | 40 | - title: Code distribution 41 | description: | 42 | Functions for distributing code to users. 43 | contents: 44 | - buildRmdBundle 45 | - buildScriptBundle 46 | - outputCodeButton 47 | - displayCodeModal 48 | -------------------------------------------------------------------------------- /tests/testthat/test-deparsing.R: -------------------------------------------------------------------------------- 1 | describe("deparsing", isolate({ 2 | 3 | it("escapes strings", { 4 | mr <- metaReactive({"foo"}) 5 | out <- withMetaMode(mr()) 6 | expect_equal(as.character(out), "\"foo\"") 7 | expect_equal(format(out), "\"foo\"") 8 | 9 | skip_if_not_installed("knitr") 10 | expect_equal( 11 | knitr::knit_expand(text = "a <- {{out}}", out = out), 12 | "a <- \"foo\"" 13 | ) 14 | }) 15 | 16 | it("deparses code objects", { 17 | mr <- metaReactive({"foo" + 1}) 18 | out <- withMetaMode(mr()) 19 | expect_equal(as.character(out), "\"foo\" + 1") 20 | expect_equal(format(out), "\"foo\" + 1") 21 | 22 | skip_if_not_installed("knitr") 23 | expect_equal( 24 | knitr::knit_expand(text = "a <- {{out}}", out = out), 25 | "a <- \"foo\" + 1" 26 | ) 27 | }) 28 | 29 | it("deparses R objects", { 30 | mr <- metaReactive({list(a = 1)}) 31 | out <- withMetaMode(mr()) 32 | expect_equal(as.character(out), "list(a = 1)") 33 | expect_equal(format(out), "list(a = 1)") 34 | 35 | skip_if_not_installed("knitr") 36 | expect_equal( 37 | knitr::knit_expand(text = "a <- {{out}}", out = out), 38 | "a <- list(a = 1)" 39 | ) 40 | }) 41 | 42 | })) 43 | -------------------------------------------------------------------------------- /tests/testthat/test-metamodes.R: -------------------------------------------------------------------------------- 1 | test_that("state machine is followed", { 2 | # Normal (FALSE) 3 | 4 | expect_identical(metaMode(), FALSE) 5 | 6 | withMetaMode({ 7 | expect_identical(metaMode(), TRUE) 8 | }) 9 | 10 | metaDispatch( 11 | normal = expect_identical(metaMode(), FALSE), 12 | meta = stop("Error in test") 13 | ) 14 | 15 | metaExpr({ 16 | expect_identical(metaMode(), FALSE) 17 | }) 18 | 19 | 20 | # Meta (TRUE) 21 | withMetaMode(mode = TRUE, { 22 | expect_identical(metaMode(), TRUE) 23 | 24 | withMetaMode({ 25 | expect_identical(metaMode(), TRUE) 26 | }) 27 | 28 | metaDispatch( 29 | normal = stop("Error in test"), 30 | meta = expect_identical(metaMode(), "mixed") 31 | ) 32 | 33 | metaExpr({ 34 | expect_identical(metaMode(), TRUE) 35 | }) 36 | }) 37 | 38 | 39 | # Mixed ("mixed") 40 | withMetaMode(mode = TRUE, metaDispatch(normal = stop("Error in test"), meta = { 41 | expect_identical(metaMode(), "mixed") 42 | 43 | withMetaMode({ 44 | expect_identical(metaMode(), TRUE) 45 | }) 46 | 47 | metaDispatch( 48 | normal = expect_identical(metaMode(), FALSE), 49 | meta = stop("Error in test") 50 | ) 51 | 52 | metaExpr({ 53 | expect_identical(metaMode(), TRUE) 54 | }) 55 | })) 56 | }) 57 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/format.md: -------------------------------------------------------------------------------- 1 | # auto-localized expressions: without assignment 2 | 3 | local({ 4 | a <- 1 + 1 5 | if (T) { 6 | return("b") 7 | } 8 | a + 1 9 | }) 10 | 11 | # auto-localized expressions: with assignment 12 | 13 | mr <- local({ 14 | a <- 1 + 1 15 | if (T) { 16 | return("b") 17 | } 18 | a + 1 19 | }) 20 | mr 21 | 22 | # auto-localized expressions: with chaining 23 | 24 | mr <- local({ 25 | a <- 1 + 1 26 | if (T) { 27 | return("b") 28 | } 29 | a + 1 30 | }) 31 | mr2 <- mr + 1 32 | mr2 33 | 34 | # auto-localized expressions: with anonymous functions 35 | 36 | unlist(lapply(1:5, function(x) { 37 | if (x == 2) { 38 | return(x) 39 | } 40 | })) 41 | 42 | # auto-localized expressions: with already localized expression 43 | 44 | local({ 45 | a <- 1 46 | a + 2 47 | }) 48 | 49 | # bindToReturn: single assign works 50 | 51 | a <- 1 + 1 52 | b <- a + 1 53 | mr <- b + 1 54 | 55 | # bindToReturn: double assign works 56 | 57 | a <- 1 + 1 58 | b <- a + 1 59 | mr <- b + 1 60 | a <- 1 + 1 61 | b <- a + 1 62 | mr2 <- b + 1 63 | mrx <- mr + mr2 64 | mrx 65 | 66 | # bindToReturn: doesn't bind on local 67 | 68 | mr <- local({ 69 | a <- 1 + 1 70 | b <- a + 1 71 | b + 1 72 | }) 73 | mr 74 | 75 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: shinymeta 2 | Type: Package 3 | Title: Export Domain Logic from Shiny using Meta-Programming 4 | Version: 0.2.1.9000 5 | Authors@R: c( 6 | person("Joe", "Cheng", email = "joe@rstudio.com", role = "aut"), 7 | person("Carson", "Sievert", email = "carson@rstudio.com", role = c("cre", "aut"), comment = c(ORCID = "0000-0002-4958-2844")), 8 | person(family = "RStudio", role = "cph") 9 | ) 10 | Description: Provides tools for capturing logic in a Shiny app and exposing it as code that can be run outside of Shiny (e.g., from an R console). It also provides tools for bundling both the code and results to the end user. 11 | URL: https://rstudio.github.io/shinymeta/, https://github.com/rstudio/shinymeta 12 | License: GPL-3 13 | Imports: 14 | callr, 15 | fastmap, 16 | fs, 17 | rlang, 18 | htmltools, 19 | shiny (>= 1.6.0), 20 | sourcetools, 21 | styler, 22 | utils 23 | Encoding: UTF-8 24 | RoxygenNote: 7.3.2 25 | Suggests: 26 | knitr, 27 | stringr, 28 | rmarkdown, 29 | testthat (>= 3.0), 30 | shinyAce, 31 | clipr, 32 | dplyr, 33 | ggplot2, 34 | cranlogs, 35 | xfun, 36 | magrittr, 37 | zoo 38 | Roxygen: list(markdown = TRUE) 39 | Config/testthat/edition: 3 40 | Collate: 41 | 'archive.R' 42 | 'display.R' 43 | 'format.R' 44 | 'imports.R' 45 | 'utils.R' 46 | 'metareactive.R' 47 | 'observe.R' 48 | 'globals.R' 49 | 'output-code.R' 50 | 'print.R' 51 | 'render.R' 52 | 'report.R' 53 | 'utils-format.R' 54 | 'zzz.R' 55 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("$",shinymeta_observer) 4 | S3method("[[",shinymeta_observer) 5 | S3method(as.character,shinyMetaExpr) 6 | S3method(format,shinyMetaExpr) 7 | S3method(print,pending_zip_archive) 8 | S3method(print,shinyMetaDeparsed) 9 | S3method(print,shinyMetaExpr) 10 | S3method(print,shinyMetaFormatted) 11 | S3method(print,shinyMetaString) 12 | S3method(print,shinymetaExpansionContext) 13 | S3method(print,shinymeta_reactive) 14 | export(..) 15 | export(buildRmdBundle) 16 | export(buildScriptBundle) 17 | export(deparseCode) 18 | export(displayCodeModal) 19 | export(expandChain) 20 | export(formatCode) 21 | export(knit_print.shinyMetaExpr) 22 | export(metaAction) 23 | export(metaExpr) 24 | export(metaObserve) 25 | export(metaObserve2) 26 | export(metaReactive) 27 | export(metaReactive2) 28 | export(metaRender) 29 | export(metaRender2) 30 | export(newExpansionContext) 31 | export(outputCodeButton) 32 | export(styleText) 33 | export(withMetaMode) 34 | importFrom(rlang,"%||%") 35 | importFrom(rlang,enquo) 36 | importFrom(rlang,expr) 37 | importFrom(rlang,exprs) 38 | importFrom(rlang,is_syntactic_literal) 39 | importFrom(rlang,new_quosure) 40 | importFrom(rlang,quo) 41 | importFrom(rlang,quo_get_expr) 42 | importFrom(shiny,div) 43 | importFrom(shiny,getDefaultReactiveDomain) 44 | importFrom(shiny,isolate) 45 | importFrom(shiny,reactive) 46 | importFrom(shiny,tags) 47 | importFrom(sourcetools,tokenize_string) 48 | importFrom(utils,getFromNamespace) 49 | importFrom(utils,head) 50 | importFrom(utils,zip) 51 | -------------------------------------------------------------------------------- /man/metaExpr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/metareactive.R 3 | \name{metaExpr} 4 | \alias{metaExpr} 5 | \title{Mark an expression as a meta-expression} 6 | \usage{ 7 | metaExpr( 8 | expr, 9 | env = parent.frame(), 10 | quoted = FALSE, 11 | localize = "auto", 12 | bindToReturn = FALSE 13 | ) 14 | } 15 | \arguments{ 16 | \item{expr}{An expression (quoted or unquoted).} 17 | 18 | \item{env}{An environment.} 19 | 20 | \item{quoted}{Is the expression quoted? This is useful when you want to use an expression 21 | that is stored in a variable; to do so, it must be quoted with \code{\link[=quote]{quote()}}.} 22 | 23 | \item{localize}{Whether or not to wrap the returned expression in \code{\link[=local]{local()}}. 24 | The default, \code{"auto"}, only wraps expressions with a top-level \code{\link[=return]{return()}} 25 | statement (i.e., return statements in anonymized functions are ignored).} 26 | 27 | \item{bindToReturn}{For non-\code{localize}d expressions, should an assignment 28 | of a meta expression be applied to the \emph{last child} of the top-level \verb{\\\{} call?} 29 | } 30 | \value{ 31 | If inside meta mode, a quoted form of \code{expr} for use inside of 32 | \code{\link[=metaReactive2]{metaReactive2()}}, \code{\link[=metaObserve2]{metaObserve2()}}, or \code{\link[=metaRender2]{metaRender2()}}. Otherwise, in 33 | normal execution, the result of evaluating \code{expr}. 34 | } 35 | \description{ 36 | Mark an expression as a meta-expression 37 | } 38 | \seealso{ 39 | \code{\link[=metaReactive2]{metaReactive2()}}, \code{\link[=metaObserve2]{metaObserve2()}}, \code{\link[=metaRender2]{metaRender2()}}, \code{\link[=dotdot]{..}} 40 | } 41 | -------------------------------------------------------------------------------- /inst/examples/modules/app.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinymeta) 3 | library(magrittr) 4 | 5 | selectColumnUI <- function(id, label) { 6 | ns <- NS(id) 7 | tagList( 8 | varSelectInput(ns("col"), label, NULL), 9 | textOutput(ns("average")) 10 | ) 11 | } 12 | 13 | selectColumn <- function(input, output, session, df) { 14 | observeEvent(df(), { 15 | updateVarSelectInput(session, "col", data = df()) 16 | }) 17 | 18 | values <- metaReactive2({ 19 | req(input$col) 20 | metaExpr({ 21 | ..(df()) %>% 22 | dplyr::pull(!!..(input$col)) 23 | }) 24 | }) 25 | 26 | avg <- metaReactive({ 27 | ..(values()) %>% 28 | mean() %>% 29 | round(1) 30 | }) 31 | 32 | output$average <- metaRender(renderText, { 33 | paste("Average of", ..(as.character(input$col)), "is", ..(avg())) 34 | }) 35 | 36 | list( 37 | values = values, 38 | average = output$average 39 | ) 40 | } 41 | 42 | ui <- fluidPage( 43 | fluidRow( 44 | column(3, selectColumnUI("x", "x var")), 45 | column(3, selectColumnUI("y", "y var")) 46 | ), 47 | outputCodeButton(plotOutput("plot")) 48 | ) 49 | 50 | server <- function(input, output, session) { 51 | dataset <- metaReactive({mtcars}) 52 | 53 | x <- callModule(selectColumn, "x", dataset) 54 | y <- callModule(selectColumn, "y", dataset) 55 | 56 | df_plot <- metaReactive({ 57 | "# Combine x and y into data frame for plotting" 58 | data.frame(x = ..(x$values()), y = ..(y$values())) 59 | }) 60 | 61 | output$plot <- metaRender(renderPlot, { 62 | plot(..(df_plot())) 63 | }) 64 | 65 | observeEvent(input$plot_output_code, { 66 | displayCodeModal(expandChain( 67 | output$plot(), 68 | x$average(), 69 | y$average() 70 | )) 71 | }) 72 | } 73 | 74 | shinyApp(ui, server) 75 | -------------------------------------------------------------------------------- /tests/testthat/test-observe.R: -------------------------------------------------------------------------------- 1 | describe("metaObserve", isolate({ 2 | it("basically works", { 3 | e1 <- environment() 4 | x <- 0 5 | mo <- metaObserve({ 6 | x <<- 1 7 | }) 8 | mo1 <- metaObserve({ 9 | e2 <- environment() 10 | expect_false(identical(e1, e2)) 11 | }) 12 | shiny:::flushReact() 13 | 14 | expect_identical(x, 1) 15 | expect_equal(unclass(withMetaMode(mo())), quote( x <<- 1 )) 16 | }) 17 | 18 | it("basically works 2", { 19 | e1 <- environment() 20 | x <- 0 21 | mo <- metaObserve2({ 22 | e2 <- environment() 23 | expect_false(identical(e1, e2)) 24 | 25 | x <<- x + 1 26 | metaExpr({ 27 | x <<- ..(x + 1) 28 | }) 29 | }) 30 | shiny:::flushReact() 31 | 32 | expect_identical(x, 2) 33 | 34 | # The value becomes 4 here because even `withMetaMode(mo())` has a side effect 35 | # of x <<- x + 1 (the part outside the metaExpr) 36 | res <- withMetaMode(mo()) 37 | expect_equal(unclass(res), quote( x <<- 4 )) 38 | }) 39 | 40 | it("obeys scoping rules", { 41 | # introduces scopes 42 | outer <- environment() 43 | i <- 0 44 | 45 | mo <- metaObserve({ 46 | inner <- environment() 47 | expect_false(identical(inner, outer)) 48 | 49 | i <<- i + 1 50 | }) 51 | shiny:::flushReact() 52 | 53 | expect_identical(i, 1) 54 | 55 | mo2 <- metaObserve2({ 56 | inner <- environment() 57 | expect_false(identical(inner, outer)) 58 | i <<- i + 1 59 | metaExpr({ 60 | innermost <- environment() 61 | expect_true(identical(innermost, inner)) 62 | i <<- i + 1 63 | }) 64 | }) 65 | shiny:::flushReact() 66 | 67 | expect_identical(i, 3) 68 | 69 | withMetaMode(mo2()) 70 | expect_identical(i, 4) 71 | }) 72 | 73 | })) 74 | -------------------------------------------------------------------------------- /man/buildScriptBundle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/report.R 3 | \name{buildScriptBundle} 4 | \alias{buildScriptBundle} 5 | \alias{buildRmdBundle} 6 | \title{Produce a zip bundle of code and results} 7 | \usage{ 8 | buildScriptBundle( 9 | code = NULL, 10 | output_zip_path, 11 | script_name = "script.R", 12 | include_files = list(), 13 | render = TRUE, 14 | render_args = list() 15 | ) 16 | 17 | buildRmdBundle( 18 | report_template, 19 | output_zip_path, 20 | vars = list(), 21 | include_files = list(), 22 | render = TRUE, 23 | render_args = list() 24 | ) 25 | } 26 | \arguments{ 27 | \item{code}{A language object.} 28 | 29 | \item{output_zip_path}{A filename for the resulting zip bundle.} 30 | 31 | \item{script_name}{A name for the R script in the zip bundle.} 32 | 33 | \item{include_files}{A named list consisting of additional files that should 34 | be included in the zip bundle. The element names indicate the destination 35 | path within the bundle, specified as a relative path; the element values 36 | indicate the path to the actual file currently on disk, specified as either 37 | a relative or absolute path.} 38 | 39 | \item{render}{Whether or not to call \code{\link[rmarkdown:render]{rmarkdown::render()}} on the R script.} 40 | 41 | \item{render_args}{Arguments to provide to \code{\link[rmarkdown:render]{rmarkdown::render()}}.} 42 | 43 | \item{report_template}{Filename of an Rmd template to be expanded by \code{\link[knitr:knit_expand]{knitr::knit_expand()}}.} 44 | 45 | \item{vars}{A named list of variables passed along to \code{...} in \code{\link[knitr:knit_expand]{knitr::knit_expand()}}.} 46 | } 47 | \value{ 48 | The path to a generated file. 49 | } 50 | \description{ 51 | Produce a zip bundle of code and results 52 | } 53 | \seealso{ 54 | knitr::knit_expand 55 | } 56 | -------------------------------------------------------------------------------- /inst/examples/hello-distribution/app.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinymeta) 3 | library(dplyr) 4 | 5 | ui <- fluidPage( 6 | selectInput("dataset", "Dataset", c("iris", "pressure")), 7 | numericInput("n", "n", 5), 8 | downloadButton("download_report", "Download report"), 9 | downloadButton("download_script", "Download script"), 10 | downloadButton("download_script_bundle", "Download script + output"), 11 | verbatimTextOutput("code"), 12 | plotOutput("plot") 13 | ) 14 | 15 | server <- function(input, output, session) { 16 | df <- metaReactive({ 17 | get(..(input$dataset), "package:datasets") 18 | }) 19 | 20 | filtered <- metaReactive({ 21 | ..(df()) %>% head(..(input$n)) 22 | }) 23 | 24 | filtered2 <- metaReactive({ 25 | "# a comment inside metaReactive()" 26 | ..(df()) %>% tail(..(input$n)) 27 | }) 28 | 29 | output$plot <- metaRender(renderPlot, { 30 | "# This is a helpful comment" 31 | plot(..(filtered())) 32 | }) 33 | 34 | obs <- metaObserve({ 35 | "# Print filtered data" 36 | print(..(filtered2())) 37 | }) 38 | 39 | code <- reactive({ 40 | expandChain( 41 | quote(library(magrittr)), 42 | output$plot(), 43 | obs() 44 | ) 45 | }) 46 | 47 | output$code <- renderPrint(code()) 48 | 49 | output$download_report <- downloadHandler("report.zip", 50 | content = function(out) { 51 | buildRmdBundle("report.Rmd", out, vars = list(code = code())) 52 | } 53 | ) 54 | 55 | output$download_script_bundle <- downloadHandler("report.zip", 56 | content = function(out) { 57 | buildScriptBundle(code(), out, render_args = list(output_format = "html_document")) 58 | } 59 | ) 60 | 61 | output$download_script <- downloadHandler("script.R", 62 | content = function(out) { 63 | writeLines(deparseCode(code()), out) 64 | } 65 | ) 66 | } 67 | 68 | shinyApp(ui, server) 69 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # 0.2.1.9000 2 | 3 | 4 | 5 | # 0.2.1 6 | 7 | ## Bug fixes 8 | 9 | * Tweak imports to avoid revdepcheck errors for styler. (#119) 10 | 11 | * Add `"reactive"` class to `metaReactive` objects, so `shiny::is.reactive()` returns `TRUE` for them. (#120) 12 | 13 | # 0.2.0.3 14 | 15 | Small patch release to accommodate for changes made to `base::deparse()` in the next upcoming R release. (#107) 16 | 17 | # 0.2.0.2 18 | 19 | Small patch release to accommodate for changes made in testthat 3.1.0. (#102) 20 | 21 | # 0.2.0.1 22 | 23 | Small patch release to address unit test failures on Solaris. (#101) 24 | 25 | # 0.2.0 26 | 27 | ## Breaking changes 28 | 29 | * A different operator, `..()` (instead of `!!`), is now expanded in meta-mode. In normal execution, this operator is not expanded, and is, instead stripped (i.e., `.,(data())` becomes `data()`). See [this wiki page](https://github.com/rstudio/shinymeta/wiki/Syntax-changes-for-shinymeta-0.2.0) for more information. ([#59](https://github.com/rstudio/shinymeta/pull/59)) 30 | 31 | ## New features 32 | 33 | * New `metaAction` function, intended for executing code for its side effects while also capturing the source for code generation. This is useful for app setup code, such as `library()` calls, `source`-ing of supplemental .R files, loading static data sets, etc. ([#71](https://github.com/rstudio/shinymeta/pull/71)) 34 | 35 | ## Known issues 36 | 37 | * `bquote(splicing = TRUE)` can't be used inside a `metaExpr()` context since the `..()` operator is reserved for `{shinymeta}`'s quasi-quotation rules. Use `{rlang}`'s `!!!` operator for splicing instead of `bquote()`. 38 | 39 | * `metaRender()` will throw a warning about deprecated `env`/`quoted` arguments when `shiny::devmode(TRUE)`. This warning may be safely ignored and will be fixed in a future version. 40 | 41 | # 0.1.0 (unreleased) 42 | 43 | * Initial version, as presented at useR 2019. 44 | -------------------------------------------------------------------------------- /tests/testthat/test-archive.R: -------------------------------------------------------------------------------- 1 | describe("name translation", { 2 | it("strips non-.Rmd extensions", { 3 | test_cases <- list( 4 | "/foo/report.Rmd.in" = "report.Rmd", 5 | "/foo/report.Rmd" = "report.Rmd", 6 | "/foo/report" = "report.Rmd", 7 | "/foo/report.foo.bar.Rmd.in" = "report.foo.bar.Rmd", 8 | "/foo/report.foo.bar.Rmd" = "report.foo.bar.Rmd" 9 | ) 10 | mapply(names(test_cases), test_cases, FUN = function(from, to) { 11 | expect_identical(template_rename(from), to) 12 | }) 13 | }) 14 | 15 | it("strips non-.R extensions", { 16 | test_cases <- list( 17 | "/foo/report.R.in" = "report.R", 18 | "/foo/report.R" = "report.R", 19 | "/foo/report" = "report.R", 20 | "/foo/report.foo.bar.R.in" = "report.foo.bar.R", 21 | "/foo/report.foo.bar.R" = "report.foo.bar.R" 22 | ) 23 | mapply(names(test_cases), test_cases, FUN = function(from, to) { 24 | expect_identical(template_rename(from, "R"), to) 25 | }) 26 | }) 27 | }) 28 | 29 | test_that("zip building", { 30 | tmp <- tempfile(pattern = "dir") 31 | dir.create(file.path(tmp, "foo"), recursive = TRUE) 32 | file1 <- file.path(tmp, "foo", "bar") 33 | file.create(file1) 34 | 35 | za <- zip_archive() 36 | 37 | # Copy file where dest doesn't have trailing slash 38 | add_items(za, baz = file1) 39 | expect_equal(list_items(za), fs::path(c("baz"))) 40 | 41 | # Copy file where dest has trailing slash 42 | add_item(za, file1, "qux/") 43 | expect_equal(list_items(za), fs::path(c("baz", "qux", "qux/bar"))) 44 | 45 | # Copy dir where dest doesn't have trailing slash 46 | lst <- setNames(fs::path_dir(file1), list("quuz")) 47 | add_items(za, !!!lst) 48 | expect_equal(list_items(za), fs::path(c("baz", "quuz", "quuz/bar", "qux", "qux/bar"))) 49 | 50 | # Copy dir where dest does have trailing slash (no difference) 51 | lst2 <- setNames(fs::path_dir(file1), list("corge/")) 52 | add_items(za, !!!lst2) 53 | expect_equal(list_items(za), fs::path(c("baz", "corge", "corge/bar", "quuz", "quuz/bar", "qux", "qux/bar"))) 54 | }) 55 | -------------------------------------------------------------------------------- /man/metaAction.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/metareactive.R 3 | \name{metaAction} 4 | \alias{metaAction} 5 | \title{Run/capture non-reactive code for side effects} 6 | \usage{ 7 | metaAction(expr, env = parent.frame(), quoted = FALSE) 8 | } 9 | \arguments{ 10 | \item{expr}{A code expression that will immediately be executed (before the 11 | call to \code{metaAction} returns), and also stored for later retrieval (i.e. 12 | meta mode).} 13 | 14 | \item{env}{An environment.} 15 | 16 | \item{quoted}{Is the expression quoted? This is useful when you want to use an expression 17 | that is stored in a variable; to do so, it must be quoted with \code{\link[=quote]{quote()}}.} 18 | } 19 | \value{ 20 | A function that, when called in meta mode (i.e. inside 21 | \code{\link[=expandChain]{expandChain()}}), will return the code in quoted form. If this function is 22 | ever called outside of meta mode, it throws an error, as it is definitely 23 | being called incorrectly. 24 | } 25 | \description{ 26 | Most apps start out with setup code that is non-reactive, such as 27 | \code{\link[base:library]{library()}} calls, loading of static data into local 28 | variables, or \code{\link[base:source]{source}}-ing of supplemental R scripts. 29 | \code{metaAction} provides a convenient way to run such code for its side effects 30 | (including declaring new variables) while making it easy to export that code 31 | using \code{\link[=expandChain]{expandChain()}}. Note that \code{metaAction} executes code directly in the 32 | \code{env} environment (which defaults to the caller's environment), so any local 33 | variables that are declared in the \code{expr} will be available outside of 34 | \code{metaAction} as well. 35 | } 36 | \examples{ 37 | 38 | setup <- metaAction({ 39 | library(stats) 40 | 41 | "# Set the seed to ensure repeatable randomness" 42 | set.seed(100) 43 | 44 | x <- 1 45 | y <- 2 46 | }) 47 | 48 | # The action has executed 49 | print(x) 50 | print(y) 51 | 52 | # And also you can emit the code 53 | expandChain( 54 | setup() 55 | ) 56 | 57 | } 58 | -------------------------------------------------------------------------------- /man/outputCodeButton.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/output-code.R 3 | \name{outputCodeButton} 4 | \alias{outputCodeButton} 5 | \title{Overlay an icon on a shiny output} 6 | \usage{ 7 | outputCodeButton( 8 | outputObj, 9 | label = "Show code", 10 | icon = shiny::icon("code"), 11 | width = NULL, 12 | ... 13 | ) 14 | } 15 | \arguments{ 16 | \item{outputObj}{A shiny output container (e.g., \link[shiny:plotOutput]{shiny::plotOutput}, \link[shiny:textOutput]{shiny::textOutput}, etc)} 17 | 18 | \item{label}{The contents of the button or link--usually a text label, but 19 | you could also use any other HTML, like an image.} 20 | 21 | \item{icon}{An optional \code{\link[shiny:icon]{icon()}} to appear on the button.} 22 | 23 | \item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'}; 24 | see \code{\link[shiny:validateCssUnit]{validateCssUnit()}}.} 25 | 26 | \item{...}{Named attributes to be applied to the button or link.} 27 | } 28 | \value{ 29 | the \code{outputObj} wrapped in a card-like HTML container. 30 | } 31 | \description{ 32 | Intended for overlaying a button over a shiny output, that when clicked, 33 | displays code for reproducing that output. The button is 34 | similar to an \code{\link[shiny:actionButton]{shiny::actionButton()}}, but instead of providing an \code{inputId}, 35 | the id is determined by the id of the \code{outputObj}. The name 36 | of that input is a function of \code{outputObj}'s \code{outputId}: 37 | \code{input$OUTPUTID_output_code}. 38 | } 39 | \examples{ 40 | 41 | if (interactive()) { 42 | library(shiny) 43 | ui <- fluidPage( 44 | sliderInput("n", label = "Number of samples", min = 10, max = 100, value = 30), 45 | outputCodeButton(plotOutput("p")) 46 | ) 47 | server <- function(input, output) { 48 | output$p <- metaRender(renderPlot, { 49 | plot(sample(..(input$n))) 50 | }) 51 | observeEvent(input$p_output_code, { 52 | code <- expandChain(output$p()) 53 | displayCodeModal(code) 54 | }) 55 | } 56 | shinyApp(ui, server) 57 | } 58 | 59 | } 60 | \seealso{ 61 | \link{displayCodeModal} 62 | } 63 | -------------------------------------------------------------------------------- /man/formatCode.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/format.R 3 | \name{formatCode} 4 | \alias{formatCode} 5 | \alias{styleText} 6 | \alias{deparseCode} 7 | \title{Deparse and format shinymeta expressions} 8 | \usage{ 9 | formatCode(code, width = 500L, formatter = styleText, ...) 10 | 11 | styleText(code, ...) 12 | 13 | deparseCode(code, width = 500L) 14 | } 15 | \arguments{ 16 | \item{code}{Either an unevaluated expression or a deparsed code string.} 17 | 18 | \item{width}{The \code{width.cutoff} to use when \code{\link[=deparse]{deparse()}}-ing the \code{code} expression.} 19 | 20 | \item{formatter}{a function that accepts deparsed code (a character string) 21 | as the first argument.} 22 | 23 | \item{...}{arguments passed along to the \code{formatter} function.} 24 | } 25 | \value{ 26 | Single-element character vector with formatted code 27 | } 28 | \description{ 29 | Turn unevaluated shinymeta expressions into (formatted or styled) text. 30 | } 31 | \details{ 32 | Before any formatting takes place, the unevaluated expression is 33 | deparsed into a string via \code{\link[=deparseCode]{deparseCode()}}, which ensures that 34 | shinymeta comment strings (i.e., literal strings that appear on their own line, 35 | and begin with one or more \verb{#} characters.) are turned into comments and 36 | superfluous \verb{\\\{} are removed. After deparsing, the \code{formatCode()} function then 37 | calls the \code{formatter} function on the deparsed string to format (aka style) the code string. 38 | The default \code{formatter}, \code{styleText()}, uses \code{\link[styler:style_text]{styler::style_text()}} with a couple differences: 39 | \itemize{ 40 | \item Pipe operators (\verb{\%>\%}) are \emph{always} followed by a line break. 41 | \item If the token appearing after a line-break is a comma/operator, the line-break is removed. 42 | } 43 | } 44 | \examples{ 45 | 46 | options(shiny.suppressMissingContextError = TRUE) 47 | 48 | x <- metaReactive({ 49 | "# Here's a comment" 50 | sample(5) \%>\% sum() 51 | }) 52 | 53 | code <- expandChain(x()) 54 | 55 | deparseCode(code) 56 | formatCode(code) 57 | formatCode(code, formatter = styler::style_text) 58 | } 59 | -------------------------------------------------------------------------------- /tests/testthat/test-format.R: -------------------------------------------------------------------------------- 1 | describe( 2 | "auto-localized expressions", isolate({ 3 | 4 | mr <- metaReactive({ 5 | a <- 1 + 1 6 | if (T) return("b") 7 | a + 1 8 | }) 9 | 10 | it("without assignment", { 11 | expect_snapshot_output(cran = TRUE, withMetaMode(mr())) 12 | }) 13 | 14 | it("with assignment", { 15 | expect_snapshot_output(cran = TRUE, expandChain(mr())) 16 | }) 17 | 18 | it("with chaining", { 19 | mr2 <- metaReactive({ 20 | ..(mr()) + 1 21 | }) 22 | 23 | expect_snapshot_output(cran = TRUE, expandChain(mr2())) 24 | }) 25 | 26 | it("with anonymous functions", { 27 | mrx <- metaReactive({ 28 | unlist(lapply(1:5, function(x) { if (x == 2) return(x) })) 29 | }) 30 | 31 | expect_snapshot_output(cran = TRUE, withMetaMode(mrx())) 32 | }) 33 | 34 | it("with already localized expression", { 35 | mrl <- metaReactive({ 36 | local({ 37 | a <- 1 38 | a + 2 39 | }) 40 | }) 41 | 42 | expect_snapshot_output(cran = TRUE, withMetaMode(mrl())) 43 | }) 44 | 45 | }) 46 | 47 | ) 48 | 49 | 50 | 51 | describe( 52 | "bindToReturn", isolate({ 53 | 54 | mr <- metaReactive(bindToReturn = TRUE, { 55 | a <- 1 + 1 56 | b <- a + 1 57 | b + 1 58 | }) 59 | 60 | it("single assign works", { 61 | 62 | expect_snapshot_output(cran = TRUE, expandChain(invisible(mr()))) 63 | }) 64 | 65 | it("double assign works", { 66 | 67 | mr2 <- metaReactive({ 68 | a <- 1 + 1 69 | b <- a + 1 70 | b + 1 71 | }, bindToReturn = TRUE) 72 | 73 | mrx <- metaReactive({ 74 | ..(mr()) + ..(mr2()) 75 | }) 76 | 77 | expect_snapshot_output(cran = TRUE, expandChain(mrx())) 78 | }) 79 | 80 | it("doesn't bind on local", { 81 | 82 | # TODO: maybe this should throw a warning? 83 | mr <- metaReactive({ 84 | a <- 1 + 1 85 | b <- a + 1 86 | b + 1 87 | }, local = TRUE, bindToReturn = TRUE) 88 | 89 | expect_snapshot_output(cran = TRUE, expandChain(mr())) 90 | 91 | }) 92 | 93 | 94 | }) 95 | 96 | ) 97 | -------------------------------------------------------------------------------- /R/output-code.R: -------------------------------------------------------------------------------- 1 | #' Overlay an icon on a shiny output 2 | #' 3 | #' Intended for overlaying a button over a shiny output, that when clicked, 4 | #' displays code for reproducing that output. The button is 5 | #' similar to an [shiny::actionButton()], but instead of providing an `inputId`, 6 | #' the id is determined by the id of the `outputObj`. The name 7 | #' of that input is a function of `outputObj`'s `outputId`: 8 | #' `input$OUTPUTID_output_code`. 9 | #' 10 | #' @param outputObj A shiny output container (e.g., [shiny::plotOutput], [shiny::textOutput], etc) 11 | #' @inheritParams shiny::actionButton 12 | #' @return the `outputObj` wrapped in a card-like HTML container. 13 | #' @export 14 | #' @seealso [displayCodeModal] 15 | #' @examples 16 | #' 17 | #' if (interactive()) { 18 | #' library(shiny) 19 | #' ui <- fluidPage( 20 | #' sliderInput("n", label = "Number of samples", min = 10, max = 100, value = 30), 21 | #' outputCodeButton(plotOutput("p")) 22 | #' ) 23 | #' server <- function(input, output) { 24 | #' output$p <- metaRender(renderPlot, { 25 | #' plot(sample(..(input$n))) 26 | #' }) 27 | #' observeEvent(input$p_output_code, { 28 | #' code <- expandChain(output$p()) 29 | #' displayCodeModal(code) 30 | #' }) 31 | #' } 32 | #' shinyApp(ui, server) 33 | #' } 34 | #' 35 | outputCodeButton <- function(outputObj, label = "Show code", icon = shiny::icon("code"), width = NULL, ...) { 36 | 37 | if (!inherits(outputObj, c("shiny.tag", "shiny.tag.list"))) { 38 | stop("outputObj must be a shiny.tag or shiny.tag.list object") 39 | } 40 | 41 | div( 42 | class = "shinymeta-output-code panel panel-default card", 43 | htmltools::htmlDependency( 44 | name = "shinymeta-output-code", 45 | version = utils::packageVersion("shinymeta"), 46 | src = "lib/output-code", 47 | package = "shinymeta", 48 | script = "output-code.js" 49 | ), 50 | div( 51 | class = "panel-heading card-header", 52 | # Basically the same as a actionButton(), but there doesn't seem to 53 | # be a foolproof way to get the outputId given the outputObj, so 54 | # we won't know the id of this button ahead of time 55 | tags$button( 56 | style = if (!is.null(width)) paste0("width: ", shiny::validateCssUnit(width), ";"), 57 | type = "button", 58 | class = "btn btn-default", 59 | list(icon, label), 60 | ... 61 | ) 62 | ), 63 | div( 64 | class = "panel-body card-body", 65 | outputObj 66 | ) 67 | ) 68 | } 69 | -------------------------------------------------------------------------------- /tests/testthat/test-report.R: -------------------------------------------------------------------------------- 1 | template_path <- test_path("assets/template.Rmd") 2 | 3 | test_that("buildRmdBundle works", { 4 | skip_if_not( 5 | rmarkdown::pandoc_available("1.12.3"), 6 | "Pandoc 1.12.3 or higher is required" 7 | ) 8 | 9 | output_zip_path <- tempfile("testbundle-", fileext = ".zip") 10 | 11 | buildRmdBundle(template_path, output_zip_path, vars = list( 12 | desc = "# Weekly report\n\nLooks like `cars` hasn't changed since last week.", 13 | code_chunk = metaExpr(quote({plot(cars)})), 14 | code_inline = metaExpr(quote(1 + 1)), 15 | x = 1, y = 2 16 | )) 17 | 18 | working_dir <- tempfile() 19 | dir.create(working_dir) 20 | on.exit(unlink(working_dir, recursive = TRUE)) 21 | 22 | unzip(output_zip_path, exdir = working_dir) 23 | expect_true(file.exists(file.path(working_dir, "template.html"))) 24 | 25 | expect_snapshot_file(file.path(working_dir, "template.Rmd"), compare = compare_file_text) 26 | }) 27 | 28 | test_that("buildRmdBundle rejects unsafe knit_expand results", { 29 | output_zip_path <- tempfile("testbundle-", fileext = ".zip") 30 | 31 | # (Begin code chunk) fails 32 | expect_error( 33 | buildRmdBundle(template_path, output_zip_path, vars = list( 34 | desc = "# Weekly report\n\nLooks like `cars` hasn't changed since last week.\n```{r}\nmessage('owned')\n```\n", 35 | code_chunk = metaExpr(quote({plot(cars)})), 36 | code_inline = metaExpr(quote(1 + 1)), 37 | x = 1, y = 2 38 | )) 39 | ) 40 | 41 | # (End code chunk) fails 42 | expect_error( 43 | buildRmdBundle(template_path, output_zip_path, vars = list( 44 | desc = "# Weekly report\n\nLooks like `cars` hasn't changed since last week.\n```\n", 45 | code_chunk = metaExpr(quote({plot(cars)})), 46 | code_inline = metaExpr(quote(1 + 1)), 47 | x = 1, y = 2 48 | )) 49 | ) 50 | 51 | # (Inline code) fails 52 | expect_error( 53 | buildRmdBundle(template_path, output_zip_path, vars = list( 54 | desc = "# Weekly report\n\nLooks like `cars` hasn't changed since last week.\n`r message('owned')`\n", 55 | code_chunk = metaExpr(quote({plot(cars)})), 56 | code_inline = metaExpr(quote(1 + 1)), 57 | x = 1, y = 2 58 | )) 59 | ) 60 | 61 | # Begin/end of inline.code are in two different spots - fails 62 | expect_error( 63 | buildRmdBundle(template_path, output_zip_path, vars = list( 64 | desc = "# Weekly report\n\nLooks like `cars` hasn't changed since last week.\n", 65 | code_chunk = metaExpr(quote({plot(cars)})), 66 | code_inline = metaExpr(quote(1 + 1)), 67 | x = "`r message('owned') #", y = "`" 68 | )) 69 | ) 70 | }) 71 | -------------------------------------------------------------------------------- /man/displayCodeModal.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/display.R 3 | \name{displayCodeModal} 4 | \alias{displayCodeModal} 5 | \title{Display a shinyAce code editor via shiny modal} 6 | \usage{ 7 | displayCodeModal( 8 | code, 9 | title = NULL, 10 | clip = "clipboard", 11 | footer = shiny::modalButton("Dismiss"), 12 | size = c("m", "s", "l"), 13 | easyClose = TRUE, 14 | fade = TRUE, 15 | session = shiny::getDefaultReactiveDomain(), 16 | ... 17 | ) 18 | } 19 | \arguments{ 20 | \item{code}{Either a language object or a character string.} 21 | 22 | \item{title}{An optional title for the dialog.} 23 | 24 | \item{clip}{An \code{\link[shiny:icon]{shiny::icon()}} \code{name} that a user can press to copy \code{code} to 25 | the clipboard. If you wish to not have an icon, specify \code{clip = NULL}.} 26 | 27 | \item{footer}{UI for footer. Use \code{NULL} for no footer.} 28 | 29 | \item{size}{One of \code{"s"} for small, \code{"m"} (the default) for medium, 30 | \code{"l"} for large, or \code{"xl"} for extra large. Note that \code{"xl"} only 31 | works with Bootstrap 4 and above (to opt-in to Bootstrap 4+, 32 | pass \code{\link[bslib:bs_theme]{bslib::bs_theme()}} to the \code{theme} argument of a page container 33 | like \code{\link[shiny:fluidPage]{fluidPage()}}).} 34 | 35 | \item{easyClose}{If \code{TRUE}, the modal dialog can be dismissed by 36 | clicking outside the dialog box, or be pressing the Escape key. If 37 | \code{FALSE} (the default), the modal dialog can't be dismissed in those 38 | ways; instead it must be dismissed by clicking on a \code{modalButton()}, or 39 | from a call to \code{\link[shiny:removeModal]{removeModal()}} on the server.} 40 | 41 | \item{fade}{If \code{FALSE}, the modal dialog will have no fade-in animation 42 | (it will simply appear rather than fade in to view).} 43 | 44 | \item{session}{a shiny session object (the default should almost always be used).} 45 | 46 | \item{...}{arguments passed along to \code{shinyAce::aceEditor()}} 47 | } 48 | \value{ 49 | nothing. Call this function for its side effects. 50 | } 51 | \description{ 52 | Show a \code{shinyAce::aceEditor()} in a \code{shiny::modalDialog()}. 53 | } 54 | \examples{ 55 | 56 | if (interactive()) { 57 | library(shiny) 58 | ui <- fluidPage( 59 | sliderInput("n", label = "Number of samples", min = 10, max = 100, value = 30), 60 | actionButton("code", icon("code")), 61 | plotOutput("p") 62 | ) 63 | server <- function(input, output) { 64 | output$p <- metaRender(renderPlot, { 65 | plot(sample(..(input$n))) 66 | }) 67 | observeEvent(input$code, { 68 | code <- expandChain(output$p()) 69 | displayCodeModal(code) 70 | }) 71 | } 72 | shinyApp(ui, server) 73 | } 74 | 75 | } 76 | \seealso{ 77 | \link{outputCodeButton} 78 | } 79 | -------------------------------------------------------------------------------- /R/display.R: -------------------------------------------------------------------------------- 1 | #' Display a shinyAce code editor via shiny modal 2 | #' 3 | #' Show a `shinyAce::aceEditor()` in a `shiny::modalDialog()`. 4 | #' 5 | #' @param code Either a language object or a character string. 6 | #' @param clip An [shiny::icon()] `name` that a user can press to copy `code` to 7 | #' the clipboard. If you wish to not have an icon, specify `clip = NULL`. 8 | #' @param session a shiny session object (the default should almost always be used). 9 | #' @inheritParams shiny::modalDialog 10 | #' @param ... arguments passed along to `shinyAce::aceEditor()` 11 | #' @return nothing. Call this function for its side effects. 12 | #' @export 13 | #' @seealso [outputCodeButton] 14 | #' @examples 15 | #' 16 | #' if (interactive()) { 17 | #' library(shiny) 18 | #' ui <- fluidPage( 19 | #' sliderInput("n", label = "Number of samples", min = 10, max = 100, value = 30), 20 | #' actionButton("code", icon("code")), 21 | #' plotOutput("p") 22 | #' ) 23 | #' server <- function(input, output) { 24 | #' output$p <- metaRender(renderPlot, { 25 | #' plot(sample(..(input$n))) 26 | #' }) 27 | #' observeEvent(input$code, { 28 | #' code <- expandChain(output$p()) 29 | #' displayCodeModal(code) 30 | #' }) 31 | #' } 32 | #' shinyApp(ui, server) 33 | #' } 34 | #' 35 | displayCodeModal <- function(code, title = NULL, clip = "clipboard", 36 | footer = shiny::modalButton("Dismiss"), size = c("m", "s", "l"), 37 | easyClose = TRUE, fade = TRUE, 38 | session = shiny::getDefaultReactiveDomain(), ...) { 39 | 40 | if (system.file(package = "shinyAce") == "") { 41 | stop("Please install.packages('shinyAce') and try again.") 42 | } 43 | 44 | if (length(clip) && system.file(package = "clipr") == "") { 45 | stop("Please install.packages('clipr') and try again.") 46 | } 47 | 48 | if (is.language(code)) { 49 | code <- formatCode(code) 50 | } 51 | 52 | if (!is.character(code)) { 53 | stop("code must be either a language object or a character string") 54 | } 55 | 56 | id <- getFromNamespace("createUniqueId", "shiny")(10) 57 | 58 | shiny::observeEvent(session$rootScope()$input[[paste0(id, "-copy")]], { 59 | clipr::write_clip(code) 60 | }) 61 | 62 | shiny::showModal( 63 | shiny::modalDialog( 64 | title = title, 65 | size = match.arg(size, size), 66 | easyClose = easyClose, 67 | fade = fade, 68 | shinyAce::aceEditor( 69 | outputId = paste0(id, "-editor"), 70 | value = paste(code, collapse = "\n"), 71 | mode = "r", 72 | readOnly = TRUE, 73 | ... 74 | ), 75 | footer = shiny::tagList( 76 | if (length(clip)) shiny::actionButton(paste0(id, "-copy"), shiny::icon(clip)), 77 | footer 78 | ) 79 | ) 80 | ) 81 | } 82 | -------------------------------------------------------------------------------- /tests/testthat/test-expandchain.R: -------------------------------------------------------------------------------- 1 | mr1 <- metaReactive({ 2 | 1 3 | }) 4 | 5 | mr2 <- metaReactive( 6 | {..(mr1()) + 2} 7 | ) 8 | 9 | # Can't infer varname, but inlined 10 | metaReactive({ 11 | 3 12 | }, inline = TRUE) -> mr3 13 | 14 | # Can't infer varname, explicitly provided 15 | metaReactive({ 16 | 4 17 | }, varname = "mrFour") -> mr4 18 | 19 | o <- metaObserve({ 20 | ..(mr2()) + ..(mr3()) + ..(mr4()) 21 | }) 22 | 23 | describe("expandChain", { 24 | it("basically works", { 25 | x <- capture.output(print(expandChain(mr2()))) 26 | expect_identical(x, c("mr1 <- 1", "mr2 <- mr1 + 2", "mr2")) 27 | 28 | x <- capture.output(print(expandChain( 29 | "# A comment", 30 | o() 31 | ))) 32 | expect_identical(x, c( 33 | "# A comment", 34 | "mr1 <- 1", 35 | "mr2 <- mr1 + 2", 36 | "mrFour <- 4", 37 | "mr2 + 3 + mrFour" 38 | )) 39 | }) 40 | 41 | it("can emit metaReactive invisibly", { 42 | x <- capture.output(print(expandChain( 43 | quote(library(ggplot2)), 44 | # NULL should be ignored 45 | NULL, 46 | # Use invisible() to cause mr2 to be defined, but not printed 47 | invisible(mr2()) 48 | ))) 49 | expect_identical(x, c( 50 | "library(ggplot2)", 51 | "mr1 <- 1", 52 | "mr2 <- mr1 + 2" 53 | )) 54 | }) 55 | 56 | it("rejects bad arguments", { 57 | expect_error(expandChain(1)) 58 | expect_error(expandChain(quote(1))) 59 | expect_error(expandChain("hi")) 60 | expect_error(expandChain(list())) 61 | expect_error(expandChain(mr)) # missing () 62 | expect_error(expandChain(cars)) 63 | expect_error(expandChain(a = NULL), "Named") 64 | }) 65 | }) 66 | 67 | describe("expansion context", { 68 | it("basically works", { 69 | ec <- newExpansionContext() 70 | 71 | x <- capture.output(print(expandChain(.expansionContext = ec, 72 | invisible(mr2()) 73 | ))) 74 | expect_identical(x, c("mr1 <- 1", "mr2 <- mr1 + 2")) 75 | 76 | x <- capture.output(print(expandChain(.expansionContext = ec, 77 | o() 78 | ))) 79 | expect_identical(x, c("mrFour <- 4", "mr2 + 3 + mrFour")) 80 | }) 81 | 82 | it("can substitute", { 83 | ec <- newExpansionContext() 84 | ec$substituteMetaReactive(mr2, function() { 85 | metaExpr({ 86 | "# Add one hundred and two hundred" 87 | 100 + 200 88 | }) 89 | }) 90 | ec$substituteMetaReactive(mr3, function() { 91 | metaExpr({(1000 + 2000)}) 92 | }) 93 | 94 | x <- capture.output(print(expandChain(.expansionContext = ec, 95 | o() 96 | ))) 97 | expect_identical(x, c( 98 | "# Add one hundred and two hundred", 99 | "mr2 <- 100 + 200", 100 | "mrFour <- 4", 101 | "mr2 + (1000 + 2000) + mrFour" 102 | )) 103 | }) 104 | }) 105 | -------------------------------------------------------------------------------- /inst/examples/interactive-lm/app.R: -------------------------------------------------------------------------------- 1 | # App derived from https://gist.github.com/wch/c4b857d73493e6550cba 2 | library(shiny) 3 | library(shinymeta) 4 | library(shinyAce) 5 | library(dplyr) 6 | library(ggplot2) 7 | 8 | # Define the data dataset of interest 9 | data <- mtcars 10 | 11 | # User interface 12 | ui <- fluidPage( 13 | sidebarLayout( 14 | sidebarPanel( 15 | varSelectInput("yvar", "Select y", data), 16 | varSelectInput("xvar", "Select x", data), 17 | selectInput("degree", "Polynomial degree", c(1, 2, 3, 4)) 18 | ), 19 | mainPanel( 20 | outputCodeButton(plotOutput("plot", click = "plot_click")) 21 | ) 22 | ) 23 | ) 24 | 25 | # This column will track which rows have been excluded 26 | data <- tibble::rownames_to_column(data, var = ".row_ids") 27 | 28 | server <- function(input, output) { 29 | # For storing which row ids have been excluded 30 | outliers <- reactiveVal(NULL) 31 | 32 | # Toggle points that are clicked 33 | observeEvent(input$plot_click, { 34 | # TODO: handle more than one pt at a time 35 | row_id <- nearPoints(data, input$plot_click)$.row_ids[1] 36 | if (!length(row_id)) return() 37 | 38 | # If this point is already an outlier, then 39 | # it's not longer considered an outlier. 40 | if (row_id %in% outliers()) { 41 | outliers(setdiff(outliers(), row_id)) 42 | } else { 43 | outliers(c(row_id, outliers())) 44 | } 45 | }) 46 | 47 | data_discard <- metaReactive({ 48 | filter(data, .row_ids %in% ..(outliers())) 49 | }) 50 | 51 | data_kept <- metaReactive({ 52 | filter(data, !.row_ids %in% ..(outliers())) 53 | }) 54 | 55 | model_fit <- metaReactive2({ 56 | req(input$degree) 57 | 58 | # just say no to as.formula 59 | form <- substitute( 60 | y ~ poly(x, degree = degree), 61 | list( 62 | y = input$yvar, 63 | x = input$xvar, 64 | degree = as.numeric(input$degree) 65 | ) 66 | ) 67 | 68 | metaExpr( 69 | lm(..(form), data = ..(data_kept())) 70 | ) 71 | }) 72 | 73 | data_fitted <- metaReactive({ 74 | modelr::add_predictions(..(data_kept()), ..(model_fit())) 75 | }) 76 | 77 | output$plot <- metaRender(renderPlot, { 78 | ggplot(..(data_kept()), aes(x = !!..(input$xvar), y = !!..(input$yvar))) + 79 | geom_point() + 80 | geom_line(data = ..(data_fitted()), aes(y = pred), color = "gray50") + 81 | geom_point(data = ..(data_discard()), fill = NA, color = "black", alpha = 0.25) + 82 | theme_bw(base_size = 14) 83 | }) 84 | 85 | observeEvent(input$plot_output_code, { 86 | code <- expandChain( 87 | quote({ 88 | library(ggplot2) 89 | library(dplyr) 90 | library(modelr) 91 | data <- mtcars 92 | data <- tibble::rownames_to_column(data, var = ".row_ids") 93 | }), 94 | output$plot() 95 | ) 96 | 97 | displayCodeModal( 98 | code = code, 99 | title = "Code to reproduce data and plot" 100 | ) 101 | }) 102 | } 103 | 104 | shinyApp(ui, server) 105 | -------------------------------------------------------------------------------- /man/metaObserve.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/observe.R 3 | \name{metaObserve} 4 | \alias{metaObserve} 5 | \alias{metaObserve2} 6 | \title{Create a meta-reactive observer} 7 | \usage{ 8 | metaObserve( 9 | expr, 10 | env = parent.frame(), 11 | quoted = FALSE, 12 | label = NULL, 13 | domain = getDefaultReactiveDomain(), 14 | localize = "auto", 15 | bindToReturn = FALSE 16 | ) 17 | 18 | metaObserve2( 19 | expr, 20 | env = parent.frame(), 21 | quoted = FALSE, 22 | label = NULL, 23 | domain = getDefaultReactiveDomain() 24 | ) 25 | } 26 | \arguments{ 27 | \item{expr}{An expression (quoted or unquoted).} 28 | 29 | \item{env}{The parent environment for the reactive expression. By default, 30 | this is the calling environment, the same as when defining an ordinary 31 | non-reactive expression. If \code{x} is a quosure and \code{quoted} is \code{TRUE}, 32 | then \code{env} is ignored.} 33 | 34 | \item{quoted}{If it is \code{TRUE}, then the \code{\link[=quote]{quote()}}ed value of \code{x} 35 | will be used when \code{x} is evaluated. If \code{x} is a quosure and you 36 | would like to use its expression as a value for \code{x}, then you must set 37 | \code{quoted} to \code{TRUE}.} 38 | 39 | \item{label}{A label for the observer, useful for debugging.} 40 | 41 | \item{domain}{See \link[shiny]{domains}.} 42 | 43 | \item{localize}{Whether or not to wrap the returned expression in \code{\link[=local]{local()}}. 44 | The default, \code{"auto"}, only wraps expressions with a top-level \code{\link[=return]{return()}} 45 | statement (i.e., return statements in anonymized functions are ignored).} 46 | 47 | \item{bindToReturn}{For non-\code{localize}d expressions, should an assignment 48 | of a meta expression be applied to the \emph{last child} of the top-level \verb{\\\{} call?} 49 | } 50 | \value{ 51 | A function that, when called in meta mode (i.e. inside 52 | \code{\link[=expandChain]{expandChain()}}), will return the code in quoted form. If this function is 53 | ever called outside of meta mode, it throws an error, as it is definitely 54 | being called incorrectly. 55 | } 56 | \description{ 57 | Create a \code{\link[shiny:observe]{shiny::observe()}}r that, when invoked with meta-mode activated 58 | (i.e. called within \code{\link[=withMetaMode]{withMetaMode()}} or \code{\link[=expandChain]{expandChain()}}), returns a partially 59 | evaluated code expression. Outside of meta-mode, \code{metaObserve()} is 60 | equivalent to \code{observe()} (it fully evaluates the given expression). 61 | } 62 | \details{ 63 | If you wish to capture specific code inside of \code{expr} (e.g. ignore 64 | code that has no meaning outside shiny, like \code{\link[shiny:req]{shiny::req()}}), use 65 | \code{metaObserve2()} in combination with \code{metaExpr()}. When using 66 | \code{metaObserve2()}, \code{expr} must return a \code{metaExpr()}. 67 | } 68 | \examples{ 69 | 70 | # observers execute 'immediately' 71 | x <- 1 72 | mo <- metaObserve({ 73 | x <<- x + 1 74 | }) 75 | getFromNamespace("flushReact", "shiny")() 76 | print(x) 77 | 78 | # It only makes sense to invoke an meta-observer 79 | # if we're in meta-mode (i.e., generating code) 80 | expandChain(mo()) 81 | 82 | # Intentionally produces an error 83 | \dontrun{mo()} 84 | 85 | } 86 | \seealso{ 87 | \code{\link[=metaExpr]{metaExpr()}}, \code{\link[=dotdot]{..}} 88 | } 89 | -------------------------------------------------------------------------------- /tests/testthat/test-metareactive.R: -------------------------------------------------------------------------------- 1 | test_that("doesn't break metaprogramming with quosures", { 2 | isolate({ 3 | 4 | my_quo <- local({ 5 | local_x <- 123L 6 | rlang::quo({ 7 | "# A comment in a quosure" 8 | local_x 9 | }) 10 | }) 11 | 12 | outer_quo <- rlang::quo({ 13 | if (!!my_quo == 123L) { 14 | "ok" 15 | } 16 | }) 17 | 18 | # Reactive expressions 19 | 20 | r1 <- rlang::inject(metaReactive(!!my_quo, varname = "r1")) 21 | r2 <- rlang::inject(metaReactive(!!my_quo * -1L, varname = "r2")) 22 | 23 | expect_identical(r1(), 123L) 24 | expect_identical(r2(), -123L) 25 | 26 | expect_snapshot_output(withMetaMode(r1())) 27 | expect_snapshot_output(withMetaMode(r2())) 28 | 29 | # Observers 30 | 31 | result1 <- NULL 32 | o1 <- rlang::inject(metaObserve({ 33 | result1 <<- !!outer_quo 34 | })) 35 | 36 | shiny:::flushReact() 37 | 38 | expect_identical(result1, "ok") 39 | 40 | expect_snapshot_output(withMetaMode(o1())) 41 | }) 42 | 43 | # Outputs 44 | testthat::skip_if_not_installed("shiny", "1.6.0.9000") 45 | isolate({ 46 | out1 <- rlang::inject(metaRender(shiny::renderText, !!outer_quo)) 47 | expect_identical(out1(), "ok") 48 | }) 49 | }) 50 | 51 | describe("metaAction", { 52 | it("basically works", { 53 | a <- 1 54 | metaAction({ 55 | a <- 2 56 | }) 57 | expect_identical(a, 2) 58 | 59 | metaAction(quote({ 60 | a <- 3 61 | }), quoted = TRUE) 62 | expect_identical(a, 3) 63 | 64 | env <- new.env() 65 | metaAction({ 66 | a <- 4 67 | }, env = env) 68 | expect_identical(a, 3) 69 | expect_identical(env[["a"]], 4) 70 | 71 | metaAction(quote({ 72 | a <- 5 73 | }), env = env, quoted = TRUE) 74 | expect_identical(a, 3) 75 | expect_identical(env[["a"]], 5) 76 | }) 77 | 78 | it("unquotes properly", { 79 | b <- TRUE 80 | act <- metaAction(x <- ..(b)) 81 | expect_identical(x, TRUE) 82 | expect_snapshot_output(withMetaMode(act())) 83 | 84 | mr <- metaReactive({ 85 | FALSE 86 | }) 87 | isolate({ 88 | act <- metaAction(y <- ..(mr())) 89 | }) 90 | expect_identical(y, FALSE) 91 | expect_snapshot_output(expandChain(act())) 92 | }) 93 | 94 | it("errors on non-meta usage", { 95 | ma <- metaAction({}) 96 | expect_error(ma()) 97 | }) 98 | 99 | it("can contain code that uses !!", { 100 | ma <- metaAction({ 101 | foo <- 1 102 | x <- rlang::expr(!!foo) 103 | }) 104 | expect_identical(x, 1) 105 | if (getRversion() < "3.5") { 106 | skip("Quoted !! isn't printed properly in R3.4 and lower.") 107 | } else { 108 | expect_snapshot_output(withMetaMode(ma())) 109 | } 110 | }) 111 | 112 | it("obeys scoping rules", { 113 | # introduces scopes 114 | outer <- environment() 115 | i <- 0 116 | 117 | mr <- metaReactive({ 118 | inner <- environment() 119 | expect_false(identical(inner, outer)) 120 | 121 | i <<- i + 1 122 | }) 123 | isolate(mr()) 124 | 125 | expect_identical(i, 1) 126 | 127 | mr2 <- metaReactive2({ 128 | inner <- environment() 129 | expect_false(identical(inner, outer)) 130 | i <<- i + 1 131 | metaExpr({ 132 | innermost <- environment() 133 | expect_true(identical(innermost, inner)) 134 | i <<- i + 1 135 | }) 136 | }) 137 | isolate(mr2()) 138 | 139 | expect_identical(i, 3) 140 | 141 | # In meta mode, the `metaExpr()` part of the reactive is quoted and 142 | # returned, not executed, so `i` only increments by 1. 143 | withMetaMode(mr2()) 144 | expect_identical(i, 4) 145 | }) 146 | }) 147 | -------------------------------------------------------------------------------- /R/observe.R: -------------------------------------------------------------------------------- 1 | #' Create a meta-reactive observer 2 | #' 3 | #' Create a [shiny::observe()]r that, when invoked with meta-mode activated 4 | #' (i.e. called within [withMetaMode()] or [expandChain()]), returns a partially 5 | #' evaluated code expression. Outside of meta-mode, `metaObserve()` is 6 | #' equivalent to `observe()` (it fully evaluates the given expression). 7 | #' 8 | #' @details If you wish to capture specific code inside of `expr` (e.g. ignore 9 | #' code that has no meaning outside shiny, like [shiny::req()]), use 10 | #' `metaObserve2()` in combination with `metaExpr()`. When using 11 | #' `metaObserve2()`, `expr` must return a `metaExpr()`. 12 | #' 13 | #' @inheritParams shiny::observe 14 | #' @inheritParams metaReactive 15 | #' @inheritParams metaExpr 16 | #' @return A function that, when called in meta mode (i.e. inside 17 | #' [expandChain()]), will return the code in quoted form. If this function is 18 | #' ever called outside of meta mode, it throws an error, as it is definitely 19 | #' being called incorrectly. 20 | #' @seealso [metaExpr()], [`..`][shinymeta::dotdot] 21 | #' @export 22 | #' @examples 23 | #' 24 | #' # observers execute 'immediately' 25 | #' x <- 1 26 | #' mo <- metaObserve({ 27 | #' x <<- x + 1 28 | #' }) 29 | #' getFromNamespace("flushReact", "shiny")() 30 | #' print(x) 31 | #' 32 | #' # It only makes sense to invoke an meta-observer 33 | #' # if we're in meta-mode (i.e., generating code) 34 | #' expandChain(mo()) 35 | #' 36 | #' # Intentionally produces an error 37 | #' \dontrun{mo()} 38 | #' 39 | metaObserve <- function(expr, env = parent.frame(), quoted = FALSE, 40 | label = NULL, domain = getDefaultReactiveDomain(), 41 | localize = "auto", bindToReturn = FALSE) { 42 | 43 | if (!quoted) { 44 | expr <- substitute(expr) 45 | quoted <- TRUE 46 | } 47 | 48 | # Even though expr itself is quoted, wrapExpr will effectively unquote it by 49 | # interpolating it into the `metaExpr()` call, thus quoted = FALSE. 50 | expr <- wrapExpr(shinymeta::metaExpr, expr, quoted = FALSE, localize = localize, bindToReturn = bindToReturn) 51 | 52 | metaObserveImpl(expr = expr, env = env, label = label, domain = domain) 53 | } 54 | 55 | #' @inheritParams metaObserve 56 | #' @export 57 | #' @rdname metaObserve 58 | metaObserve2 <- function(expr, env = parent.frame(), quoted = FALSE, 59 | label = NULL, domain = getDefaultReactiveDomain()) { 60 | 61 | if (!quoted) { 62 | expr <- substitute(expr) 63 | quoted <- TRUE 64 | } 65 | 66 | metaObserveImpl(expr = expr, env = env, label = label, domain = domain) 67 | } 68 | 69 | metaObserveImpl <- function(expr, env, label, domain) { 70 | force(expr) 71 | force(env) 72 | force(label) 73 | force(domain) 74 | 75 | r_meta <- function() { 76 | shiny::withReactiveDomain(domain, { 77 | eval(expr, envir = new.env(parent = env)) 78 | }) 79 | } 80 | 81 | o_normal <- rlang::inject( 82 | shiny::observe(!!rlang::new_quosure(expr, env = env), label = label, domain = domain) 83 | ) 84 | 85 | structure( 86 | function() { 87 | metaDispatch( 88 | normal = { 89 | stop("Meta mode must be activated when calling the function returned by `metaObserve()`: did you mean to call this function inside of `expandChain()`?") 90 | }, 91 | meta = { 92 | r_meta() 93 | } 94 | ) 95 | }, 96 | observer_impl = o_normal, 97 | class = c("shinymeta_observer", "shinymeta_object", "function") 98 | ) 99 | } 100 | 101 | #' @export 102 | `$.shinymeta_observer` <- function(x, name) { 103 | obs <- attr(x, "observer_impl", exact = TRUE) 104 | obs[[name]] 105 | } 106 | 107 | #' @export 108 | `[[.shinymeta_observer` <- function(x, name) { 109 | obs <- attr(x, "observer_impl", exact = TRUE) 110 | obs[[name]] 111 | } 112 | -------------------------------------------------------------------------------- /tests/testthat/test-expansion.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | 3 | describe("expansion", isolate({ 4 | one <- metaReactive({ 5 | 1 6 | }) 7 | two <- metaReactive({ 8 | ..(one()) 9 | }) 10 | 11 | it("basically works", { 12 | res <- withMetaMode( 13 | metaExpr(..(two())) 14 | ) 15 | q1 <- quote(1) 16 | expect_equal(unclass(res), q1) 17 | expect_true(formatCode(res) == "1") 18 | }) 19 | 20 | # NOTE this used to cache in meta mode but with expandChain it no longer 21 | # does, since fetching code can have side effects 22 | it("metaMode doesn't cache in meta mode only", { 23 | rand <- metaReactive({ 24 | ..(runif(1)) 25 | }) 26 | 27 | x1 <- withMetaMode(metaExpr(..(rand()))) 28 | x2 <- withMetaMode(metaExpr(..(rand()))) 29 | expect_true(!identical(x1, x2)) 30 | 31 | y1 <- rand() 32 | y2 <- rand() 33 | expect_identical(y1, y2) 34 | }) 35 | 36 | it("has clean pipeline stages", { 37 | x1 <- metaReactive({ ..(one()) + 2 }) 38 | expect_true(withMetaMode(x1()) == quote(1 + 2)) 39 | 40 | x2 <- metaReactive({ ..(one()) %>% print() }) 41 | expect_true(withMetaMode(x2()) == quote(1 %>% print())) 42 | }) 43 | 44 | it("reads from enclosing environment", { 45 | x <- 1 46 | e <- environment() 47 | result <- local({ 48 | x <- 2 49 | metaExpr({ ..(x) }, env = e) 50 | }) 51 | expect_equal(result, 1) 52 | 53 | result2 <- local({ 54 | x <- 2 55 | metaExpr({ ..(x) }) 56 | }) 57 | expect_equal(result2, 2) 58 | 59 | result3 <- local({ 60 | x <- 2 61 | metaExpr({ x }, env = e) 62 | }) 63 | expect_equal(result3, 1) 64 | 65 | result4 <- local({ 66 | x <- 2 67 | metaExpr({ x }) 68 | }) 69 | expect_equal(result4, 2) 70 | }) 71 | 72 | it("doesn't introduce a scope", { 73 | a <- 1 74 | metaExpr(a <- 2) 75 | expect_equal(a, 2) 76 | }) 77 | 78 | })) 79 | 80 | expect_equal_call <- function(actual, expected) { 81 | if (inherits(actual, "shinyMetaExpr")) { 82 | actual <- unclass(actual) 83 | } 84 | expect_equal(actual, expected) 85 | } 86 | 87 | test_that("mixed mode", {isolate({ 88 | # A bunch of different kinds of metaReactive objects that should all 89 | # yield quote(1+1) in meta mode. 90 | srcs <- list( 91 | metaReactive(1 + 1, inline = TRUE), 92 | metaReactive2(metaExpr(1 + 1), inline = TRUE), 93 | metaObserve(1 + 1), 94 | metaObserve2(metaExpr(1 + 1)), 95 | metaRender(renderText, 1 + 1), 96 | metaRender2(renderText, metaExpr(1 + 1)) 97 | ) 98 | 99 | # Try this scenario with each of the different kinds of objects. 100 | lapply(srcs, function(src) { 101 | 102 | mr <- metaReactive(..(src()), inline = TRUE) 103 | expect_equal_call(withMetaMode(mr()), quote(1 + 1)) 104 | 105 | v <- reactiveVal(0) # cache busting reactive val 106 | mr2 <- metaReactive2({ 107 | v() 108 | if (inherits(src, "shinymeta_observer")) { 109 | expect_error(src()) 110 | } else { 111 | expect_identical(as.character(src()), "2") 112 | } 113 | withMetaMode(src()) 114 | }) 115 | expect_equal_call(withMetaMode(mr2()), quote(1 + 1)) 116 | # Cached 117 | expect_equal_call(withMetaMode(mr2()), quote(1 + 1)) 118 | 119 | 120 | # Test nesting deeper than one level 121 | 122 | v(isolate(v()) + 1) # bust cache for mr2 123 | mr3 <- metaReactive({ 124 | ..(mr2()) 125 | }) 126 | expect_equal_call(withMetaMode(mr3()), quote(1 + 1)) 127 | 128 | 129 | # Test observer 130 | v(isolate(v()) + 1) # bust cache for mr2 131 | mr4 <- metaObserve(..(src())) 132 | expect_equal_call(withMetaMode(mr4()), quote(1 + 1)) 133 | mr4$destroy() # Otherwise throws errors on next flushReact 134 | 135 | # Test renderer 136 | v(isolate(v()) + 1) # bust cache for mr2 137 | mr5 <- metaRender(renderText, ..(src())) 138 | expect_equal_call(withMetaMode(mr5()), quote(1 + 1)) 139 | }) 140 | })}) 141 | -------------------------------------------------------------------------------- /man/dotdot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/metareactive.R 3 | \name{dotdot} 4 | \alias{dotdot} 5 | \alias{..} 6 | \title{The dot-dot operator} 7 | \usage{ 8 | ..(expr) 9 | } 10 | \arguments{ 11 | \item{expr}{A single code expression. Required.} 12 | } 13 | \value{ 14 | \code{expr}, but annotated. 15 | } 16 | \description{ 17 | In shinymeta, \code{..()} is designed for \emph{annotating} portions of code 18 | inside a \code{metaExpr} (or its higher-level friends \code{metaReactive}, 19 | \code{metaObserve}, and \code{metaRender}). At run time, these \verb{meta-} functions search for 20 | \code{..()} calls and replace them with something else (see Details). Outside 21 | of these \verb{meta-} functions, \code{..()} is not defined, so one must take extra care when 22 | interrogating any code within a \verb{meta-} function that contains \code{..()} (see Debugging). 23 | } 24 | \details{ 25 | As discussed in the \href{https://rstudio.github.io/shinymeta/articles/code-generation.html}{Code Generation} 26 | vignette, \code{..()} is used to mark reactive reads and unquote expressions inside 27 | \code{metaExpr} (or its higher-level friends \code{metaReactive}, \code{metaObserve}, and \code{metaRender}). 28 | The actual behavior of \code{..()} depends on the current 29 | \href{https://rstudio.github.io/shinymeta/articles/code-generation.html#execution}{mode of execution}: 30 | \itemize{ 31 | \item \strong{Normal execution}: the \code{..()} call is stripped from the expression before evaluation. 32 | For example, \code{..(dataset())} becomes \code{dataset()}, and \code{..(format(Sys.Date()))} becomes 33 | \code{format(Sys.Date())}. 34 | \item \strong{Meta execution} (as in \code{\link[=expandChain]{expandChain()}}): reactive reads are replaced with a suitable 35 | name or value (i.e. \code{..(dataset())} becomes \code{dataset} or similar) and other code is 36 | replaced with its result (\code{..(format(Sys.Date()))} becomes e.g. \code{"2019-08-06"}). 37 | } 38 | } 39 | \section{Debugging}{ 40 | 41 | If \code{..()} is called in a context where it isn't defined (that is, outside of a meta-expression), 42 | you'll see an error like: "..() is only defined inside shinymeta meta-expressions". 43 | In practice, this problem can manifest itself in at least 3 different ways: 44 | \enumerate{ 45 | \item Execution is halted, perhaps by inserting \code{browser()}, and from inside the \verb{Browse>} prompt, 46 | \code{..()} is called directly. This is also not allowed, because the purpose of \code{..()} is to be 47 | searched-and-replaced away \emph{before} \code{metaExpr} begins executing the code. As a result, 48 | if you want to interrogate code that contains \code{..()} at the \verb{Browse>} prompt, 49 | make sure it's wrapped in \code{metaExpr} before evaluating it. Also, note that when 50 | stepping through a \code{metaExpr} at the \verb{Browse>} prompt with \code{n}, the debugger 51 | will echo the actual code that's evaluated during normal execution (i.e., \code{..()} is stripped), 52 | so that's another option for interrogating what happens during normal execution. 53 | On the other hand, if you are wanting to interrogate what happens during meta-execution, 54 | you can wrap a \code{metaExpr} with \code{expandChain()}. 55 | \item \code{..()} is used in a non-\code{metaExpr} portions of \code{metaReactive2}, \code{metaObserve2}, and 56 | \code{metaRender2}. As discussed in \href{https://rstudio.github.io/shinymeta/articles/code-generation.html#execution}{The execution model}, 57 | non-\code{metaExpr} portions of \code{-2} variants always use normal execution and are completely 58 | ignored at code generation time, so \code{..()} isn't needed in this context. 59 | \item Crafted a bit of code that uses \code{..()} in a way that was too clever for 60 | shinymeta to understand. For example, \code{lapply(1:5, ..)} is syntactically valid R code, 61 | but it's nonsense from a shinymeta perspective. 62 | } 63 | } 64 | 65 | \seealso{ 66 | \code{\link[=metaExpr]{metaExpr()}}, \code{\link[=metaReactive]{metaReactive()}}, \code{\link[=metaObserve]{metaObserve()}}, \code{\link[=metaRender]{metaRender()}} 67 | } 68 | \keyword{internal} 69 | -------------------------------------------------------------------------------- /man/metaRender.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/render.R 3 | \name{metaRender} 4 | \alias{metaRender} 5 | \alias{metaRender2} 6 | \title{Create a meta-reactive output} 7 | \usage{ 8 | metaRender( 9 | renderFunc, 10 | expr, 11 | ..., 12 | env = parent.frame(), 13 | quoted = FALSE, 14 | localize = "auto", 15 | bindToReturn = FALSE 16 | ) 17 | 18 | metaRender2(renderFunc, expr, ..., env = parent.frame(), quoted = FALSE) 19 | } 20 | \arguments{ 21 | \item{renderFunc}{A reactive output function (e.g., \link[shiny:renderPlot]{shiny::renderPlot}, \link[shiny:renderPrint]{shiny::renderText}, \link[shiny:renderUI]{shiny::renderUI}, etc).} 22 | 23 | \item{expr}{An expression that generates given output expected by \code{renderFunc}.} 24 | 25 | \item{...}{Other arguments passed along to \code{renderFunc}.} 26 | 27 | \item{env}{The parent environment for the reactive expression. By default, 28 | this is the calling environment, the same as when defining an ordinary 29 | non-reactive expression. If \code{x} is a quosure and \code{quoted} is \code{TRUE}, 30 | then \code{env} is ignored.} 31 | 32 | \item{quoted}{If it is \code{TRUE}, then the \code{\link[=quote]{quote()}}ed value of \code{x} 33 | will be used when \code{x} is evaluated. If \code{x} is a quosure and you 34 | would like to use its expression as a value for \code{x}, then you must set 35 | \code{quoted} to \code{TRUE}.} 36 | 37 | \item{localize}{Whether or not to wrap the returned expression in \code{\link[=local]{local()}}. 38 | The default, \code{"auto"}, only wraps expressions with a top-level \code{\link[=return]{return()}} 39 | statement (i.e., return statements in anonymized functions are ignored).} 40 | 41 | \item{bindToReturn}{For non-\code{localize}d expressions, should an assignment 42 | of a meta expression be applied to the \emph{last child} of the top-level \verb{\\\{} call?} 43 | } 44 | \value{ 45 | An annotated render function, ready to be assigned to an output slot. 46 | The function may also be called in meta mode (i.e., inside \code{\link[=expandChain]{expandChain()}}) 47 | to return the code in quoted form. 48 | } 49 | \description{ 50 | Create a meta-reactive output that, when invoked with meta-mode activated 51 | (i.e. called within \code{\link[=expandChain]{expandChain()}} or \code{\link[=withMetaMode]{withMetaMode()}}), returns a 52 | code expression (instead of evaluating that expression and returning the value). 53 | } 54 | \details{ 55 | If you wish to capture specific code inside of \code{expr} (e.g. ignore code 56 | that has no meaning outside shiny, like \code{\link[shiny:req]{shiny::req()}}), use \code{metaRender2()} in combination 57 | with \code{metaExpr()}. When using \code{metaRender2()}, \code{expr} must return a \code{metaExpr()}. 58 | 59 | Since package authors are allowed to create their own output rendering functions, 60 | creating a meta-counterpart of an output renderer (e.g. \code{renderPlot()}) needs to be 61 | more general than prefixing \code{meta} to the function name (as with \code{metaReactive()} and \code{metaObserve()}). 62 | \code{metaRender()} makes some assumptions about the arguments taken by the render function, 63 | assumptions that we believe are true for all existing render functions. 64 | If you encounter a render function that doesn't seem to work properly, 65 | please let us know by \href{https://github.com/rstudio/shinymeta/issues}{filing an issue on GitHub}. 66 | } 67 | \examples{ 68 | 69 | if (interactive()) { 70 | library(shiny) 71 | library(shinymeta) 72 | 73 | ui <- fluidPage( 74 | selectInput("var", label = "Choose a variable", choices = names(cars)), 75 | verbatimTextOutput("Summary"), 76 | verbatimTextOutput("code") 77 | ) 78 | 79 | server <- function(input, output) { 80 | var <- metaReactive({ 81 | cars[[..(input$var)]] 82 | }) 83 | output$Summary <- metaRender(renderPrint, { 84 | summary(..(var())) 85 | }) 86 | output$code <- renderPrint({ 87 | expandChain(output$Summary()) 88 | }) 89 | } 90 | 91 | shinyApp(ui, server) 92 | } 93 | 94 | } 95 | \seealso{ 96 | \code{\link[=metaExpr]{metaExpr()}}, \code{\link[=dotdot]{..}} 97 | } 98 | -------------------------------------------------------------------------------- /man/metaReactive.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/metareactive.R 3 | \name{metaReactive} 4 | \alias{metaReactive} 5 | \alias{metaReactive2} 6 | \title{Create a meta-reactive expression} 7 | \usage{ 8 | metaReactive( 9 | expr, 10 | env = parent.frame(), 11 | quoted = FALSE, 12 | varname = NULL, 13 | domain = shiny::getDefaultReactiveDomain(), 14 | inline = FALSE, 15 | localize = "auto", 16 | bindToReturn = FALSE 17 | ) 18 | 19 | metaReactive2( 20 | expr, 21 | env = parent.frame(), 22 | quoted = FALSE, 23 | varname = NULL, 24 | domain = shiny::getDefaultReactiveDomain(), 25 | inline = FALSE 26 | ) 27 | } 28 | \arguments{ 29 | \item{expr}{An expression (quoted or unquoted).} 30 | 31 | \item{env}{The parent environment for the reactive expression. By default, 32 | this is the calling environment, the same as when defining an ordinary 33 | non-reactive expression. If \code{x} is a quosure and \code{quoted} is \code{TRUE}, 34 | then \code{env} is ignored.} 35 | 36 | \item{quoted}{If it is \code{TRUE}, then the \code{\link[=quote]{quote()}}ed value of \code{x} 37 | will be used when \code{x} is evaluated. If \code{x} is a quosure and you 38 | would like to use its expression as a value for \code{x}, then you must set 39 | \code{quoted} to \code{TRUE}.} 40 | 41 | \item{varname}{An R variable name that this object prefers to be named when 42 | its code is extracted into an R script. (See also: \code{\link[=expandChain]{expandChain()}})} 43 | 44 | \item{domain}{See \link[shiny]{domains}.} 45 | 46 | \item{inline}{If \code{TRUE}, during code expansion, do not declare a variable for 47 | this object; instead, inline the code into every call site. Use this to avoid 48 | introducing variables for very simple expressions. (See also: \code{\link[=expandChain]{expandChain()}})} 49 | 50 | \item{localize}{Whether or not to wrap the returned expression in \code{\link[=local]{local()}}. 51 | The default, \code{"auto"}, only wraps expressions with a top-level \code{\link[=return]{return()}} 52 | statement (i.e., return statements in anonymized functions are ignored).} 53 | 54 | \item{bindToReturn}{For non-\code{localize}d expressions, should an assignment 55 | of a meta expression be applied to the \emph{last child} of the top-level \verb{\\\{} call?} 56 | } 57 | \value{ 58 | A function that, when called in meta mode (i.e. inside 59 | \code{\link[=expandChain]{expandChain()}}), will return the code in quoted form. When called outside 60 | meta mode, it acts the same as a regular \code{\link[shiny:reactive]{shiny::reactive()}} expression 61 | call. 62 | } 63 | \description{ 64 | Create a \code{\link[shiny:reactive]{shiny::reactive()}} that, when invoked with meta-mode activated 65 | (i.e. called within \code{\link[=withMetaMode]{withMetaMode()}} or \code{\link[=expandChain]{expandChain()}}), returns a code 66 | expression (instead of evaluating that expression and returning the value). 67 | } 68 | \details{ 69 | If you wish to capture specific code inside of \code{expr} (e.g. ignore 70 | code that has no meaning outside shiny, like \code{\link[shiny:req]{shiny::req()}}), use 71 | \code{metaReactive2()} in combination with \code{metaExpr()}. When using 72 | \code{metaReactive2()}, \code{expr} must return a \code{metaExpr()}. 73 | 74 | If \code{varname} is unspecified, \link{srcref}s are used in attempt to infer the name 75 | bound to the meta-reactive object. In order for this inference to work, the 76 | \code{keep.source} \link{option} must be \code{TRUE} and \code{expr} must begin with \verb{\\\{}. 77 | } 78 | \examples{ 79 | 80 | library(shiny) 81 | options(shiny.suppressMissingContextError = TRUE) 82 | 83 | input <- list(x = 1) 84 | 85 | y <- metaReactive({ 86 | req(input$x) 87 | a <- ..(input$x) + 1 88 | b <- a + 1 89 | c + 1 90 | }) 91 | 92 | withMetaMode(y()) 93 | expandChain(y()) 94 | 95 | y <- metaReactive2({ 96 | req(input$x) 97 | 98 | metaExpr({ 99 | a <- ..(input$x) + 1 100 | b <- a + 1 101 | c + 1 102 | }, bindToReturn = TRUE) 103 | }) 104 | 105 | expandChain(y()) 106 | 107 | } 108 | \seealso{ 109 | \code{\link[=metaExpr]{metaExpr()}}, \code{\link[=dotdot]{..}} 110 | } 111 | -------------------------------------------------------------------------------- /tests/testthat/test-render.R: -------------------------------------------------------------------------------- 1 | describe("metaRender", isolate({ 2 | it("basically works", { 3 | expect_identical( 4 | shiny::renderText({ paste("foo", "bar") })(), 5 | "foo bar" 6 | ) 7 | 8 | expect_identical( 9 | metaRender(shiny::renderText, { paste("foo", "bar") })(), 10 | "foo bar" 11 | ) 12 | 13 | expect_equal( 14 | unclass(withMetaMode({ 15 | metaRender(shiny::renderText, { paste("foo", "bar") })() 16 | })), 17 | quote( 18 | paste("foo", "bar") 19 | ) 20 | ) 21 | 22 | expect_equal( 23 | unclass(withMetaMode({ 24 | metaRender2(shiny::renderText, metaExpr({ paste("foo", "bar") }))() 25 | })), 26 | quote( 27 | paste("foo", "bar") 28 | ) 29 | ) 30 | 31 | }) 32 | 33 | it("works with quoted expr", { 34 | x <- local({ 35 | a <- "foo" 36 | b <- "bar" 37 | env <- environment() 38 | list( 39 | expr0 = quote({ paste(a, b) }), 40 | expr1 = quote({ paste(..(a), ..(b)) }), 41 | expr2 = quote(metaExpr({ paste(..(a), ..(b)) })), 42 | env = env 43 | ) 44 | }) 45 | 46 | expect_identical( 47 | shiny::renderText(expr = x$expr0, env = x$env, quoted = TRUE)(), 48 | "foo bar" 49 | ) 50 | 51 | expect_equal( 52 | unclass(withMetaMode({ 53 | metaRender(shiny::renderText, expr = x$expr1, env = x$env, quoted = TRUE)() 54 | })), 55 | quote( 56 | paste("foo", "bar") 57 | ) 58 | ) 59 | 60 | expect_equal( 61 | unclass(withMetaMode({ 62 | metaRender2(shiny::renderText, expr = x$expr2, env = x$env, quoted = TRUE)() 63 | })), 64 | quote( 65 | paste("foo", "bar") 66 | ) 67 | ) 68 | 69 | }) 70 | 71 | it("works with a render pipeline", { 72 | output <- list() 73 | 74 | data <- metaReactive({ dplyr::sample_n(diamonds, 1000) }) 75 | output$plot <- metaRender(renderPlot, { 76 | ggplot(..(data()), aes(carat, price)) + geom_point() 77 | }) 78 | x1 <- expandChain( 79 | "# top-level comment", 80 | output$plot() 81 | ) 82 | x2 <- expandChain( 83 | "# top-level comment", 84 | output[["plot"]]() 85 | ) 86 | 87 | expect_snapshot_output(cran = TRUE, formatCode(x1)) 88 | expect_snapshot_output(cran = TRUE, formatCode(x2)) 89 | 90 | # TODO: it would be nice to have an informative error here 91 | # https://github.com/rstudio/shinymeta/issues/49 92 | #expect_error(expandChain(output$foo()), regexp = "output\\$foo") 93 | }) 94 | 95 | 96 | it("removes curly brackets when appropriate", { 97 | mr1 <- metaReactive({1 + 1}) 98 | code <- expandChain(invisible(mr1())) 99 | expect_true(formatCode(code) == "mr1 <- 1 + 1") 100 | 101 | mr2 <- metaReactive({ 102 | ..(quote({1 + 1})) 103 | }) 104 | 105 | code <- expandChain(invisible(mr2())) 106 | 107 | expect_true(formatCode(code) == "mr2 <- 1 + 1") 108 | }) 109 | 110 | it("uses correct scopes", { 111 | outer_var <- 100 112 | 113 | renderer <- metaRender(renderText, { 114 | expect_identical(outer_var, 100) 115 | outer_var <<- outer_var + 1 116 | }) 117 | renderer() 118 | expect_identical(outer_var, 101) 119 | 120 | mr <- metaReactive({ 121 | expect_identical(outer_var, 101) 122 | outer_var <<- outer_var + 1 123 | }) 124 | mr() 125 | expect_identical(outer_var, 102) 126 | 127 | renderer <- metaRender2(renderText, { 128 | expect_identical(outer_var, 102) 129 | outer_var <<- outer_var + 1 130 | metaExpr(outer_var <<- outer_var + 1) 131 | }) 132 | renderer() 133 | expect_identical(outer_var, 104) 134 | 135 | mr <- metaReactive2({ 136 | expect_identical(outer_var, 104) 137 | outer_var <<- outer_var + 1 138 | metaExpr(outer_var <<- ..(outer_var + 1)) 139 | }) 140 | mr() 141 | expect_identical(outer_var, 106) 142 | 143 | outer_var <- 104 144 | res <- withMetaMode(mr()) 145 | expect_identical(outer_var, 105) 146 | expect_equal(unclass(res), quote(outer_var <<- 106)) 147 | }) 148 | 149 | })) 150 | -------------------------------------------------------------------------------- /R/archive.R: -------------------------------------------------------------------------------- 1 | zip_archive <- function(temp_dir = NULL) { 2 | if (!is.null(temp_dir) && (!is.character(temp_dir) || length(temp_dir) != 1)) { 3 | stop("temp_dir must be a single-element character vector") 4 | } 5 | 6 | if (is.null(temp_dir)) { 7 | temp_dir <- tempfile("archive") 8 | fs::dir_create(temp_dir, mode = "u=rwx,go=") 9 | } else if (!dir.exists(temp_dir)) { 10 | stop("temp_dir directory does not exist") 11 | } 12 | 13 | structure( 14 | list(basedir = temp_dir), 15 | class = "pending_zip_archive" 16 | ) 17 | } 18 | 19 | is_zip_archive <- function(x) { 20 | inherits(x, "pending_zip_archive") 21 | } 22 | 23 | archive_basedir <- function(x) { 24 | stopifnot(is_zip_archive(x)) 25 | 26 | x[["basedir"]] 27 | } 28 | 29 | #' @export 30 | print.pending_zip_archive <- function(x, ...) { 31 | stopifnot(is_zip_archive(x)) 32 | 33 | basedir <- archive_basedir(x) 34 | cat("Archive: ", basedir, "\n", sep = "") 35 | contents <- list_items(x) 36 | paths <- fs::path(basedir, contents) 37 | dirs <- fs::is_dir(paths) 38 | cat(paste0(rlang::rep_along(contents, "- "), contents, ifelse(dirs, "/", ""), pretty_file_sizes(paths, " (", ")")), sep = "\n") 39 | invisible(x) 40 | } 41 | 42 | # Turn file paths into "10 B", "1.3 GiB", etc. Directories come back as "". 43 | pretty_file_sizes <- function(paths, prefix = "", suffix = "") { 44 | if (length(paths) == 0) { 45 | return(character(0)) 46 | } 47 | sizes <- fs::file_size(paths) 48 | ifelse(is.na(sizes) | fs::is_dir(paths), 49 | "", 50 | paste0(prefix, 51 | vapply(sizes, function(size) { 52 | format(structure(size, class = "object_size"), units = "auto", standard = "IEC") 53 | }, character(1)), 54 | suffix) 55 | ) 56 | } 57 | 58 | add_items <- function(x, ...) { 59 | stopifnot(is_zip_archive(x)) 60 | 61 | include_files <- rlang::dots_list(..., .homonyms = "last", .check_assign = TRUE) 62 | 63 | if (is.null(names(include_files))) { 64 | names(include_files) <- as.character(include_files) 65 | } 66 | 67 | mapply(names(include_files), include_files, FUN = function(to, from) { 68 | if (nchar(from) == 0) { 69 | from <- to 70 | } 71 | add_item(x, from, to) 72 | NULL 73 | }) 74 | 75 | x 76 | } 77 | 78 | add_item <- function(x, source_file, target_file) { 79 | stopifnot(is_zip_archive(x)) 80 | 81 | if (!is.character(source_file) || length(source_file) != 1) { 82 | stop("source_file must be a single-element character vector") 83 | } 84 | if (!is.character(target_file) || length(target_file) != 1) { 85 | stop("target_file must be a single-element character vector") 86 | } 87 | 88 | if (fs::is_absolute_path(target_file)) { 89 | stop("target_file must be a relative path") 90 | } 91 | 92 | full_src <- fs::path_abs(source_file) 93 | 94 | basedir <- archive_basedir(x) 95 | 96 | if (fs::dir_exists(full_src)) { 97 | full_dest <- fs::path(basedir, target_file) 98 | fs::dir_copy(full_src, full_dest) 99 | } else { 100 | if (grepl("[/\\]$", target_file)) { 101 | # If source is a file, but target is a directory name, ensure 102 | # that the file gets copied into the target, rather than as 103 | # the target. Without this line, fs::file_copy would treat 104 | # the target as a filename (it would strip off the slash). 105 | target_file <- fs::path(target_file, fs::path_file(source_file)) 106 | } 107 | full_dest <- fs::path(basedir, target_file) 108 | 109 | if (!fs::path_dir(target_file) %in% c("", ".")) 110 | fs::dir_create(fs::path_dir(full_dest), recurse = TRUE) 111 | fs::file_copy(full_src, full_dest) 112 | } 113 | 114 | x 115 | } 116 | 117 | list_items <- function(x) { 118 | stopifnot(is_zip_archive(x)) 119 | 120 | basedir <- archive_basedir(x) 121 | fs::path_rel( 122 | fs::dir_ls(basedir, recurse = TRUE), 123 | basedir 124 | ) 125 | } 126 | 127 | build_archive <- function(x, output_file) { 128 | stopifnot(is_zip_archive(x)) 129 | 130 | basedir <- archive_basedir(x) 131 | 132 | olddir <- getwd() 133 | setwd(basedir) 134 | on.exit(setwd(olddir)) 135 | 136 | utils::zip(fs::path_abs(output_file, olddir), ".") 137 | invisible(output_file) 138 | } 139 | -------------------------------------------------------------------------------- /R/utils-format.R: -------------------------------------------------------------------------------- 1 | # -------------------------------------------------------- 2 | # Code formatting utilities 3 | # -------------------------------------------------------- 4 | 5 | # wrap a call in local 6 | add_local_scope <- function(x, localize) { 7 | if (!is.call(x)) return(x) 8 | if (identical(localize, "auto")) { 9 | localize <- any(unlist(has_return(x), use.names = FALSE)) 10 | } 11 | if (localize) call("local", x) else x 12 | } 13 | 14 | # Returns TRUE if a return() is detected outside of 15 | # an anonymous function or local() expresion 16 | has_return <- function(x) { 17 | if (!is.call(x)) return(FALSE) 18 | if (rlang::is_call(x, "function")) return(FALSE) 19 | if (rlang::is_call(x, "local")) return(FALSE) 20 | if (rlang::is_call(x, "return")) return(TRUE) 21 | lapply(x, has_return) 22 | } 23 | 24 | 25 | # Modify a call like (also works with a collection of assignments) 26 | # x <- { 27 | # a <- 1 28 | # b <- 1 + a 29 | # b + 1 30 | # } 31 | # to 32 | # { 33 | # a <- 1 34 | # b <- 1 + a 35 | # x <- b + 1 36 | # } 37 | bind_to_return <- function(expr) { 38 | walk_ast(expr, function(x) { 39 | if (is_assign(x) && rlang::is_call(x[[3]], "{") && inherits(x[[3]], "bindToReturn")) { 40 | rhs <- x[[3]] 41 | rhs[[length(rhs)]] <- call("<-", x[[2]], rhs[[length(rhs)]]) 42 | x <- rhs 43 | } 44 | x 45 | }) 46 | } 47 | 48 | # Modify a call like (also works with a collection of them) 49 | # a <- { 50 | # "# my comment" 51 | # 1+1 52 | # } 53 | # to 54 | # { 55 | # "# my comment" 56 | # a <- 1+1 57 | # } 58 | elevate_comments <- function(expr) { 59 | walk_ast(expr, function(x) { 60 | if (is_assign(x) && rlang::is_call(x[[3]], "{", n = 2)) { 61 | if (isTRUE(attr(x[[3]][[2]], "shinymeta_comment"))) { 62 | x <- call( 63 | "{", x[[3]][[2]], call("<-", x[[2]], x[[3]][[3]]) 64 | ) 65 | } 66 | } 67 | x 68 | }) 69 | } 70 | 71 | 72 | # Find and flag (i.e. attach attributes) to comment-like strings 73 | comment_flags <- function(expr) { 74 | walk_ast(expr, function(x) { 75 | # comment must appear as a direct child of a `{` call 76 | if (!rlang::is_call(x, "{")) return(x) 77 | 78 | x[-1] <- lapply(x[-1], function(y) { 79 | if (is_comment(y) && !is_illegal(y)) attr(y, "shinymeta_comment") <- TRUE 80 | y 81 | }) 82 | # If the comment appears as the last child of a `{` call, 83 | # it might be an assignment value, so we throw a warning if that occurs 84 | # and tag it so that if and when we arrive at the string in the future, 85 | # we know not to add the special comment identifier. 86 | if (is_comment(x[[length(x)]])) { 87 | warning("A shinymeta comment can not appear as the last child of a `{` call") 88 | attr(x[[length(x)]], "shinymeta_comment") <- "illegal" 89 | } 90 | 91 | x 92 | }) 93 | } 94 | 95 | 96 | # Find flagged comment strings and enclose that string with 97 | # an identifier we remove during deparseCode(). 98 | comment_flags_to_enclosings <- function(expr) { 99 | walk_ast(expr, function(x) { 100 | if (isTRUE(attr(x, "shinymeta_comment"))) { 101 | paste0(comment_start, x, comment_end) 102 | } else if (length(attr(x, "shinymeta_comment"))) { 103 | structure(x, shinymeta_comment = NULL) 104 | } else { 105 | x 106 | } 107 | }) 108 | } 109 | 110 | 111 | # --------------------------------------------------------- 112 | # Helpers 113 | # --------------------------------------------------------- 114 | 115 | # Apply a function to each node of an AST 116 | # (similar to htmltools:::rewriteTags) 117 | walk_ast <- function(x, fun, preorder = FALSE) { 118 | if (rlang::is_missing(x)) return(x) 119 | if (preorder) x <- fun(x) 120 | if (is.call(x)) { 121 | x[] <- lapply(x, walk_ast, fun, preorder = preorder) 122 | } 123 | if (!preorder) x <- fun(x) 124 | return(x) 125 | } 126 | 127 | is_assign <- function(x) { 128 | inherits(x, c("<-", "=")) 129 | } 130 | 131 | is_comment <- function(x) { 132 | if (!is.character(x) || length(x) != 1) return(FALSE) 133 | grepl("^#", x) 134 | } 135 | 136 | is_illegal <- function(x) { 137 | identical(attr(x, "shinymeta_comment"), "illegal") 138 | } 139 | 140 | 141 | comment_start <- "######StartOfShinyMetaCommentIdentifier######" 142 | comment_end <- "######EndOfShinyMetaCommentIdentifier######" 143 | -------------------------------------------------------------------------------- /R/render.R: -------------------------------------------------------------------------------- 1 | #' Create a meta-reactive output 2 | #' 3 | #' Create a meta-reactive output that, when invoked with meta-mode activated 4 | #' (i.e. called within [expandChain()] or [withMetaMode()]), returns a 5 | #' code expression (instead of evaluating that expression and returning the value). 6 | #' 7 | #' @details If you wish to capture specific code inside of `expr` (e.g. ignore code 8 | #' that has no meaning outside shiny, like [shiny::req()]), use `metaRender2()` in combination 9 | #' with `metaExpr()`. When using `metaRender2()`, `expr` must return a `metaExpr()`. 10 | #' 11 | #' Since package authors are allowed to create their own output rendering functions, 12 | #' creating a meta-counterpart of an output renderer (e.g. `renderPlot()`) needs to be 13 | #' more general than prefixing `meta` to the function name (as with `metaReactive()` and `metaObserve()`). 14 | #' `metaRender()` makes some assumptions about the arguments taken by the render function, 15 | #' assumptions that we believe are true for all existing render functions. 16 | #' If you encounter a render function that doesn't seem to work properly, 17 | #' please let us know by [filing an issue on GitHub](https://github.com/rstudio/shinymeta/issues). 18 | #' 19 | #' @param renderFunc A reactive output function (e.g., [shiny::renderPlot], [shiny::renderText], [shiny::renderUI], etc). 20 | #' @param expr An expression that generates given output expected by `renderFunc`. 21 | #' @param ... Other arguments passed along to `renderFunc`. 22 | #' @inheritParams metaObserve 23 | #' @return An annotated render function, ready to be assigned to an output slot. 24 | #' The function may also be called in meta mode (i.e., inside [expandChain()]) 25 | #' to return the code in quoted form. 26 | 27 | #' 28 | #' @seealso [metaExpr()], [`..`][shinymeta::dotdot] 29 | #' @export 30 | #' @examples 31 | #' 32 | #' if (interactive()) { 33 | #' library(shiny) 34 | #' library(shinymeta) 35 | #' 36 | #' ui <- fluidPage( 37 | #' selectInput("var", label = "Choose a variable", choices = names(cars)), 38 | #' verbatimTextOutput("Summary"), 39 | #' verbatimTextOutput("code") 40 | #' ) 41 | #' 42 | #' server <- function(input, output) { 43 | #' var <- metaReactive({ 44 | #' cars[[..(input$var)]] 45 | #' }) 46 | #' output$Summary <- metaRender(renderPrint, { 47 | #' summary(..(var())) 48 | #' }) 49 | #' output$code <- renderPrint({ 50 | #' expandChain(output$Summary()) 51 | #' }) 52 | #' } 53 | #' 54 | #' shinyApp(ui, server) 55 | #' } 56 | #' 57 | metaRender <- function(renderFunc, expr, ..., env = parent.frame(), 58 | quoted = FALSE, localize = "auto", bindToReturn = FALSE) { 59 | 60 | if (!quoted) { 61 | expr <- substitute(expr) 62 | quoted <- TRUE 63 | } 64 | 65 | # Even though expr itself is quoted, wrapExpr will effectively unquote it by 66 | # interpolating it into the `metaExpr()` call, thus quoted = FALSE. 67 | expr <- wrapExpr(shinymeta::metaExpr, expr, quoted = FALSE, 68 | localize = localize, bindToReturn = bindToReturn) 69 | 70 | metaRender2(renderFunc, expr, ..., env = env, quoted = quoted) 71 | } 72 | 73 | #' @export 74 | #' @rdname metaRender 75 | metaRender2 <- function(renderFunc, expr, ..., env = parent.frame(), quoted = FALSE) { 76 | if (!quoted) { 77 | expr <- substitute(expr) 78 | quoted <- TRUE 79 | } 80 | 81 | domain <- getDefaultReactiveDomain() 82 | 83 | # 3rd party render functions, such as htmlwidgets::shinyRenderWidget() might 84 | # be using shiny::installExprFunction() + shiny::createRenderFunction() to 85 | # implement the rendering function, which won't work with the rlang::inject() 86 | # approach that Shiny 1.6 release suggests. If and when installExprFunction() 87 | # becomes quosure aware, which it might in 88 | # https://github.com/rstudio/shiny/pull/3390, we should be able to change this 89 | # line to use rlang::inject() in order to avoid the env/quoted deprecating 90 | # warning 91 | normal <- renderFunc(expr = expr, ..., env = env, quoted = quoted) 92 | 93 | meta <- function() { 94 | shiny::withReactiveDomain(domain, { 95 | eval(expr, envir = new.env(parent = env)) 96 | }) 97 | } 98 | 99 | structure( 100 | function(...) { 101 | metaDispatch( 102 | normal = { 103 | if (is.null(formals(normal))) 104 | normal() 105 | else 106 | normal(...) 107 | }, 108 | meta = { 109 | # TODO: Verify that length(list(...)) == 0? 110 | meta() 111 | } 112 | ) 113 | }, 114 | class = c("shinymeta_render", "shinymeta_object", "function") 115 | ) 116 | } 117 | -------------------------------------------------------------------------------- /R/format.R: -------------------------------------------------------------------------------- 1 | #' Deparse and format shinymeta expressions 2 | #' 3 | #' Turn unevaluated shinymeta expressions into (formatted or styled) text. 4 | #' 5 | #' Before any formatting takes place, the unevaluated expression is 6 | #' deparsed into a string via [deparseCode()], which ensures that 7 | #' shinymeta comment strings (i.e., literal strings that appear on their own line, 8 | #' and begin with one or more `#` characters.) are turned into comments and 9 | #' superfluous `\{` are removed. After deparsing, the `formatCode()` function then 10 | #' calls the `formatter` function on the deparsed string to format (aka style) the code string. 11 | #' The default `formatter`, `styleText()`, uses [styler::style_text()] with a couple differences: 12 | #' 13 | #' * Pipe operators (`%>%`) are _always_ followed by a line break. 14 | #' * If the token appearing after a line-break is a comma/operator, the line-break is removed. 15 | #' 16 | #' @param code Either an unevaluated expression or a deparsed code string. 17 | #' @param width The `width.cutoff` to use when [deparse()]-ing the `code` expression. 18 | #' @param formatter a function that accepts deparsed code (a character string) 19 | #' as the first argument. 20 | #' @param ... arguments passed along to the `formatter` function. 21 | #' @return Single-element character vector with formatted code 22 | #' @export 23 | #' @examples 24 | #' 25 | #' options(shiny.suppressMissingContextError = TRUE) 26 | #' 27 | #' x <- metaReactive({ 28 | #' "# Here's a comment" 29 | #' sample(5) %>% sum() 30 | #' }) 31 | #' 32 | #' code <- expandChain(x()) 33 | #' 34 | #' deparseCode(code) 35 | #' formatCode(code) 36 | #' formatCode(code, formatter = styler::style_text) 37 | formatCode <- function(code, width = 500L, formatter = styleText, ...) { 38 | if (!inherits(code, "shinyMetaDeparsed")) { 39 | code <- deparseCode(code, width = width) 40 | } 41 | code <- do.call(formatter, c(list(code), list(...))) 42 | # Add a class that we control the print() method for. The primary 43 | # motivation for this is to avoid styler:::print.vertical(), which 44 | # adds syntax highlight via unicode characters, which doesn't currently 45 | # work with shiny::renderPrint() (or anything else that does capture.output()) 46 | # https://github.com/rstudio/shinymeta/pull/93 47 | prefix_class(code, "shinyMetaFormatted") 48 | } 49 | 50 | #' @export 51 | #' @rdname formatCode 52 | styleText <- function(code, ...) { 53 | # TODO: break up functionality in rebreak and allow user to opt-out? 54 | # Also, perhaps someday we let styler handle the %>% line-breaking? 55 | # https://github.com/r-lib/styler/issues/523 56 | code <- rebreak(code) 57 | styler::style_text(code, ...) 58 | } 59 | 60 | 61 | #' @export 62 | #' @rdname formatCode 63 | deparseCode <- function(code, width = 500L) { 64 | code <- walk_ast(code, quo_to_expr, preorder = TRUE) 65 | code <- comment_flags_to_enclosings(code) 66 | # Don't include meta classes in the deparsed result 67 | code <- walk_ast(code, remove_meta_classes) 68 | code_text <- deparse_flatten(code, width = width) 69 | code_text <- comment_remove_enclosing(code_text) 70 | oldClass(code_text) <- "shinyMetaDeparsed" 71 | code_text 72 | } 73 | 74 | # Quosures deparse strangely (they look like formulas). For shinymeta's 75 | # deparsing purposes we just want them to be exprs. 76 | quo_to_expr <- function(expr) { 77 | if (rlang::is_quosure(expr)) { 78 | rlang::quo_get_expr(expr) 79 | } else { 80 | expr 81 | } 82 | } 83 | 84 | remove_meta_classes <- function(expr) { 85 | remove_class(expr, c("shinyMetaString", "shinyMetaExpr")) 86 | } 87 | 88 | deparse_flatten <- function(expr, width = 500L) { 89 | if (rlang::is_call(expr, "{")) { 90 | paste0(vapply(expr[-1], deparse_flatten, character(1)), collapse = "\n") 91 | } else { 92 | # TODO: should this have `backtick = TRUE`? 93 | paste0(deparse(expr, width.cutoff = width), collapse = "\n") 94 | } 95 | } 96 | 97 | # Neither deparse() nor styler will go out of their way to break on %>%, and 98 | # deparse will break on other random operators instead. This function inserts 99 | # newlines after %>%, and replaces newlines that follow operators or commas with 100 | # a single space. The resulting code string will not contain indentation, and 101 | # must be processed further to be considered readable. 102 | rebreak <- function(str) { 103 | str <- paste(str, collapse = "\n") 104 | tokens <- sourcetools::tokenize_string(str) 105 | tokens$value <- paste0( 106 | tokens$value, 107 | ifelse( 108 | tokens$type == "operator" & tokens$value == "%>%", 109 | "\n", 110 | "" 111 | ) 112 | ) 113 | # if the token appearing after a line-break is a 114 | # comma/operator, remove the line-break 115 | operator_newline <- grepl("\n", tokens$value) & 116 | tokens$type == "whitespace" & 117 | c(FALSE, head(tokens$type %in% c("comma", "operator"), -1)) 118 | tokens$value[operator_newline] <- " " 119 | new_str <- paste(tokens$value, collapse = "") 120 | gsub("\\s*\\r?\\n\\s*", "\n", new_str) 121 | } 122 | 123 | # If a deparsed code string contains a line that's enclosed in our special 124 | # identifiers, then turn it into a comment 125 | comment_remove_enclosing <- function(x) { 126 | if (!is.character(x) || length(x) > 1) { 127 | stop("Expected a string (character vector of length 1).") 128 | } 129 | txt <- strsplit(x, "\n")[[1]] 130 | comment_index <- grep(paste0('^\\s*"', comment_start), txt) 131 | if (!length(comment_index)) return(txt) 132 | txt[comment_index] <- sub(paste0('^(\\s*)"', comment_start), "\\1", txt[comment_index]) 133 | txt[comment_index] <- sub(paste0(comment_end, '"$'), "", txt[comment_index]) 134 | # e.g. `deparse("a \"string\"")` -> "\"a \\\"string\\\"\"" 135 | txt[comment_index] <- gsub("\\\"", "\"", txt[comment_index], fixed = TRUE) 136 | paste(txt, collapse = "\n") 137 | } 138 | -------------------------------------------------------------------------------- /tests/testthat/test-comments.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | 3 | capturePrint <- function(x) { 4 | capture.output(print(x)) 5 | } 6 | 7 | describe("metaReactive", isolate({ 8 | 9 | it("works", { 10 | mr <- metaReactive({ 11 | "# a comment" 12 | 1 + 1 13 | }) 14 | expected_output <- c("# a comment", "1 + 1") 15 | actual_output <- capturePrint(withMetaMode(mr())) 16 | expect_equal(expected_output, actual_output) 17 | }) 18 | 19 | it("works with metaReactive2", { 20 | mr2 <- metaReactive2({ 21 | 4 + 4 22 | metaExpr({ 23 | "# a comment" 24 | 1 + 1 25 | }) 26 | }) 27 | expected_output <- c("# a comment", "mr2 <- 1 + 1") 28 | actual_output <- capturePrint(expandChain(invisible(mr2()))) 29 | expect_equal(expected_output, actual_output) 30 | }) 31 | 32 | it("throws warning if mis-specified", { 33 | mrw <- metaReactive({ 34 | 1 + 1 35 | "# not a comment" 36 | }) 37 | expected_output <- c("1 + 1", "\"# not a comment\"") 38 | expect_warning( 39 | actual_output <- capturePrint(withMetaMode(mrw())), 40 | "comment can not appear as the last child" 41 | ) 42 | expect_equal(expected_output, actual_output) 43 | }) 44 | 45 | })) 46 | 47 | 48 | describe("metaObserve", isolate({ 49 | 50 | it("works", { 51 | mo <- metaObserve({ 52 | "# a comment" 53 | 1 + 1 54 | }) 55 | expected_output <- c("# a comment", "1 + 1") 56 | actual_output <- capturePrint(expandChain(mo())) 57 | expect_equal(expected_output, actual_output) 58 | }) 59 | 60 | it("works with metaObserve2", { 61 | mo2 <- metaObserve2({ 62 | 4 + 4 63 | metaExpr({ 64 | "# a comment" 65 | 1 + 1 66 | }) 67 | }) 68 | expected_output <- c("# a comment", "1 + 1") 69 | actual_output <- capturePrint(withMetaMode(mo2())) 70 | expect_equal(expected_output, actual_output) 71 | }) 72 | 73 | it("throws warning if mis-specified", { 74 | mow <- metaObserve({ 75 | 1 + 1 76 | "# a comment" 77 | }) 78 | expected_output <- c("1 + 1", "\"# a comment\"") 79 | expect_warning( 80 | actual_output <- capturePrint(withMetaMode(mow())), 81 | "comment can not appear as the last child" 82 | ) 83 | expect_equal(expected_output, actual_output) 84 | }) 85 | 86 | })) 87 | 88 | 89 | describe("metaRender", isolate({ 90 | 91 | it("works", { 92 | mrt <- metaRender(renderText, { 93 | "# a comment" 94 | 1 + 1 95 | }) 96 | expected_output <- c("# a comment", "1 + 1") 97 | actual_output <- capturePrint(withMetaMode(mrt())) 98 | expect_equal(expected_output, actual_output) 99 | }) 100 | 101 | it("works with metaRender2", { 102 | mrt2 <- metaRender2(renderText, { 103 | 4 + 4 104 | metaExpr({ 105 | "# a comment" 106 | 1 + 1 107 | }) 108 | }) 109 | expected_output <- c("# a comment", "1 + 1") 110 | actual_output <- capturePrint(expandChain(mrt2())) 111 | expect_equal(expected_output, actual_output) 112 | }) 113 | 114 | it("throws warning if mis-specified", { 115 | mrw <- metaRender(renderText, { 116 | 1 + 1 117 | "# not a comment" 118 | }) 119 | expected_output <- c("1 + 1", "\"# not a comment\"") 120 | expect_warning( 121 | actual_output <- capturePrint(withMetaMode(mrw())), 122 | "comment can not appear as the last child" 123 | ) 124 | expect_equal(expected_output, actual_output) 125 | }) 126 | 127 | })) 128 | 129 | describe("various edge cases", isolate({ 130 | mr <- metaReactive({ 131 | "# Escaped \"quotes\" should \'be' supported" 132 | NULL 133 | }) 134 | mr2 <- metaReactive({ 135 | '# Escaped \"quotes" should \'be\' supported' 136 | NULL 137 | }) 138 | expected <- c( 139 | "# Escaped \"quotes\" should 'be' supported", 140 | "NULL" 141 | ) 142 | expect_equal( 143 | capturePrint(withMetaMode(mr())), expected 144 | ) 145 | expect_equal( 146 | capturePrint(withMetaMode(mr2())), expected 147 | ) 148 | mr <- metaReactive({ 149 | " # This shouldn't count as a comment " # Leading whitespace 150 | " '# This either' " # Nested quote 151 | " \"# Or this\" " # Nested dbl-quote 152 | }) 153 | expect_equal( 154 | capturePrint(withMetaMode(mr())), 155 | c( 156 | deparse(" # This shouldn't count as a comment "), 157 | deparse(" '# This either' "), 158 | deparse(" \"# Or this\" ") 159 | ) 160 | ) 161 | mr <- metaReactive({ 162 | "# This should be a comment" 163 | paste( 164 | "# But this should not", 165 | "be a comment" 166 | ) 167 | }) 168 | expect_equal( 169 | capturePrint(withMetaMode(mr())), 170 | c( 171 | "# This should be a comment", 172 | "paste(\"# But this should not\", \"be a comment\")" 173 | ) 174 | ) 175 | 176 | 177 | mr <- metaReactive({ 178 | message("got here") 179 | "# This is not a comment" 180 | }) 181 | 182 | mr2 <- metaReactive({ 183 | ..(mr()) 184 | NULL 185 | }) 186 | 187 | expect_warning( 188 | out <- capturePrint(withMetaMode(mr2())), 189 | "comment can not appear as the last child" 190 | ) 191 | 192 | expect_equal( 193 | out, 194 | c( 195 | "message(\"got here\")", 196 | "\"# This is not a comment\"", 197 | "NULL" 198 | ) 199 | ) 200 | 201 | x <- metaReactive({ 202 | "# This comment should appear above the assignment" 203 | 1 + 1 204 | }) 205 | 206 | out <- capturePrint(expandChain(invisible(x()))) 207 | expect_equal( 208 | out, 209 | c( 210 | "# This comment should appear above the assignment", 211 | "x <- 1 + 1" 212 | ) 213 | ) 214 | 215 | x2 <- metaReactive({ 216 | "# This comment should appear above the assignment" 217 | ..(x()) + 1 218 | }) 219 | expect_equal( 220 | capturePrint(expandChain(invisible(x2()))), 221 | c( 222 | "# This comment should appear above the assignment", 223 | "x <- 1 + 1", 224 | "# This comment should appear above the assignment", 225 | "x2 <- x + 1" 226 | ) 227 | ) 228 | 229 | # TODO: What should happen if \n appears in a string-comment? 230 | })) 231 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | #' Wrap expressions with a function call 2 | #' 3 | #' Creates a function call with the given function, using the quoted expressions 4 | #' as unnamed arguments. 5 | #' 6 | #' @param func Fully-qualified function (i.e. base::head or shiny:::withLocalOptions) 7 | #' @param ... Language objects to pass to the function 8 | #' @noRd 9 | wrapExpr <- function(func, ...) { 10 | func <- substitute(func) 11 | 12 | as.call(list( 13 | if (is.call(func)) as.call(func) else as.symbol(func), 14 | ... 15 | )) 16 | } 17 | 18 | # Expands (i.e. evaluated) all ..() function calls in an expression 19 | # which mainly useful for unquoting away reactive inputs/values 20 | # when generating code in meta-mode 21 | expandExpr <- function(expr, env) { 22 | walk_ast(expr, preorder = TRUE, function(x) { 23 | if (!rlang::is_call(x, "..")) return(x) 24 | 25 | # make sure ..() contains a single unnamed argument 26 | if (!rlang::is_call(x, "..", n = 1)) { 27 | stop("..() must contain a single argument.") 28 | } 29 | if (!is.null(names(x))) { 30 | stop("..() cannot contain a named argument: '", names(x)[2], "'.") 31 | } 32 | # unquote 33 | x <- eval(x[[2]], list(), env) 34 | # Expand symbols to code that generates that symbol, as opposed 35 | # to just the symbol itself 36 | if (inherits(x, "shinymeta_symbol")) { 37 | as.symbol(x) 38 | } else if (is.symbol(x)) { 39 | call("as.symbol", as.character(x)) 40 | } else { 41 | x 42 | } 43 | }) 44 | } 45 | 46 | cleanExpr <- function(expr) { 47 | walk_ast(expr, function(x) { 48 | if (rlang::is_call(x, "..", n = 1) && is.null(names(x))) { 49 | x <- x[[2]] 50 | } 51 | x 52 | }) 53 | } 54 | 55 | 56 | strip_outer_brace <- function(expr) { 57 | while (rlang::is_call(expr, "{", n = 1)) { 58 | expr <- expr[[2]] 59 | } 60 | expr 61 | } 62 | 63 | # Given the srcref to a metaReactive expression, attempts to figure out what the 64 | # name of the reactive expression is. This isn't foolproof, as it literally 65 | # scans the line of code that started the reactive block and looks for something 66 | # that looks like assignment. If we fail, fall back to a default value (likely 67 | # the block of code in the body of the reactive). 68 | mrexprSrcrefToLabel <- function(srcref, defaultLabel) { 69 | if (is.null(srcref)) 70 | return(defaultLabel) 71 | 72 | srcfile <- attr(srcref, "srcfile", exact = TRUE) 73 | if (is.null(srcfile)) 74 | return(defaultLabel) 75 | 76 | if (is.null(srcfile$lines)) 77 | return(defaultLabel) 78 | 79 | lines <- srcfile$lines 80 | # When pasting at the Console, srcfile$lines is not split 81 | if (length(lines) == 1) { 82 | lines <- strsplit(lines, "\n")[[1]] 83 | } 84 | 85 | if (length(lines) < srcref[1]) { 86 | return(defaultLabel) 87 | } 88 | 89 | firstLineIdx <- srcref[1] 90 | firstLine <- substring(lines[firstLineIdx], 1, srcref[2] - 1) 91 | while (!grepl("metaReactive", firstLine) & firstLineIdx >= 1) { 92 | firstLineIdx <- firstLineIdx - 1 93 | firstLine <- lines[firstLineIdx] 94 | } 95 | 96 | m <- regexec("(.*)(<-|=)\\s*(?:shinymeta::)?metaReactive2?\\s*\\(", firstLine) 97 | if (m[[1]][1] == -1) { 98 | return(defaultLabel) 99 | } 100 | sym <- regmatches(firstLine, m)[[1]][2] 101 | res <- try(parse(text = sym), silent = TRUE) 102 | if (inherits(res, "try-error")) 103 | return(defaultLabel) 104 | 105 | if (length(res) != 1) 106 | return(defaultLabel) 107 | 108 | return(as.character(res)) 109 | } 110 | 111 | # For R 3.3/3.4 112 | is_false <- function(x) { 113 | is.logical(x) && length(x) == 1L && !is.na(x) && !x 114 | } 115 | 116 | # Version of knit_expand that doesn't search the parent frame, and detects when 117 | # expansion results in unsafe Rmd input (i.e. the evaluation of {{expr}} should 118 | # never introduce a chunk boundary or even a new inline chunk) 119 | knit_expand_safe <- function(file, vars = list(), text = xfun::read_utf8(file), delim = c("{{", "}}")) { 120 | # The approach we take here is to detect all knitr md patterns before and 121 | # after expansion, and fail if anything was either added or removed. We tried 122 | # just testing the output of each {{expansion}} for the patterns, but, that 123 | # doesn't catch cases where an inline.code is started in one expansion and 124 | # finished in another (see test in test-report.R). 125 | 126 | # Code chunk delimiter regexes 127 | # TODO: Can we assume `md`? 128 | patterns <- unname(unlist(knitr::all_patterns$md)) 129 | 130 | matches_before <- count_matches_by_pattern(text, patterns) 131 | 132 | # Create an environment that contains nothing but the variables we want to 133 | # make available for template expansion, plus .GlobalEnv. 134 | eval_envir <- list2env(vars, parent = .GlobalEnv) 135 | 136 | # Use a knitr hook to ensure that only the ... arguments plus stuff in the 137 | # global environment are available when evaluating {{/}} expressions. 138 | orig_eval_inline <- knitr::knit_hooks$get("evaluate.inline") 139 | knitr::knit_hooks$set(evaluate.inline = function(code, envir) { 140 | # ignore envir, as it includes the parent frame of `knit_expand` which we 141 | # explicitly do not want to be used for evaluation--only ... arguments to 142 | # knit_expand_safe should be used. 143 | orig_eval_inline(code, eval_envir) 144 | }) 145 | on.exit(knitr::knit_hooks$set(evaluate.inline = orig_eval_inline), add = TRUE) 146 | 147 | res <- knitr::knit_expand(text = text, delim = delim) 148 | 149 | matches_after <- count_matches_by_pattern(xfun::split_lines(res), patterns) 150 | 151 | if (!identical(matches_before, matches_after)) { 152 | # The process of knit_expand-ing introduced new (or removed existing?) code 153 | # chunks 154 | stop("Can't build report--user input values must not contain code chunk delimiters") 155 | } 156 | 157 | res 158 | } 159 | 160 | # Returns a vector of length `length(pattern)`, where each element is the total 161 | # number of times the corresponding pattern element was found in the character 162 | # vector `string`. 163 | # 164 | # > count_matches_by_pattern(c("abc12", "def34", "5"), c("[a-z]", "[0-9]")) 165 | # [1] c(6, 5) 166 | count_matches_by_pattern <- function(string, pattern) { 167 | vapply(pattern, function(regex) { 168 | matches <- stringr::str_locate_all(string, regex) 169 | sum(vapply(matches, nrow, integer(1))) 170 | }, integer(1), USE.NAMES = FALSE) 171 | } 172 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # shinymeta 2 | 3 | 4 | [![R build status](https://github.com/rstudio/shinymeta/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/rstudio/shinymeta/actions) 5 | [![CRAN status](https://www.r-pkg.org/badges/version/shinymeta)](https://cran.r-project.org/package=shinymeta) 6 | 7 | 8 | The **shinymeta** R package provides tools for capturing logic in a Shiny app and exposing it as code that can be run outside of Shiny (e.g., from an R console). It also provides tools for bundling both the code and results to the end user. 9 | 10 | ## Installation 11 | 12 | Install the stable release of `shinymeta` on CRAN: 13 | 14 | ```r 15 | install.packages("shinymeta") 16 | ``` 17 | 18 | Or, install the development version with: 19 | 20 | ```r 21 | remotes::install_github("rstudio/shinymeta") 22 | ``` 23 | 24 | ## Generating code with shinymeta 25 | 26 | In short, **shinymeta** provides counterparts to Shiny's reactive building blocks (e.g., `reactive()` -> `metaReactive()`, `observe()` -> `metaObserve()`, `render()` -> `metaRender()`) that have the added ability to capture and expose the logic needed to recreate their current state *outside of the Shiny runtime*. Once the appropriate logic has been captured by these meta-counterparts and reactive reads (e.g., `input$var`, `var()`) have been marked by a special `..()` operator, then `expandChain()` can produce code to replicate the state of a particular meta-counterpart (e.g., `output$Summary`). 27 | 28 | ```r 29 | library(shiny) 30 | library(shinymeta) 31 | 32 | ui <- fluidPage( 33 | selectInput("var", label = "Choose a variable", choices = names(cars)), 34 | verbatimTextOutput("Summary"), 35 | verbatimTextOutput("code") 36 | ) 37 | 38 | server <- function(input, output) { 39 | var <- metaReactive({ 40 | cars[[..(input$var)]] 41 | }) 42 | output$Summary <- metaRender(renderPrint, { 43 | summary(..(var())) 44 | }) 45 | output$code <- renderPrint({ 46 | expandChain(output$Summary()) 47 | }) 48 | } 49 | 50 | shinyApp(ui, server) 51 | ``` 52 | 53 |
54 | 55 |
56 | 57 | For more details, explanation, and overview **shinymeta** features, see the article on [code generation](https://rstudio.github.io/shinymeta/articles/code-generation.html) as well as [code distribution](https://rstudio.github.io/shinymeta/articles/code-distribution.html). 58 | 59 | ## Breaking changes in shinymeta 0.2.0 60 | 61 | On August 6, 2019, we introduced a major syntax change into shinymeta, that is not compatible with the previous syntax. If you're here after watching @jcheng5's [useR2019 talk](https://www.youtube.com/watch?v=5KByRC6eqC8) or reading @zappingseb's [blog post](https://medium.com/data-science/shinymeta-a-revolution-for-reproducibility-bfda6b329f68), please be aware that the `!!` operator has been replaced with a `..()` function. See [this page](https://github.com/rstudio/shinymeta/wiki/Syntax-changes-for-shinymeta-0.2.0) for details. 62 | 63 | ## A motivating example 64 | 65 | Below is a screen-recording of a Shiny app which allows you to obtain CRAN download statistics for any combination of CRAN packages, look at those downloads using different aggregations, and produce a Rmd-based report _with code to reproduce the visualization_. This Shiny app is different from most in that it generates R code to reproduce what the user sees in the Shiny app (i.e., notice how the generated report reflects the user's input). 66 | 67 | 68 | 69 | We hope this example helps illustrate and inspire several reasons why you might want to generate standalone R code that mimics logic in your Shiny app: 70 | 71 | * **Automation**: Shiny apps often use data that changes over time: stock quotes, sensor readings, centralized databases, etc. By providing users with reproducible R code, you enable them to take that logic into other workflows, such as creating a [periodic R Markdown email using RStudio Connect](https://support.posit.co/hc/en-us/articles/221266427-Scheduling-emailed-reports-in-Posit-Connect) (e.g., the R code generated by the Shiny app above has been tailored so that anyone can re-run the code to acquire the latest download statistics). 72 | 73 | * **Transparency**: By generating code that exposes the core logic of your **shiny** app, you make things more transparent for yourself and others, which has numerous benefits: 74 | 75 | * **Reassurance**: In the domain of data analysis, it's usually enough hard to know exactly how a result is derived, and be confident that it's 100% correct. Unfortunately, wrapping your analysis code in a user interface like Shiny make the situation even worse: the analysis code is now embedded inside a larger system making the overall logic even more error prone and difficult to fully understand. Export the core logic of your analysis can help reassure others (and yourself!) that your work is correct. 76 | 77 | * **Education**: For example, in the classroom, a student might use a Shiny app interactively to gain intuitive understanding of a statistical concept, then use the code to learn how to use the corresponding function from their own R scripts. 78 | 79 | * **Enabling**: Shiny is great for enabling others to interface with an R script you've written, but what if your users wish to explore things that your interface doesn't allow for? By exposing the core logic of your app, you make it easier for motivated users to modify and build upon your work in ways you never thought about. 80 | 81 | * **Documentation**: This one is especially relevant for exploratory analysis apps that allow you to derive insight from a dataset. A great example is the [ANOVA example app](https://github.com/cpsievert/DIY_ANOVA), where you can upload a dataset, run an ANOVA analysis, then download a report with all ANOVA results as well as the code to reproduce it. 82 | 83 | * **Permanence**: Using a Shiny app can have an ephemeral feeling to it; what happens in the future if the server goes down, or the app's features change? With a reproducible report, your users can download a more permanent artifact that can be saved locally. 84 | 85 | 86 | ## Acknowledgements 87 | 88 | Many people projects provided motivation, inspiration, and ideas that have lead to **shinymeta**. Thanks especially to Adrian Waddell for inspiring the over-overarching metaprogramming approach and Doug Kelkhoff for his work on **scriptgloss**. Also thanks to Eric Nantz and Xiao Ni for providing feedback and insight on potential applications. We'd also like to acknowledge and highlight other work towards this same goal such as (Eric Hare and Andee Kaplan) and (Vincent Nijs). 89 | -------------------------------------------------------------------------------- /R/report.R: -------------------------------------------------------------------------------- 1 | # TODO: Unit tests for this whole file 2 | 3 | #' Produce a zip bundle of code and results 4 | #' 5 | #' @param code A language object. 6 | #' @param output_zip_path A filename for the resulting zip bundle. 7 | #' @param script_name A name for the R script in the zip bundle. 8 | #' @param include_files A named list consisting of additional files that should 9 | #' be included in the zip bundle. The element names indicate the destination 10 | #' path within the bundle, specified as a relative path; the element values 11 | #' indicate the path to the actual file currently on disk, specified as either 12 | #' a relative or absolute path. 13 | #' @param render Whether or not to call [rmarkdown::render()] on the R script. 14 | #' @param render_args Arguments to provide to [rmarkdown::render()]. 15 | #' @return The path to a generated file. 16 | #' @export 17 | buildScriptBundle <- function(code = NULL, output_zip_path, script_name = "script.R", 18 | include_files = list(), render = TRUE, render_args = list()) { 19 | 20 | with_progress_obj(function(progress) { 21 | progress$set(value = 0) 22 | progress$set(message = "Generating code") 23 | 24 | if (is.language(code)) { 25 | code <- paste(formatCode(code), collapse = "\n") 26 | } 27 | 28 | build_bundle(code, script_name, output_zip_path, 29 | include_files = include_files, render = render, 30 | render_args = render_args, progress = progress) 31 | }) 32 | } 33 | 34 | 35 | #' @param report_template Filename of an Rmd template to be expanded by [knitr::knit_expand()]. 36 | #' @param vars A named list of variables passed along to `...` in [knitr::knit_expand()]. 37 | #' @export 38 | #' @rdname buildScriptBundle 39 | #' @seealso knitr::knit_expand 40 | #' 41 | buildRmdBundle <- function(report_template, output_zip_path, vars = list(), 42 | include_files = list(), render = TRUE, render_args = list()) { 43 | 44 | force(report_template) 45 | force(vars) 46 | 47 | with_progress_obj(function(progress) { 48 | progress$set(value = 0) 49 | progress$set(message = "Generating code") 50 | 51 | if (is.list(vars)) { 52 | vars <- lapply(vars, function(x) { 53 | if (is.language(x)) { 54 | paste(formatCode(x), collapse = "\n") 55 | } else { 56 | x 57 | } 58 | }) 59 | } 60 | 61 | progress$set(value = 0.1) 62 | progress$set(message = "Expanding Rmd template") 63 | 64 | rmd_source <- knit_expand_safe(report_template, vars = vars) 65 | rmd_filename <- template_rename(report_template, "Rmd") 66 | 67 | build_bundle(rmd_source, rmd_filename, output_zip_path, 68 | include_files = include_files, render = render, 69 | render_args = render_args, progress = progress) 70 | }) 71 | } 72 | 73 | build_bundle <- function(input_src, input_filename, output_zip_path, 74 | include_files = list(), render = TRUE, render_args = list(), progress) { 75 | 76 | force(input_src) 77 | force(input_filename) 78 | force(output_zip_path) 79 | force(include_files) 80 | force(render) 81 | force(render_args) 82 | 83 | # TODO: validate args 84 | progress$set(value = 0.2) 85 | progress$set(message = "Adding items to zip archive") 86 | 87 | x <- zip_archive() 88 | 89 | dest_filename_full <- fs::path(archive_basedir(x), input_filename) 90 | 91 | # TODO: Verify UTF-8 encoding is preserved 92 | writeLines(input_src, dest_filename_full) 93 | 94 | add_items(x, !!!include_files) 95 | 96 | progress$set(value = 0.3) 97 | 98 | if (render) { 99 | progress$set(message = "Rendering report") 100 | render_with_args(dest_filename_full, render_args) 101 | } 102 | 103 | 104 | progress$set(value = 0.9) 105 | progress$set(message = "Compressing bundle") 106 | archive <- build_archive(x, output_zip_path) 107 | progress$set(value = 1) 108 | archive 109 | } 110 | 111 | 112 | with_progress_obj <- function(callback) { 113 | # Note that `session` may be NULL. 114 | session <- shiny::getDefaultReactiveDomain() 115 | if (!is.null(session$userData$shinymeta_last_progress)) { 116 | # If the last progress object we created for this session is still visible, 117 | # close it. This would be in the case of an error, we never auto-dismiss in 118 | # that case. 119 | suppressWarnings(session$userData$shinymeta_last_progress$close()) 120 | } 121 | 122 | progress <- make_progress() 123 | # Register our newly created progress object. 124 | session$userData$shinymeta_last_progress <- progress 125 | 126 | tryCatch(shiny::captureStackTraces({ 127 | callback(progress) 128 | progress$close() 129 | session$userData$shinymeta_last_progress <- NULL 130 | }), error = function(err) { 131 | progress$set(value = 1, message = "An error has occurred:", 132 | detail = conditionMessage(err)) 133 | stop(err) 134 | }) 135 | } 136 | 137 | render_with_args <- function(input_file, render_args = list(), switch_dirs = TRUE, fork = TRUE) { 138 | 139 | if (switch_dirs) { 140 | old_wd <- getwd() 141 | setwd(fs::path_dir(input_file)) 142 | on.exit(setwd(old_wd)) 143 | } 144 | 145 | if (fork) { 146 | callr::r( 147 | function(...) rmarkdown::render(...), 148 | # https://github.com/rstudio/rmarkdown/issues/1204#issuecomment-344884823 149 | args = c(list(input_file, envir = globalenv()), render_args) 150 | ) 151 | } else { 152 | do.call(rmarkdown::render, c(list(input_file), render_args), quote = TRUE) 153 | } 154 | } 155 | 156 | # /foo/report.Rmd.in => report.Rmd 157 | # /foo/report.Rmd => report.Rmd 158 | # /foo/report => report.Rmd 159 | # /foo/report.foo.bar.Rmd.in => report.foo.bar.Rmd 160 | # /foo/report.foo.bar.Rmd => report.foo.bar.Rmd 161 | template_rename <- function(input_template, extension = "Rmd") { 162 | stopifnot(is.character(extension) && length(extension) == 1 && identical(TRUE, nzchar(extension))) 163 | 164 | filename <- fs::path_ext_remove(fs::path_file(input_template)) 165 | if (tolower(fs::path_ext(filename)) == tolower(extension)) { 166 | filename 167 | } else { 168 | paste0(filename, ".", extension) 169 | } 170 | } 171 | 172 | # Create shiny::Progress if possible, otherwise a dummy progress object 173 | make_progress <- function(...) { 174 | session <- shiny::getDefaultReactiveDomain() 175 | if (!is.null(session)) { 176 | shiny::Progress$new(session = session, ...) 177 | } else { 178 | # Return a dummy progress object 179 | nothing <- function(...) {} 180 | list( 181 | set = nothing, 182 | inc = nothing, 183 | getMin = nothing, 184 | getMax = nothing, 185 | getValue = nothing, 186 | close = nothing, 187 | clone = nothing 188 | ) 189 | } 190 | } 191 | -------------------------------------------------------------------------------- /inst/examples/contingency/app.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinymeta) 3 | library(plotly) 4 | library(dplyr) 5 | library(ggmosaic) 6 | 7 | ui <- fluidPage( 8 | titlePanel("Contingency table explorer"), 9 | sidebarLayout( 10 | sidebarPanel( 11 | selectInput( 12 | "data", "Choose a dataset", 13 | c( 14 | "Flying Etiquette" = "fly", 15 | "Happiness" = "happy", 16 | "Upload your own" = "custom" 17 | ), 18 | selected = "happy" 19 | ), 20 | conditionalPanel( 21 | "input.data == 'custom'", 22 | # TODO: option to upload pre-aggregated counts?! 23 | fileInput("data_file", "Upload dataset") 24 | ), 25 | uiOutput("vars"), 26 | checkboxInput("na.rm", "Exclude missing values?", value = TRUE), 27 | downloadButton("full_code", "Full report", icon = icon("code")) 28 | ), 29 | mainPanel( 30 | tabsetPanel( 31 | tabPanel( 32 | "Plot", 33 | div( 34 | plotlyOutput("plot"), 35 | downloadButton("plot_code", "", icon = icon("code")) 36 | ) 37 | ), 38 | 39 | tabPanel( 40 | "Model", 41 | div( 42 | checkboxInput("simulate", "Compute p-values by Monte Carlo simulation?"), 43 | verbatimTextOutput("model"), 44 | downloadButton("model_code", "", icon = icon("code")) 45 | ) 46 | ), 47 | tabPanel( 48 | "Counts", 49 | div(tableOutput("table")) 50 | ) 51 | ) 52 | ) 53 | ) 54 | ) 55 | 56 | server <- function(input, output, session) { 57 | 58 | getData <- metaReactive({ 59 | d <- switch( 60 | input$data, 61 | fly = fly, 62 | happy = happy, 63 | custom = if (length(input$data_file)) read.csv(input$data_file$datapath) 64 | ) 65 | if (is.null(d)) return(NULL) 66 | d <- mutate_all(d, as.character) 67 | if (isTRUE(input$na.rm)) na.omit(d) else d 68 | }) 69 | 70 | getVars <- metaReactive({ 71 | switch( 72 | input$data, 73 | fly = list(y = "DoYouRecline", x = "UseElectronicsDuringTakeoff"), 74 | happy = list(y = "happy", x = "marital"), 75 | custom = list(y = getData()[1], x = getData()[2]) 76 | ) 77 | }) 78 | 79 | output$vars <- renderUI({ 80 | validate( 81 | need(ncol(getData()) >= 2, "Need a dataset with at least two discrete variables") 82 | ) 83 | d <- getData() 84 | div( 85 | varSelectInput( 86 | "yvar", "Response variable", 87 | d, selected = getVars()$y 88 | ), 89 | varSelectInput( 90 | "xvar", "Explanatory variable", 91 | d, selected = getVars()$x 92 | ) 93 | ) 94 | }) 95 | 96 | counts_long <- metaReactive2({ 97 | req(input$xvar, input$yvar) 98 | 99 | # To increase reproducibility of the code in the 100 | # report download, we'll provide the result of 101 | # getData() in the download and have the code 102 | # import in that R object 103 | metaExpr({ 104 | ..(getData()) %>% 105 | count(!!..(input$xvar), !!..(input$yvar)) 106 | }) 107 | }) 108 | 109 | counts_wide <- metaReactive2({ 110 | req(counts_long()) 111 | 112 | metaExpr({ 113 | ..(counts_long()) %>% 114 | tidyr::pivot_wider( 115 | names_from = !!..(input$xvar), 116 | values_from = n, 117 | values_fill = list(n = 0) 118 | ) 119 | }) 120 | }) 121 | 122 | counts_raw <- metaReactive2({ 123 | req(counts_wide()) 124 | 125 | metaExpr({ 126 | ..(counts_wide()) %>% 127 | select(-1) %>% 128 | as.matrix() 129 | }) 130 | }) 131 | 132 | output$table <- metaRender2(renderTable, { 133 | validate(need(counts_wide(), "Choose some variables")) 134 | metaExpr({ 135 | ..(counts_wide()) 136 | }) 137 | }) 138 | 139 | output$plot <- metaRender2(renderPlotly, { 140 | validate( 141 | need(getData(), "Choose a dataset"), 142 | need(input$yvar, "Choose a response"), 143 | need(input$xvar, "Choose a predictor") 144 | ) 145 | 146 | metaExpr({ 147 | gg_plot <- ggplot(..(getData())) + 148 | geom_mosaic( 149 | aes( 150 | x = product(!!..(input$xvar)), 151 | fill = !!..(input$yvar) 152 | ) 153 | ) + 154 | theme_bw() + 155 | labs(x = NULL, y = NULL) + 156 | theme( 157 | axis.text.x = element_text( 158 | angle = 45, vjust = 0.95, hjust = 1 159 | ) 160 | ) 161 | 162 | ggplotly(gg_plot) %>% 163 | config(displayModeBar = FALSE) 164 | }) 165 | }) 166 | 167 | output$model <- metaRender2(renderPrint, { 168 | validate(need(counts_raw(), "Choose some variables")) 169 | 170 | metaExpr({ 171 | chisq.test(..(counts_raw()), simulate.p.value = isTRUE(..(input$simulate))) 172 | }) 173 | }) 174 | 175 | output$plot_code <- downloadHandler( 176 | "plot.zip", 177 | content = function(out) { 178 | saveRDS(getData(), "data.rds") 179 | on.exit(unlink("data.rds"), add = TRUE) 180 | 181 | ec <- newExpansionContext() 182 | ec$substituteMetaReactive(getData, function() { 183 | metaExpr({readRDS("data.rds")}) 184 | }) 185 | 186 | code <- expandChain( 187 | quote({ 188 | library(plotly) 189 | library(dplyr) 190 | library(ggmosaic) 191 | }), 192 | output$plot(), 193 | .expansionContext = ec 194 | ) 195 | 196 | buildRmdBundle( 197 | "plot.Rmd", out, 198 | vars = list(code = code), 199 | include_files = c("data.rds") 200 | ) 201 | } 202 | ) 203 | 204 | 205 | output$model_code <- downloadHandler( 206 | "model.zip", 207 | content = function(out) { 208 | saveRDS(getData(), "data.rds") 209 | on.exit(unlink("data.rds"), add = TRUE) 210 | 211 | ec <- newExpansionContext() 212 | ec$substituteMetaReactive(getData, function() { 213 | metaExpr({readRDS("data.rds")}) 214 | }) 215 | 216 | code <- expandChain( 217 | quote({ 218 | library(plotly) 219 | library(dplyr) 220 | library(ggmosaic) 221 | }), 222 | output$model(), 223 | .expansionContext = ec 224 | ) 225 | 226 | buildRmdBundle( 227 | "model.Rmd", out, 228 | vars = list( 229 | code = code, 230 | xvar = deparse(input$xvar), 231 | yvar = deparse(input$yvar) 232 | ), 233 | include_files = "data.rds" 234 | ) 235 | } 236 | ) 237 | 238 | output$full_code <- downloadHandler( 239 | "full.zip", 240 | content = function(out) { 241 | 242 | saveRDS(getData(), "data.rds") 243 | on.exit(unlink("data.rds"), add = TRUE) 244 | 245 | ec <- newExpansionContext() 246 | ec$substituteMetaReactive(getData, function() { 247 | metaExpr({readRDS("data.rds")}) 248 | }) 249 | 250 | code <- expandChain( 251 | quote({ 252 | library(plotly) 253 | library(dplyr) 254 | library(ggmosaic) 255 | }), 256 | output$plot(), 257 | output$model(), 258 | .expansionContext = ec 259 | ) 260 | 261 | buildRmdBundle( 262 | "full.Rmd", out, 263 | vars = list(code = code), 264 | include_files = "data.rds" 265 | ) 266 | } 267 | ) 268 | 269 | } 270 | 271 | shinyApp(ui, server) 272 | -------------------------------------------------------------------------------- /man/expandChain.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/metareactive.R 3 | \name{expandChain} 4 | \alias{expandChain} 5 | \alias{newExpansionContext} 6 | \title{Expand code objects} 7 | \usage{ 8 | newExpansionContext() 9 | 10 | expandChain(..., .expansionContext = newExpansionContext()) 11 | } 12 | \arguments{ 13 | \item{...}{All arguments must be unnamed, and must be one of: 1) calls to 14 | meta-reactive objects, 2) comment string (e.g. \code{"# A comment"}), 3) 15 | language object (e.g. \code{quote(print(1 + 1))}), or 4) \code{NULL} (which will be 16 | ignored). Calls to meta-reactive objects can optionally be \code{\link[=invisible]{invisible()}}, 17 | see Details.} 18 | 19 | \item{.expansionContext}{Accept the default value if calling \code{expandChain} a 20 | single time to generate a corpus of code; or create an expansion context 21 | object using \code{newExpansionContext()} and pass it to multiple related calls 22 | of \code{expandChain}. See Details.} 23 | } 24 | \value{ 25 | The return value of \code{expandChain()} is a code object that's suitable for 26 | printing or passing to \code{\link[=displayCodeModal]{displayCodeModal()}}, \code{\link[=buildScriptBundle]{buildScriptBundle()}}, or 27 | \code{\link[=buildRmdBundle]{buildRmdBundle()}}. 28 | 29 | The return value of \code{newExpansionContext} is an object that should be 30 | passed to multiple \code{expandChain()} calls. 31 | } 32 | \description{ 33 | Use \code{expandChain} to write code out of one or more metaReactive objects. 34 | Each meta-reactive object (expression, observer, or renderer) will cause not 35 | only its own code to be written, but that of its dependencies as well. 36 | } 37 | \details{ 38 | There are two ways to extract code from meta objects (i.e. \code{\link[=metaReactive]{metaReactive()}}, 39 | \code{\link[=metaObserve]{metaObserve()}}, and \code{\link[=metaRender]{metaRender()}}): \code{withMetaMode()} and \code{expandChain()}. 40 | The simplest is \code{withMetaMode(obj())}, which crawls the tree of meta-reactive 41 | dependencies and expands each \code{..()} in place. 42 | 43 | For example, consider these meta objects: 44 | 45 | \if{html}{\out{
}}\preformatted{ nums <- metaReactive(\{ runif(100) \}) 46 | obs <- metaObserve(\{ 47 | summary(..(nums())) 48 | hist(..(nums())) 49 | \}) 50 | }\if{html}{\out{
}} 51 | 52 | When code is extracted using \code{withMetaMode}: 53 | 54 | \if{html}{\out{
}}\preformatted{ withMetaMode(obs()) 55 | }\if{html}{\out{
}} 56 | 57 | The result looks like this: 58 | 59 | \if{html}{\out{
}}\preformatted{ summary(runif(100)) 60 | plot(runif(100)) 61 | }\if{html}{\out{
}} 62 | 63 | Notice how \code{runif(100)} is inlined wherever \code{..(nums())} 64 | appears, which is not desirable if we wish to reuse the same 65 | values for \code{summary()} and \code{plot()}. 66 | 67 | The \code{expandChain} function helps us workaround this issue 68 | by assigning return values of \code{metaReactive()} expressions to 69 | a name, then replaces relevant expansion (e.g., \code{..(nums())}) 70 | with the appropriate name (e.g. \code{nums}). 71 | 72 | \if{html}{\out{
}}\preformatted{ expandChain(obs()) 73 | }\if{html}{\out{
}} 74 | 75 | The result looks like this: 76 | 77 | \if{html}{\out{
}}\preformatted{ nums <- runif(100) 78 | summary(nums) 79 | plot(nums) 80 | }\if{html}{\out{
}} 81 | 82 | You can pass multiple meta objects and/or comments to \code{expandChain}. 83 | 84 | \if{html}{\out{
}}\preformatted{ expandChain( 85 | "# Generate values", 86 | nums(), 87 | "# Summarize and plot", 88 | obs() 89 | ) 90 | }\if{html}{\out{
}} 91 | 92 | Output: 93 | 94 | \if{html}{\out{
}}\preformatted{ # Load data 95 | nums <- runif(100) 96 | nums 97 | # Inspect data 98 | summary(nums) 99 | plot(nums) 100 | }\if{html}{\out{
}} 101 | 102 | You can suppress the printing of the \code{nums} vector in the previous example by 103 | wrapping the \code{nums()} argument to \code{expandChain()} with \code{invisible(nums())}. 104 | } 105 | \section{Preserving dependencies between \code{expandChain()} calls}{ 106 | 107 | 108 | Sometimes we may have related meta objects that we want to generate code for, 109 | but we want the code for some objects in one code chunk, and the code for 110 | other objects in another code chunk; for example, you might be constructing 111 | an R Markdown report that has a specific place for each code chunk. 112 | 113 | Within a single \code{expandChain()} call, all \code{metaReactive} objects are 114 | guaranteed to only be declared once, even if they're declared on by multiple 115 | meta objects; but since we're making two \code{expandChain()} calls, we will end 116 | up with duplicated code. To remove this duplication, we need the second 117 | \code{expandChain} call to know what code was emitted in the first \code{expandChain} 118 | call. 119 | 120 | We can achieve this by creating an "expansion context" and sharing it between 121 | the two calls. 122 | 123 | \if{html}{\out{
}}\preformatted{ exp_ctx <- newExpansionContext() 124 | chunk1 <- expandChain(.expansionContext = exp_ctx, 125 | invisible(nums()) 126 | ) 127 | chunk2 <- expandChain(.expansionContext = exp_ctx, 128 | obs() 129 | ) 130 | }\if{html}{\out{
}} 131 | 132 | After this code is run, \code{chunk1} contains only the definition of \code{nums} and 133 | \code{chunk2} contains only the code for \code{obs}. 134 | } 135 | 136 | \section{Substituting \code{metaReactive} objects}{ 137 | 138 | 139 | Sometimes, when generating code, we want to completely replace the 140 | implementation of a \code{metaReactive}. For example, our Shiny app might contain 141 | this logic, using \code{\link[shiny:fileInput]{shiny::fileInput()}}: 142 | 143 | \if{html}{\out{
}}\preformatted{ data <- metaReactive2(\{ 144 | req(input$file_upload) 145 | metaExpr(read.csv(..(input$file_upload$datapath))) 146 | \}) 147 | obs <- metaObserve(\{ 148 | summary(..(data())) 149 | \}) 150 | }\if{html}{\out{
}} 151 | 152 | Shiny's file input works by saving uploading files to a temp directory. The 153 | file referred to by \code{input$file_upload$datapath} won't be available when 154 | another user tries to run the generated code. 155 | 156 | You can use the expansion context object to swap out the implementation of 157 | \code{data}, or any other \code{metaReactive}: 158 | 159 | \if{html}{\out{
}}\preformatted{ ec <- newExpansionContext() 160 | ec$substituteMetaReactive(data, function() \{ 161 | metaExpr(read.csv("data.csv")) 162 | \}) 163 | 164 | expandChain(.expansionContext = ec, obs()) 165 | }\if{html}{\out{
}} 166 | 167 | Result: 168 | 169 | \if{html}{\out{
}}\preformatted{ data <- read.csv("data.csv") 170 | summary(data) 171 | }\if{html}{\out{
}} 172 | 173 | Just make sure this code ends up in a script or Rmd bundle that includes the 174 | uploaded file as \code{data.csv}, and the user will be able to reproduce your 175 | analysis. 176 | 177 | The \code{substituteMetaReactive} method takes two arguments: the \code{metaReactive} 178 | object to substitute, and a function that takes zero arguments and returns a 179 | quoted expression (for the nicest looking results, use \code{metaExpr} to create 180 | the expression). This function will be invoked the first time the 181 | \code{metaReactive} object is encountered (or if the \code{metaReactive} is defined 182 | with \code{inline = TRUE}, then every time it is encountered). 183 | } 184 | 185 | \examples{ 186 | input <- list(dataset = "cars") 187 | 188 | # varname is only required if srcref aren't supported 189 | # (R CMD check disables them for some reason?) 190 | mr <- metaReactive({ 191 | get(..(input$dataset), "package:datasets") 192 | }) 193 | 194 | top <- metaReactive({ 195 | head(..(mr())) 196 | }) 197 | 198 | bottom <- metaReactive({ 199 | tail(..(mr())) 200 | }) 201 | 202 | obs <- metaObserve({ 203 | message("Top:") 204 | summary(..(top())) 205 | message("Bottom:") 206 | summary(..(bottom())) 207 | }) 208 | 209 | # Simple case 210 | expandChain(obs()) 211 | 212 | # Explicitly print top 213 | expandChain(top(), obs()) 214 | 215 | # Separate into two code chunks 216 | exp_ctx <- newExpansionContext() 217 | expandChain(.expansionContext = exp_ctx, 218 | invisible(top()), 219 | invisible(bottom())) 220 | expandChain(.expansionContext = exp_ctx, 221 | obs()) 222 | 223 | } 224 | \references{ 225 | \url{https://rstudio.github.io/shinymeta/articles/code-generation.html} 226 | } 227 | -------------------------------------------------------------------------------- /vignettes/special-topics.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Special topics" 3 | author: "Carson Sievert & Joe Cheng" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | self_contained: false 8 | vignette: > 9 | %\VignetteIndexEntry{3. Special topics} 10 | %\VignetteEngine{knitr::rmarkdown} 11 | %\VignetteEncoding{UTF-8} 12 | --- 13 | 14 | ```{r setup, include=FALSE} 15 | knitr::opts_chunk$set( 16 | collapse = TRUE, 17 | message = FALSE, 18 | fig.align = "center", 19 | out.width = "80%", 20 | class.output = "R", 21 | comment = "" 22 | ) 23 | options(shiny.suppressMissingContextError = TRUE) 24 | ``` 25 | 26 | ## Meta counterparts to `observeEvent()` & `eventReactive()` 27 | 28 | **shinymeta** currently does not provide meta-counterparts for `eventReactive()` and `observeEvent()`, but it's possible to 'hand-roll' your own counterpart from existing building blocks (namely, `metaReactive2()`, `metaObserve2()`, and `metaExpr()`) Both of these functions are essentially a wrapper for a common reactive pattern where you want `isolate()` all reactive values except for one value/input. For example, if you want to 29 | 30 | ```{r, eval = FALSE} 31 | r <- eventReactive(input$x, { 32 | c(input$x, input$y) 33 | }) 34 | ``` 35 | 36 | is equivalent to: 37 | 38 | ```{r, eval = FALSE} 39 | r <- reactive({ 40 | req(input$x) 41 | isolate({ 42 | c(input$x, input$y) 43 | }) 44 | }) 45 | ``` 46 | 47 | so, to create the meta-counterpart: 48 | 49 | ```{r, eval = FALSE} 50 | r <- metaReactive2({ 51 | req(input$x) 52 | isolate(metaExpr({ 53 | c(input$x, input$y) 54 | })) 55 | }) 56 | ``` 57 | 58 | Similarly, for `observeEvent()`: 59 | 60 | ```{r, eval = FALSE} 61 | observeEvent(input$x, { 62 | message(input$x + input$y) 63 | }) 64 | ``` 65 | 66 | is equivalent to: 67 | 68 | ```{r, eval = FALSE} 69 | observe({ 70 | req(input$x) 71 | isolate({ 72 | message(input$x, input$y) 73 | }) 74 | }) 75 | ``` 76 | 77 | so, to create the meta-counterpart: 78 | 79 | ```{r, eval = FALSE} 80 | o <- metaObserve2({ 81 | req(input$x) 82 | isolate(metaExpr({ 83 | message(input$x + input$y) 84 | })) 85 | }) 86 | ``` 87 | 88 | **Warning:** Do not attempt to use existing `eventReactive()`/`observeEvent()` by calling `metaExpr()` within their handler bodies. It won't work with either one. `eventReactive()` won't work because it caches its results, oblivious to whether it's in normal mode or meta mode; and `observeEvent()` won't work because (non-meta) observers don't even have a way to return values, period. 89 | 90 | 91 | ## Shiny modules 92 | 93 | **shinymeta** is designed to work with Shiny modules, [here's an example](https://github.com/rstudio/shinymeta/blob/main/inst/examples/modules/app.R). 94 | Modifying an existing Shiny app that uses modules may be more involved than simply capturing domain logic and marking reactive reads. For example, if you have one or more `callModule()` calls which create a (namespaced) output object(s), you may want to have that module function return the output object so you can `expandChain()` various meta-outputs from different modules at the same time ([as done in the example app](https://github.com/rstudio/shinymeta/blob/main/inst/examples/modules/app.R#L32)). 95 | 96 | ## Shiny, tidyeval, and shinymeta 97 | 98 | > TL;DR: The same steps in the [overview](#overview) will work for a Shiny app that uses [tidyeval](https://tidyeval.tidyverse.org/), but it probably won't produce the most readable code. To workaround that, if possible, try to avoid unquoting (i.e., `!!`/`!!!`) by using a functional interface that accepts character strings (instead of symbolic names). 99 | 100 | Most **tidyverse** functions evaluate code expressions in a special context (e.g., they search for names within a data frame). That's how **dplyr** knows, for example, to lookup names (e.g. `cyl`) and evaluate calls (e.g., `mean(mpg)`) within a context defined by `mtcars`: 101 | 102 | ```{r} 103 | library(dplyr) 104 | 105 | # compute mean miles per gallon (mpg) by cylinder (cyl) 106 | mtcars %>% 107 | group_by(cyl) %>% 108 | summarise(avg = mean(mpg)) 109 | ``` 110 | 111 | This approach makes for an expressive interactive interface, but it also complicates things if we wish to pass variables into (i.e., program around) these functions (because they quote their arguments). For example, if you had a variable, named `var`, that represented another name with the column name of interest, **dplyr** thinks you're looking for a column named `var`, not `mpg`: 112 | 113 | ```{r} 114 | var <- as.name("mpg") 115 | 116 | mtcars %>% 117 | group_by(cyl) %>% 118 | summarise(avg = mean(var)) 119 | ``` 120 | 121 | To workaround this problem, **tidyverse** functions allow you to unquote (i.e., replace a name with it's value) via the `!!` operator. Just to demonstrate, if we unquote `var`, we'd get back the name (i.e., symbol) `mpg`. 122 | 123 | ```{r} 124 | rlang::expr(!!var) 125 | ``` 126 | 127 | That's why this code gives us the desired result of average miles per gallon (`mpg`) per cylinder (`cyl`). 128 | 129 | ```{r} 130 | mtcars %>% 131 | group_by(cyl) %>% 132 | summarise(avg = mean(!!var)) 133 | ``` 134 | 135 | Often times in a Shiny app we wish to pass an input value to a **tidyverse** function argument (as a variable). In most cases, that requires converting a string into a symbolic name, which can be done via `as.symbol()` or `rlang::sym()`. For example, here's a Shiny app to compute the mean of different `mtcars` variables by cylinder (`cyl`). 136 | 137 | ```{r, eval = FALSE} 138 | library(shiny) 139 | library(tidyverse) 140 | ui <- fluidPage( 141 | selectInput("var", "Select a variable", names(mtcars)), 142 | verbatimTextOutput("out") 143 | ) 144 | server <- function(input, output) { 145 | output$out <- renderPrint({ 146 | var_sym <- sym(input$var) 147 | mtcars %>% 148 | group_by(cyl) %>% 149 | summarise(mean_mpg = mean(!!var_sym)) 150 | }) 151 | } 152 | shinyApp(ui, server) 153 | ``` 154 | 155 | Adding **shinymeta** support in this case is straight-forward. As with any other app, you'll have to capture the domain logic (i.e., wrap `renderPrint()` with `metaRender()`), then mark reactive read `..()`. 156 | 157 | ```{r, eval = FALSE} 158 | server <- function(input, output) { 159 | output$out <- metaRender(renderPrint, { 160 | var_sym <- sym(..(input$var)) 161 | mtcars %>% 162 | group_by(cyl) %>% 163 | summarise(mean_mpg = mean(!!var_sym)) 164 | }) 165 | observe(print(expandChain(output$out()))) 166 | } 167 | ``` 168 | 169 | This pattern also works when you need to convert a character vector of strings into a list of symbolic names (splice them into a function call using `!!!`). 170 | 171 | ```{r, eval = FALSE} 172 | ui <- fluidPage( 173 | selectInput("var", "Select variables", names(mtcars), multiple = TRUE), 174 | verbatimTextOutput("out") 175 | ) 176 | server <- function(input, output) { 177 | output$out <- metaRender(renderPrint, { 178 | var_sym <- syms(..(input$var)) 179 | select(mtcars, !!!var_sym) 180 | }) 181 | observe(print(expandChain(output$out()))) 182 | } 183 | shinyApp(ui, server) 184 | ``` 185 | 186 | In version v1.2.0, **shiny** introduced `varSelectInput()` essentially to remove the need to convert character string(s) into symbolic name(s). For example, in the app below, `input$var` already represents the symbolic name of interest, so you can do: 187 | 188 | ```{r, eval = FALSE} 189 | ui <- fluidPage( 190 | varSelectInput("var", "Select a variable", mtcars), 191 | verbatimTextOutput("out") 192 | ) 193 | server <- function(input, output) { 194 | output$out <- renderPrint({ 195 | mtcars %>% 196 | group_by(cyl) %>% 197 | summarise(mean_mpg = mean(!!input$var)) 198 | }) 199 | } 200 | shinyApp(ui, server) 201 | ``` 202 | 203 | As in the other examples, you can mark the reactive read with `..()` (before unquoting with `!!`) and the code generation should "just work". Technically speaking, this works because, when `..()` encounters a symbolic name that it doesn't recognize, it returns the code *to generate* the symbol instead of the bare symbol (i.e., it returns `as.symbol("mpg")` instead of `mpg` which makes the `!!` work in both normal and meta execution). 204 | 205 | ```{r, eval = FALSE} 206 | server <- function(input, output) { 207 | output$out <- metaRender(renderPrint, { 208 | mtcars %>% 209 | group_by(cyl) %>% 210 | summarise(mean_mpg = mean(!!..(input$var))) 211 | }) 212 | observe(print(expandChain(output$out()))) 213 | } 214 | shinyApp(ui, server) 215 | ``` 216 | 217 | In all the cases we've encountered thus far, the generated code is a bit different from how a human would write it. This last example produces code that looks like this: 218 | 219 | ```{r, eval = FALSE} 220 | mtcars %>% 221 | group_by(cyl) %>% 222 | summarise(mean_mpg = mean(!!as.symbol("mpg"))) 223 | ``` 224 | 225 | But what you'd probably want your app to generate is this: 226 | 227 | ```{r, eval = FALSE} 228 | mtcars %>% 229 | group_by(cyl) %>% 230 | summarise(mean_mpg = mean(mpg)) 231 | ``` 232 | 233 | At least currently, there is no great workaround for this problem other than to use alternative **tidyverse** functions that allow you to avoid unquoting by using character strings instead of symbolic names. Most **dplyr** functions provide this alternative through `_at()` variants. These variants allow you to write code like: 234 | 235 | ```{r, eval = FALSE} 236 | mtcars %>% 237 | group_by(cyl) %>% 238 | summarise_at("mpg", mean) 239 | ``` 240 | 241 | In this case, the implementation of the app is a lot simpler because we don't have to worry about unquoting; plus, the code that the app generates looks a lot more like code a human would write: 242 | 243 | ```{r, eval = FALSE} 244 | ui <- fluidPage( 245 | selectInput("var", "Select a variable", names(mtcars)), 246 | verbatimTextOutput("out") 247 | ) 248 | server <- function(input, output) { 249 | output$out <- metaRender(renderPrint, { 250 | mtcars %>% 251 | group_by(cyl) %>% 252 | summarise_at(..(input$var), mean) 253 | }) 254 | observe(print(expandChain(output$out()))) 255 | } 256 | shinyApp(ui, server) 257 | ``` 258 | -------------------------------------------------------------------------------- /vignettes/code-distribution.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Code distribution" 3 | author: "Carson Sievert & Joe Cheng" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | self_contained: false 8 | vignette: > 9 | %\VignetteIndexEntry{2. Code distribution} 10 | %\VignetteEngine{knitr::rmarkdown} 11 | %\VignetteEncoding{UTF-8} 12 | --- 13 | 14 | ```{r setup, include=FALSE} 15 | knitr::opts_chunk$set( 16 | comment = "#>", 17 | collapse = TRUE, 18 | message = FALSE, 19 | fig.align = "center", 20 | out.width = "80%" 21 | ) 22 | ``` 23 | 24 | Once you're able to [generate code](code-generation.html) that replicates desired logic in your Shiny app, you'll need some way to distribute the code (and the results!) to users. **shinymeta** provides a few utilties to make all these things a bit easier to implement, including [downloading code and results](#bundles) as well as [showing code](#show-code) in the Shiny app itself. 25 | 26 | 29 | 30 | ## Downloading code and results {#bundles} 31 | 32 | **shinymeta** provides helpers for generating [**rmarkdown** reports](https://rmarkdown.rstudio.com/) from both R scripts (`buildScriptBundle()`) and Rmd templates (`buildRmdBundle()`). Both of these functions use code that you provide to produce a source file, then they (optionally) run `rmarkdown::render()` on that source file, compress the code & results into a zip file, and provide `shiny::Progress` indications to the user throughout all these steps. These functions are best used inside a `downloadHandler()` that's linked to either a `downloadButton()` or `downloadLink()`, so the user can generate and download these reports on demand. 33 | 34 | ### From an R script 35 | 36 | The `buildScriptBundle()` produces an R script from a code expression. The default behavior is to call `rmarkdown::render()` on the resulting script, so to customize the resulting output file, you can leverage all it's support for [compiling R scripts](https://www.rdocumentation.org/packages/rmarkdown/versions/1.13/topics/compile_notebook), such as including markdown and **knitr** chunks in special comments. You can also provide arguments to the `render()` call through the `render_args` argument. 37 | 38 | ```{r, eval = FALSE} 39 | library(shiny) 40 | library(shinymeta) 41 | library(ggplot2) 42 | ui <- fluidPage( 43 | downloadButton("download_script", "Download script"), 44 | plotOutput("p1"), 45 | plotOutput("p2") 46 | ) 47 | server <- function(input, output) { 48 | output$p1 <- metaRender(renderPlot, { 49 | qplot(data = diamonds, x = carat) + ylab("Number of diamonds") 50 | }) 51 | output$p2 <- metaRender(renderPlot, { 52 | qplot(data = diamonds, x = price) + ylab("Number of diamonds") 53 | }) 54 | output$download_script <- downloadHandler( 55 | filename = "ggcode.zip", 56 | content = function(file) { 57 | ggcode <- expandChain( 58 | "#' ---", 59 | "#' title: 'Some ggplot2 code'", 60 | "#' author: ''", 61 | "#' ---", 62 | "#' Some text that appears above the plot", 63 | "#+ plot, message=FALSE, tidy=TRUE, fig.show='hold', fig.height=2", 64 | quote(library(ggplot2)), 65 | output$p1(), 66 | output$p2() 67 | ) 68 | buildScriptBundle( 69 | ggcode, file, 70 | render_args = list(output_format = "pdf_document") 71 | ) 72 | } 73 | ) 74 | } 75 | shinyApp(ui, server) 76 | ``` 77 | 78 | ```{r, echo = FALSE, out.width="100%"} 79 | knitr::include_graphics("https://i.imgur.com/mQ1kBAe.gif") 80 | ``` 81 | 82 | ### From an Rmd template 83 | 84 | If you need code spread across multiple chunks in a report, you'll have to use `buildRmdBundle()` instead of `buildScriptBundle()`, which requires Rmd template file. That template should contain one or more 'variables' surrounded in `{{}}` that match names supplied to `buildRmdBundle()`'s `vars` argument.^[Instead of using [parameterized reports](https://bookdown.org/yihui/rmarkdown/parameterized-reports.html) (i.e., the usual way to [generate downloadable reports](https://shiny.rstudio.com/articles/generating-reports.html)), `buildRmdBundle()` uses `knitr::knit_expand()` to fill in the Rmd template, so the user gets not only the report, but also the source file with the essential logic to reproduce that report.] For example, this template named `report.Rmd` has two variables, `{{plot1}}` and `{{plot2}}`, which we'll eventually supply with the code from `output$p1` and `output$p2`. 85 | 86 | 
 87 | ```{r, results='asis', echo = FALSE}
 88 | cat(readLines(system.file(package = "shinymeta", "report-template.Rmd")), sep = "\n")
 89 | ```
 90 |
91 | 92 | Then, to use this `report.Rmd` template, the `downloadHandler()` in the Shiny app could use the code below (instead of `buildScriptBundle()`). Since our template places output code into separate **knitr** code chunks, it's a good idea to share the expansion context so that any dependency code isn't duplicated (as discussed in [code generation](#code-expansion)). 93 | 94 | ```{r, eval = FALSE} 95 | ec <- newExpansionContext() 96 | buildRmdBundle( 97 | "report.Rmd", 98 | file, 99 | vars = list( 100 | plot1 = expandChain(output$p1(), .expansionContext = ec), 101 | plot2 = expandChain(output$p2(), .expansionContext = ec) 102 | ), 103 | render_args = list(output_format = "all") 104 | ) 105 | ``` 106 | 107 | ### Including other files 108 | 109 | If your report needs access to other files (e.g., data files or images), you'll want to use the `include_files` argument. This copies local file(s) over to a (temporary) directory where the report generation and zip bundling occurs. More than likely, you'll want to use this to include a dataset that your Shiny app has access to, but your users probably don't. Below is a Shiny app where a user can upload their own dataset, then download that dataset along with some transformation of that dataset. 110 | 111 | ```{r, eval = FALSE} 112 | library(shiny) 113 | library(shinymeta) 114 | 115 | ui <- fluidPage( 116 | sidebarLayout( 117 | sidebarPanel( 118 | fileInput("file1", "Choose CSV File", accept = "text/csv"), 119 | checkboxInput("header", "Header", value = TRUE), 120 | uiOutput("download_button") 121 | ), 122 | mainPanel(verbatimTextOutput("summary")) 123 | ) 124 | ) 125 | 126 | server <- function(input, output) { 127 | 128 | data <- metaReactive({ 129 | req(input$file1) 130 | read.csv(input$file1$datapath, header = input$header) 131 | }) 132 | 133 | output$download_button <- renderUI({ 134 | req(input$file1) 135 | downloadButton("download") 136 | }) 137 | 138 | output$summary <- metaRender(renderPrint, { 139 | skimr::skim(!!data()) 140 | }) 141 | 142 | output$download <- downloadHandler( 143 | filename = "report.zip", 144 | content = function(out) { 145 | ec <- newExpansionContext() 146 | ec$substituteMetaReactive(data, function() { 147 | metaExpr(read.csv("data.csv")) 148 | }) 149 | buildScriptBundle( 150 | expandChain(output$summary(), .expansionContext = ec), out, 151 | include_files = setNames(input$file1$datapath, "data.csv") 152 | ) 153 | } 154 | ) 155 | } 156 | 157 | shinyApp(ui, server) 158 | ``` 159 | 160 | 161 | ```{r, echo = FALSE, out.width="100%"} 162 | knitr::include_graphics("https://i.imgur.com/IV0gfZJ.gif") 163 | ``` 164 | 165 | 166 | ## Showing code {#show-code} 167 | 168 | ### For an output 169 | 170 | If your Shiny app has lots of outputs, then you may want an intuitive way for users to obtain the code for specific output(s). For this purpose, **shinymeta** provides `outputCodeButton()`, which wraps an output in a container with a button. The button works in a similar way to an `shiny::actionButton()`, except the input is determined by the `outputId` of the shiny output it's overlaying: `input$OUTPUTID_output_code`. When this button is clicked, we recommend showing code for an output by supplying that code to `displayCodeModal()` (which shows a `shiny::modalDialog()` that contains a `shinyAce::aceEditor()`). 171 | 172 | ```{r, eval = FALSE} 173 | library(shiny) 174 | library(shinymeta) 175 | library(ggplot2) 176 | ui <- fluidPage( 177 | outputCodeButton(plotOutput("p1", height = 200)), 178 | outputCodeButton(plotOutput("p2", height = 200)) 179 | ) 180 | server <- function(input, output) { 181 | output$p1 <- metaRender(renderPlot, { 182 | qplot(data = diamonds, x = carat) + ylab("Number of diamonds") 183 | }) 184 | output$p2 <- metaRender(renderPlot, { 185 | qplot(data = diamonds, x = price) + ylab("Number of diamonds") 186 | }) 187 | observeEvent(input$p1_output_code, { 188 | code <- expandChain(quote(library(ggplot2)), output$p1()) 189 | displayCodeModal(code) 190 | }) 191 | observeEvent(input$p2_output_code, { 192 | code <- expandChain(quote(library(ggplot2)), output$p2()) 193 | displayCodeModal(code) 194 | }) 195 | } 196 | shinyApp(ui, server) 197 | ``` 198 | 199 | ```{r, echo = FALSE, out.width="80%"} 200 | knitr::include_graphics("https://i.imgur.com/ZiHKfXY.gif") 201 | ``` 202 | 203 | 204 | ### For numerous outputs {#numerous-outputs} 205 | 206 | If you want to show code for a collection of outputs at once, we recommend using a `shiny::actionButton()` instead of `outputCodeButton()` to trigger the code display. Note that with `displayCodeModal()`, you are able to control both the `modalDialog()` as well as the `shinyAce::aceEditor()` that it contains. 207 | 208 | ```{r, eval = FALSE} 209 | library(shiny) 210 | library(shinymeta) 211 | library(ggplot2) 212 | ui <- fluidPage( 213 | plotOutput("p1"), 214 | plotOutput("p2"), 215 | actionButton("code", "R code", icon("code")) 216 | ) 217 | server <- function(input, output) { 218 | output$p1 <- metaRender(renderPlot, { 219 | qplot(data = diamonds, x = carat) + ylab("Number of diamonds") 220 | }) 221 | output$p2 <- metaRender(renderPlot, { 222 | qplot(data = diamonds, x = price) + ylab("Number of diamonds") 223 | }) 224 | observeEvent(input$code, { 225 | code <- expandChain( 226 | quote(library(ggplot2)), 227 | output$p1(), 228 | output$p2() 229 | ) 230 | displayCodeModal( 231 | code, 232 | title = "ggplot2 code", 233 | size = "s", 234 | fontSize = 16, 235 | height = "200px", 236 | theme = "solarized_dark" 237 | ) 238 | }) 239 | } 240 | shinyApp(ui, server) 241 | ``` 242 | 243 | ```{r, echo = FALSE, out.width="80%"} 244 | knitr::include_graphics("https://i.imgur.com/h14d7QG.gif") 245 | ``` 246 | -------------------------------------------------------------------------------- /vignettes/code-generation.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Code generation" 3 | author: "Carson Sievert & Joe Cheng" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | self_contained: false 8 | vignette: > 9 | %\VignetteIndexEntry{1. Code generation} 10 | %\VignetteEngine{knitr::rmarkdown} 11 | %\VignetteEncoding{UTF-8} 12 | --- 13 | 14 | ```{r setup, include=FALSE} 15 | knitr::opts_chunk$set( 16 | collapse = TRUE, 17 | message = FALSE, 18 | fig.align = "center", 19 | out.width = "80%", 20 | class.output = "R", 21 | comment = "" 22 | ) 23 | library(shiny) 24 | library(shinymeta) 25 | library(dplyr) 26 | library(ggplot2) 27 | options(shiny.suppressMissingContextError = TRUE) 28 | input <- list(package = "ggplot2") 29 | output <- list() 30 | 31 | downloads <- metaReactive({ 32 | cranlogs::cran_downloads(..(input$package), from = Sys.Date() - 365, to = Sys.Date()) 33 | }) 34 | 35 | downloads_rolling <- metaReactive2({ 36 | validate(need(sum(downloads()$count) > 0, "Input a valid package name")) 37 | 38 | metaExpr({ 39 | ..(downloads()) %>% 40 | mutate(count = zoo::rollapply(count, 7, mean, fill = "extend")) 41 | }) 42 | }) 43 | 44 | output$plot <- metaRender(renderPlot, { 45 | ggplot(..(downloads_rolling()), aes(date, count)) + geom_line() 46 | }) 47 | 48 | # Only show the first few rows 49 | library(knitr) 50 | knit_print.data.frame <- function(x, ...) { 51 | if (nrow(x) > 10) { 52 | normal_print(head(x, 6)) 53 | cat("[...plus", nrow(x) - 6, "more rows...]\n") 54 | } 55 | } 56 | # register the method 57 | registerS3method("knit_print", "data.frame", knit_print.data.frame) 58 | ``` 59 | 60 | ```{css echo=FALSE} 61 | pre { 62 | border: 1px solid #eee; 63 | } 64 | 65 | pre.r { 66 | background-color: #ffffff; 67 | } 68 | 69 | pre.r code { 70 | background-color: #ffffff; 71 | } 72 | 73 | pre.R { 74 | background-color: #f8f8f8; 75 | border-radius: 0px; 76 | border-bottom-left-radius: 4px; 77 | border-bottom-right-radius: 4px; 78 | } 79 | 80 | .sourceCode .R { 81 | margin-top: -1em; 82 | } 83 | ``` 84 | 85 | ## Motivating example 86 | 87 | Below is a reduced version of the [cranview](https://github.com/cpsievert/cranview) Shiny app that allows you to enter an R package name to generate a plot of its [CRAN](https://cran.r-project.org/) downloads over the past year. This app provides a nice example of how to modify an existing Shiny app so that it can generate code to reproduce what a user sees in the app: 88 | 89 | ```{r, eval = FALSE} 90 | library(shiny) 91 | library(tidyverse) 92 | 93 | ui <- fluidPage( 94 | textInput("package", "Package name", value = "ggplot2"), 95 | plotOutput("plot") 96 | ) 97 | 98 | server <- function(input, output, session) { 99 | 100 | downloads <- reactive({ 101 | cranlogs::cran_downloads(input$package, from = Sys.Date() - 365, to = Sys.Date()) 102 | }) 103 | 104 | downloads_rolling <- reactive({ 105 | validate(need(sum(downloads()$count) > 0, "Input a valid package name")) 106 | 107 | downloads() %>% 108 | mutate(count = zoo::rollapply(count, 7, mean, fill = "extend")) 109 | }) 110 | 111 | output$plot <- renderPlot({ 112 | ggplot(downloads_rolling(), aes(date, count)) + geom_line() 113 | }) 114 | } 115 | 116 | shinyApp(ui, server) 117 | ``` 118 | 119 | Below is a modified version of the app that generates code to reproduce `output$plot` outside of the shiny session (via **shinymeta**). In the screencast of the app below, note how both `output$plot` and `output$code` update dynamically in response to user input. To keep the focus on code generation, we've presented the `output$code` as simple as possible here (by using `verbatimTextOutput()` and `renderPrint()`), but the [next article](code-distribution.html) outlines the various options distributing code to users. 120 | 121 | ```{r, eval = FALSE} 122 | library(shiny) 123 | library(tidyverse) 124 | library(shinymeta) 125 | 126 | ui <- fluidPage( 127 | textInput("package", "Package name", value = "ggplot2"), 128 | verbatimTextOutput("code"), 129 | plotOutput("plot") 130 | ) 131 | 132 | server <- function(input, output, session) { 133 | 134 | downloads <- metaReactive({ 135 | cranlogs::cran_downloads(..(input$package), from = Sys.Date() - 365, to = Sys.Date()) 136 | }) 137 | 138 | downloads_rolling <- metaReactive2({ 139 | validate(need(sum(downloads()$count) > 0, "Input a valid package name")) 140 | 141 | metaExpr({ 142 | ..(downloads()) %>% 143 | mutate(count = zoo::rollapply(count, 7, mean, fill = "extend")) 144 | }) 145 | }) 146 | 147 | output$plot <- metaRender(renderPlot, { 148 | ggplot(..(downloads_rolling()), aes(date, count)) + geom_line() 149 | }) 150 | 151 | output$code <- renderPrint({ 152 | expandChain( 153 | quote(library(tidyverse)), 154 | output$plot() 155 | ) 156 | }) 157 | } 158 | 159 | shinyApp(ui, server) 160 | ``` 161 | 162 | 171 | 172 | ## Overview {#overview} 173 | 174 | There are roughly 3 main steps required to get an existing Shiny app generating reproducible code via **shinymeta** (well, 4 steps if you want to generate 'readable' code). Those steps are illustrated in the video below: 175 | 176 | 186 | 187 | ### Step 1: Identify and capture domain logic 188 | 189 | Each reactive building block that contains domain logic must be replaced by a suitable meta-counterpart (i.e., `reactive()` -> `metaReactive()`, `renderPlot()` -> `metaRender()`, `observe()` -> `metaObserve()`, etc). In situations where a reactive building block contains non-domain logic that you don't want to capture (e.g., Shiny specific code, like `validate()`), **shinymeta** provides a second version (e.g. `metaReactive2()`, `metaRender2()`, `metaObserve2()`, etc) that allows you to ignore code (by wrapping only the code that you care about in `metaExpr()`). When using these `-2` variants, make sure the return value of the expression is a `metaExpr()` object (In practice, the code you want to capture might depend on other input value(s). In that case, you can use control flow [similar to this](https://github.com/cpsievert/cranview/blob/f4989a9/app.R#L71-L89), just make sure to return a `metaExpr()`!). 190 | 191 | ### Step 2: Identify and mark reactive reads 192 | 193 | To substitute reactive reads (e.g., `input$package`, `downloads()`) with a suitable value or name (e.g., `"ggplot2"`, `downloads`), mark them with `..()`. When `..()` is applied to something other than a reactive read, it's treated as an unquoting operator, which is discussed more in [The execution model](#execution). 194 | 195 | ### Step 3: Generate code with `expandChain()` 196 | 197 | The `expandChain()` function generates code from any combination of meta-counterparts (i.e., `metaReactive()`, `metaRender()`, etc) and other quoted code. Supplying quoted code is primarily useful for supplying setup code that the user needs but isn't captured by meta-reactives (e.g., loading of libraries). 198 | 199 | ```{r} 200 | # Imagine we've added this output to our example 201 | output$summary <- metaRender(renderPrint, { 202 | summary(..(downloads())$count) 203 | }) 204 | 205 | expandChain( 206 | quote({ 207 | library(dplyr) 208 | library(ggplot2) 209 | }), 210 | output$plot(), 211 | output$summary() 212 | ) 213 | ``` 214 | 215 | If we expand these outputs separately, `expandChain()` won't automatically know to avoid duplicating code for dependencies that they share. In this case, both of these outputs depend on `downloads`, so if we expand them in subsequent calls to `expandChain()`, we'll be producing code that calls `cranlogs::cran_downloads()` twice: 216 | 217 | ```{r} 218 | expandChain(output$plot()) 219 | ``` 220 | 221 | ```{r} 222 | expandChain(output$summary()) 223 | ``` 224 | 225 | Fortunately, there is a way to avoid this redundant code caused by shared dependencies by sharing an 'expansion context' between subsequent calls to `expandChain()`. This is especially useful for [generating reports](#generating-reports) where you might want to spit code out into separate **knitr** chunks. 226 | 227 | ```{r} 228 | ec <- newExpansionContext() 229 | expandChain(output$plot(), .expansionContext = ec) 230 | ``` 231 | 232 | ```{r} 233 | expandChain(output$summary(), .expansionContext = ec) 234 | ``` 235 | 236 | Expansion contexts are also useful for cases where you need to redefine a meta-reactive's logic. This is useful in at least two scenarios: 237 | 238 | 1. For efficiency or privacy reasons, you may not want to provide the "rawest" form of the data in your app to users. Instead, you might want to only provide a transformed and/or summarized version of the data. For example, instead of providing the user with `downloads`, we could provide `downloads_rolling` as file to be [included as part of a download bundle](code-distribution.html#including-other-files). 239 | 240 | ```{r} 241 | saveRDS(downloads_rolling(), "d.rds") 242 | ec <- newExpansionContext() 243 | ec$substituteMetaReactive(downloads_rolling, function() { 244 | metaExpr(readRDS("d.rds")) 245 | }) 246 | 247 | expandChain( 248 | quote(library(ggplot2)), 249 | output$plot(), 250 | .expansionContext = ec 251 | ) 252 | ``` 253 | 254 | ```{r, echo = FALSE} 255 | unlink("d.rds") 256 | ``` 257 | 258 | 2. Apps that allow users to upload a file: the location of the file on the server won't be available to users, so it may be easier just to substitute the reactive that reads the uploaded file. For an example, see [this example](code-distribution.html#including-other-files) in the next vignette. 259 | 260 | ### Step 4: Improving the readability of generated code 261 | 262 | There's a few different techniques you can leverage to improve the quality of the generated code, including: 263 | 264 | * __Comment preservation__: Surround comments in quotes to ensure they appear in the generated code. This works with any meta-reactive as well as `expandChain()`: 265 | 266 | ```{r} 267 | mr <- metaReactive({ 268 | "# comment" 269 | 1 + 1 270 | }) 271 | expandChain("# another comment", mr()) 272 | ``` 273 | 274 | * __Controlling names__: In some cases, meta-reactive name inference fails^[Name inference depends on a `srcref` of the `expr` argument being available. There are at least a couple different ways name inference can fail: (1) The `keep.source` option is `FALSE` (2) `expr` [does not appear as the first argument](https://github.com/rstudio/shinymeta/issues/61).] and/or isn't quite the name you want to appear in the generated code. In those cases, you can specify the name via the `varname` argument. 275 | 276 | ```{r} 277 | mr <- metaReactive(1 + 1, varname = "two") 278 | expandChain(mr()) 279 | ``` 280 | 281 | * __Controlling scope__: Meta-reactive expressions that use intermediate variable names may generate code that introduces those names into the global scope. For example, the code generated from this `three` meta-reactive introduces `two` into the global scope: 282 | 283 | ```{r} 284 | three <- metaReactive({ 285 | two <- 1 + 1 286 | two + 1 287 | }) 288 | expandChain(three()) 289 | ``` 290 | 291 | If you want to be careful not to unnecessarily introduce names into the users namespace, you can force the generated code expressions to be wrapped in `local()` which ensures intermediate variables aren't bound to the global environment: 292 | 293 | ```{r} 294 | three <- metaReactive({ 295 | two <- 1 + 1 296 | two + 1 297 | }, localize = TRUE) 298 | expandChain(three()) 299 | ``` 300 | 301 | Another option is to bind the meta-reactive's name to the last call of the meta-expression expression. This option has the benefit of generating the most readable code, but also has the downside of introducing intermediate variables into the global namespace. 302 | 303 | ```{r} 304 | three <- metaReactive({ 305 | two <- 1 + 1 306 | two + 1 307 | }, bindToReturn = TRUE) 308 | expandChain(three()) 309 | ``` 310 | 311 | 312 | ## The execution model {#execution} 313 | 314 | For most existing Shiny applications, you should be able to follow the steps outlined above in the [Overview](#overview) section, and the code generation should "just work". In some scenarios, however, you may have to tweak or debug your Shiny app logic, and in doing so, it'll be helpful to understand **shinymeta**'s model for execution. 315 | 316 | Meta-reactives (e.g., `metaReactive()`, `metaRender()`, etc) can be invoked in two different modes: meta or normal (the default). In normal mode, the behavior of a meta-reactive is essentially the same as the non-meta version (e.g., `downloads()` still evaluates and caches results just like a normal `reactive()` does). The only subtle difference is that, in normal execution, meta-reactives know to (silently) ignore `..()`: 317 | 318 | ```{r} 319 | downloads <- metaReactive({ 320 | cranlogs::cran_downloads( 321 | ..(input$package), 322 | from = Sys.Date() - 365, 323 | to = Sys.Date() 324 | ) 325 | }) 326 | downloads() 327 | ``` 328 | 329 | When invoked in meta mode, meta-counterparts return a code expression instead of fully evaluating the expression. **shinymeta** currently provides two ways to invoke meta-reactives in meta mode: `withMetaMode()` and `expandChain()`. In practice, you'll almost always want to use `expandChain()` over `withMetaMode()`: the former has a special understanding of marked reactive reads, whereas the latter is a less intelligent [quasi-quotation](https://adv-r.hadley.nz/quasiquotation.html) interface. More specifically, `expandChain()` intelligently substitutes marked reactive reads with suitable value(s) or name(s) (and reuses those names to avoid redundant computation), whereas `withMetaMode()` does nothing more than evaluate what appears in `..()`. 330 | 331 | ```{r} 332 | withMetaMode(downloads()) 333 | ``` 334 | 335 | When applied to arbitrary code expression, `..()` works like an unquoting operator (similar to **rlang**'s `!!` operator), regardless of whether `expandChain()` or `withMetaMode()` is used. That is, it evaluates the code that appears in `..()` and inlines the result in the generated code. This makes it possible, for instance, to 'hard-code' a dynamic result (e.g., use the date the code was generated instead of when the generated code is actually evaluated). 336 | 337 | ```{r} 338 | downloads <- metaReactive({ 339 | cranlogs::cran_downloads( 340 | ..(input$package), 341 | from = ..(format(Sys.Date() - 365)), 342 | to = Sys.Date() 343 | ) 344 | }) 345 | expandChain(downloads()) 346 | ``` 347 | 348 | When it comes to `-2` variants (e.g. `metaReactive2()`, `metaRender2()`, etc), only the code that appears inside `metaExpr()` can execute in meta mode. That means, among other things, that the read of `downloads()` that appears outside of `metaExpr()` always returns a data frame (the `validate()` wouldn’t make sense if `downloads()` returned code!). It also means that `..()` isn't defined outside of `metaExpr()`. 349 | 350 | ```{r} 351 | downloads_rolling <- metaReactive2({ 352 | # Using ..() here would produce an error 353 | validate(need(sum(downloads()$count) > 0, "Input a valid package name")) 354 | 355 | metaExpr({ 356 | ..(downloads()) %>% 357 | mutate(count = zoo::rollapply(count, 7, mean, fill = "extend")) 358 | }) 359 | }) 360 | 361 | expandChain(downloads_rolling()) 362 | ``` 363 | 364 | -------------------------------------------------------------------------------- /R/metareactive.R: -------------------------------------------------------------------------------- 1 | .globals <- new.env(parent = emptyenv()) 2 | 3 | # This is a global hook for intercepting meta-mode reads of metaReactive/2. 4 | # The first argument is the (delayed eval) code result, and rexpr is the 5 | # metaReactive/2 object itself. If evaluation of x is not triggered by the 6 | # hook function, then the metaReactive/2 code will not execute/be expanded. 7 | # 8 | # The return value should be a code object. 9 | .globals$rexprMetaReadFilter <- function(x, rexpr) { 10 | x 11 | } 12 | 13 | #' Create a meta-reactive expression 14 | #' 15 | #' Create a [shiny::reactive()] that, when invoked with meta-mode activated 16 | #' (i.e. called within [withMetaMode()] or [expandChain()]), returns a code 17 | #' expression (instead of evaluating that expression and returning the value). 18 | #' 19 | #' @details If you wish to capture specific code inside of `expr` (e.g. ignore 20 | #' code that has no meaning outside shiny, like [shiny::req()]), use 21 | #' `metaReactive2()` in combination with `metaExpr()`. When using 22 | #' `metaReactive2()`, `expr` must return a `metaExpr()`. 23 | #' 24 | #' If `varname` is unspecified, [srcref]s are used in attempt to infer the name 25 | #' bound to the meta-reactive object. In order for this inference to work, the 26 | #' `keep.source` [option] must be `TRUE` and `expr` must begin with `\{`. 27 | #' 28 | #' @param varname An R variable name that this object prefers to be named when 29 | #' its code is extracted into an R script. (See also: [expandChain()]) 30 | #' 31 | #' @param inline If `TRUE`, during code expansion, do not declare a variable for 32 | #' this object; instead, inline the code into every call site. Use this to avoid 33 | #' introducing variables for very simple expressions. (See also: [expandChain()]) 34 | #' 35 | #' @inheritParams shiny::reactive 36 | #' @inheritParams metaExpr 37 | #' @return A function that, when called in meta mode (i.e. inside 38 | #' [expandChain()]), will return the code in quoted form. When called outside 39 | #' meta mode, it acts the same as a regular [shiny::reactive()] expression 40 | #' call. 41 | #' @export 42 | #' @seealso [metaExpr()], [`..`][shinymeta::dotdot] 43 | #' @examples 44 | #' 45 | #' library(shiny) 46 | #' options(shiny.suppressMissingContextError = TRUE) 47 | #' 48 | #' input <- list(x = 1) 49 | #' 50 | #' y <- metaReactive({ 51 | #' req(input$x) 52 | #' a <- ..(input$x) + 1 53 | #' b <- a + 1 54 | #' c + 1 55 | #' }) 56 | #' 57 | #' withMetaMode(y()) 58 | #' expandChain(y()) 59 | #' 60 | #' y <- metaReactive2({ 61 | #' req(input$x) 62 | #' 63 | #' metaExpr({ 64 | #' a <- ..(input$x) + 1 65 | #' b <- a + 1 66 | #' c + 1 67 | #' }, bindToReturn = TRUE) 68 | #' }) 69 | #' 70 | #' expandChain(y()) 71 | #' 72 | metaReactive <- function(expr, env = parent.frame(), quoted = FALSE, 73 | varname = NULL, domain = shiny::getDefaultReactiveDomain(), inline = FALSE, 74 | localize = "auto", bindToReturn = FALSE) { 75 | 76 | if (!quoted) { 77 | expr <- substitute(expr) 78 | quoted <- TRUE 79 | } 80 | 81 | varname <- exprToVarname(expr, varname, inline, "metaReactive") 82 | 83 | # Need to wrap expr with shinymeta:::metaExpr, but can't use rlang/!! to do 84 | # so, because we want to keep any `!!` contained in expr intact (i.e. too 85 | # early to perform expansion of expr here). 86 | # 87 | # Even though expr itself is quoted, wrapExpr will effectively unquote it by 88 | # interpolating it into the `metaExpr()` call, thus quoted = FALSE. 89 | expr <- wrapExpr(shinymeta::metaExpr, expr, quoted = FALSE, localize = localize, bindToReturn = bindToReturn) 90 | 91 | metaReactiveImpl(expr = expr, env = env, varname = varname, domain = domain, inline = inline) 92 | } 93 | 94 | 95 | #' @export 96 | #' @rdname metaReactive 97 | metaReactive2 <- function(expr, env = parent.frame(), quoted = FALSE, 98 | varname = NULL, domain = shiny::getDefaultReactiveDomain(), inline = FALSE) { 99 | 100 | if (!quoted) { 101 | expr <- substitute(expr) 102 | quoted <- TRUE 103 | } 104 | 105 | varname <- exprToVarname(expr, varname, inline, "metaReactive2") 106 | 107 | metaReactiveImpl(expr = expr, env = env, varname = varname, domain = domain, inline = inline) 108 | } 109 | 110 | exprToVarname <- function(expr, varname = NULL, inline, objectType = "metaReactive") { 111 | 112 | if (is.null(varname)) { 113 | if (inline) return("anonymous") 114 | 115 | srcref <- attr(expr, "srcref", exact = TRUE) 116 | if (is.null(srcref)) { 117 | if (identical(getOption("keep.source"), FALSE)) { 118 | warning( 119 | "Unable to infer variable name for ", objectType, " when the option ", 120 | "keep.source is FALSE. Either set `options(keep.source = TRUE)` ", 121 | "or specify `varname` in ", objectType, 122 | call. = FALSE 123 | ) 124 | } else if (!rlang::is_call(expr, "{")) { 125 | warning( 126 | "Unable to infer variable name for ", objectType, " when `expr` does not ", 127 | "begin with `{`. Either start `expr` with `{` or specify `varname` in ", 128 | objectType, 129 | call. = FALSE 130 | ) 131 | } else { 132 | warning( 133 | "Unable to infer variable name for ", objectType, " because no srcref ", 134 | "is available. Please report an issue to https://github.com/rstudio/shinymeta/issues/new", 135 | call. = FALSE 136 | ) 137 | } 138 | } 139 | 140 | varname <- mrexprSrcrefToLabel(srcref[[1]], defaultLabel = NULL) 141 | } else { 142 | if (!is.character(varname) || length(varname) != 1 || is.na(varname) || nchar(varname) == 0) { 143 | stop("varname must be a non-empty string", call. = FALSE) 144 | } 145 | } 146 | varname 147 | } 148 | 149 | metaReactiveImpl <- function(expr, env, varname, domain, inline) { 150 | force(expr) 151 | force(env) 152 | force(varname) 153 | force(domain) 154 | force(inline) 155 | 156 | r_normal <- rlang::inject( 157 | shiny::reactive(!!rlang::new_quosure(expr, env = env), label = varname, domain = domain) 158 | ) 159 | 160 | r_meta <- function() { 161 | shiny::withReactiveDomain(domain, { 162 | eval(expr, envir = new.env(parent = env)) 163 | }) 164 | } 165 | 166 | self <- structure( 167 | function() { 168 | metaDispatch( 169 | normal = { 170 | r_normal() 171 | }, 172 | meta = { 173 | .globals$rexprMetaReadFilter(r_meta(), self) 174 | } 175 | ) 176 | }, 177 | class = c("shinymeta_reactive", "shinymeta_object", "reactive", "function"), 178 | shinymetaVarname = varname, 179 | shinymetaUID = getFromNamespace("createUniqueId", "shiny")(8), 180 | shinymetaDomain = domain, 181 | shinymetaInline = inline 182 | ) 183 | self 184 | } 185 | 186 | #' Run/capture non-reactive code for side effects 187 | #' 188 | #' Most apps start out with setup code that is non-reactive, such as 189 | #' [`library()`][base::library()] calls, loading of static data into local 190 | #' variables, or [`source`][base::source()]-ing of supplemental R scripts. 191 | #' `metaAction` provides a convenient way to run such code for its side effects 192 | #' (including declaring new variables) while making it easy to export that code 193 | #' using [expandChain()]. Note that `metaAction` executes code directly in the 194 | #' `env` environment (which defaults to the caller's environment), so any local 195 | #' variables that are declared in the `expr` will be available outside of 196 | #' `metaAction` as well. 197 | #' 198 | #' @inheritParams metaExpr 199 | #' 200 | #' @param expr A code expression that will immediately be executed (before the 201 | #' call to `metaAction` returns), and also stored for later retrieval (i.e. 202 | #' meta mode). 203 | #' @return A function that, when called in meta mode (i.e. inside 204 | #' [expandChain()]), will return the code in quoted form. If this function is 205 | #' ever called outside of meta mode, it throws an error, as it is definitely 206 | #' being called incorrectly. 207 | #' 208 | #' @examples 209 | #' 210 | #' setup <- metaAction({ 211 | #' library(stats) 212 | #' 213 | #' "# Set the seed to ensure repeatable randomness" 214 | #' set.seed(100) 215 | #' 216 | #' x <- 1 217 | #' y <- 2 218 | #' }) 219 | #' 220 | #' # The action has executed 221 | #' print(x) 222 | #' print(y) 223 | #' 224 | #' # And also you can emit the code 225 | #' expandChain( 226 | #' setup() 227 | #' ) 228 | #' 229 | #' @export 230 | metaAction <- function(expr, env = parent.frame(), quoted = FALSE) { 231 | force(env) 232 | 233 | if (!quoted) { 234 | expr <- substitute(expr) 235 | quoted <- TRUE 236 | } 237 | 238 | # Need to wrap expr with shinymeta:::metaExpr, but can't use rlang/!! to do 239 | # so, because we want to keep any `!!` contained in expr intact (i.e. too 240 | # early to perform expansion of expr here). 241 | expr <- wrapExpr(shinymeta::metaExpr, expr) 242 | 243 | eval(expr, envir = env) 244 | function() { 245 | metaDispatch( 246 | normal = { 247 | stop("Meta mode must be activated when calling the function returned by `metaAction()`: did you mean to call this function inside of `expandChain()`?") 248 | }, 249 | meta = { 250 | eval(expr, envir = env) 251 | } 252 | ) 253 | } 254 | } 255 | 256 | #' @export 257 | print.shinymeta_reactive <- function(x, ...) { 258 | cat("metaReactive:", attr(x, "shinymetaVarname"), "\n", sep = "") 259 | } 260 | 261 | # A global variable that can be one of three values: 262 | # 1. FALSE - metaExpr() should return its EVALUATED expr 263 | # 2. TRUE - metaExpr() should return its QUOTED expr 264 | # 3. "mixed" - same as TRUE, but see below 265 | # 266 | # The "mixed" exists to serve cases like metaReactive2. In cases 267 | # where calls to metaReactives are encountered inside of metaReactive2 268 | # but outside of metaExpr, those metaReactives should be evaluated in 269 | # non-meta mode (i.e. metaMode(FALSE)). 270 | # 271 | # See metaDispatch for more details on mixed mode. 272 | metaMode <- local({ 273 | value <- FALSE 274 | function(x) { 275 | if (missing(x)) { 276 | value 277 | } else { 278 | if (!isTRUE(x) && !is_false(x) && !identical(x, "mixed")) { 279 | stop("Invalid metaMode() value: legal values are TRUE, FALSE, and \"mixed\"") 280 | } 281 | value <<- x 282 | } 283 | } 284 | }) 285 | 286 | # More-specific replacement for switch() on the value of metaMode(). 287 | # 288 | # This gives us a single place to update if we need to modify the set of 289 | # supported metaMode values. 290 | switchMetaMode <- function(normal, meta, mixed) { 291 | if (missing(normal) || missing(meta) || missing(mixed)) { 292 | stop("switchMetaMode call was missing required argument(s)") 293 | } 294 | 295 | mode <- metaMode() 296 | if (isTRUE(mode)) { 297 | meta 298 | } else if (is_false(mode)) { 299 | normal 300 | } else if (identical(mode, "mixed")) { 301 | mixed 302 | } else { 303 | stop("Illegal metaMode detected: ", format(mode)) 304 | } 305 | } 306 | 307 | # metaDispatch implements the innermost if/switch for meta-reactive objects: 308 | # metaReactive/metaReactive2, metaObserve/metaObserve2, metaRender/metaRender2. 309 | # 310 | # We basically want to detect nested calls to `metaDispatch` without an 311 | # intervening `withMetaMode(TRUE)` or `metaExpr`, and treat those cases as 312 | # metaMode(FALSE). 313 | # 314 | # mr1 <- metaReactive({ 315 | # 1 + 1 316 | # }) 317 | # 318 | # mr2 <- metaReactive2({ 319 | # mr1() # returns 2 320 | # metaExpr( 321 | # ..(mr1()) # returns quote(1 + 1) 322 | # ) 323 | # }) 324 | # 325 | # withMetaMode(mr2()) 326 | metaDispatch <- function(normal, meta) { 327 | switchMetaMode( 328 | normal = { 329 | force(normal) 330 | }, 331 | meta = { 332 | withMetaMode(meta, "mixed") 333 | }, 334 | mixed = { 335 | withMetaMode(normal, FALSE) 336 | } 337 | ) 338 | } 339 | 340 | #' Evaluate an expression with meta mode activated 341 | #' 342 | #' @param expr an expression. 343 | #' @param mode whether or not to evaluate expression in meta mode. 344 | #' @return The result of evaluating `expr`. 345 | #' @seealso [expandChain()] 346 | #' @export 347 | withMetaMode <- function(expr, mode = TRUE) { 348 | origVal <- metaMode() 349 | if (!identical(origVal, mode)) { 350 | metaMode(mode) 351 | on.exit(metaMode(origVal), add = TRUE) 352 | } 353 | 354 | if (switchMetaMode(normal = FALSE, meta = TRUE, mixed = FALSE)) { 355 | expr <- prefix_meta_classes(expr) 356 | } 357 | 358 | force(expr) 359 | } 360 | 361 | #' The dot-dot operator 362 | #' 363 | #' In shinymeta, `..()` is designed for _annotating_ portions of code 364 | #' inside a `metaExpr` (or its higher-level friends `metaReactive`, 365 | #' `metaObserve`, and `metaRender`). At run time, these `meta-` functions search for 366 | #' `..()` calls and replace them with something else (see Details). Outside 367 | #' of these `meta-` functions, `..()` is not defined, so one must take extra care when 368 | #' interrogating any code within a `meta-` function that contains `..()` (see Debugging). 369 | #' 370 | #' As discussed in the [Code Generation](https://rstudio.github.io/shinymeta/articles/code-generation.html) 371 | #' vignette, `..()` is used to mark reactive reads and unquote expressions inside 372 | #' `metaExpr` (or its higher-level friends `metaReactive`, `metaObserve`, and `metaRender`). 373 | #' The actual behavior of `..()` depends on the current 374 | #' [mode of execution](https://rstudio.github.io/shinymeta/articles/code-generation.html#execution): 375 | #' 376 | #' * __Normal execution__: the `..()` call is stripped from the expression before evaluation. 377 | #' For example, `..(dataset())` becomes `dataset()`, and `..(format(Sys.Date()))` becomes 378 | #' `format(Sys.Date())`. 379 | #' 380 | #' * __Meta execution__ (as in [expandChain()]): reactive reads are replaced with a suitable 381 | #' name or value (i.e. `..(dataset())` becomes `dataset` or similar) and other code is 382 | #' replaced with its result (`..(format(Sys.Date()))` becomes e.g. `"2019-08-06"`). 383 | #' 384 | #' @section Debugging: 385 | #' If `..()` is called in a context where it isn't defined (that is, outside of a meta-expression), 386 | #' you'll see an error like: "..() is only defined inside shinymeta meta-expressions". 387 | #' In practice, this problem can manifest itself in at least 3 different ways: 388 | #' 389 | #' 1. Execution is halted, perhaps by inserting `browser()`, and from inside the `Browse>` prompt, 390 | #' `..()` is called directly. This is also not allowed, because the purpose of `..()` is to be 391 | #' searched-and-replaced away _before_ `metaExpr` begins executing the code. As a result, 392 | #' if you want to interrogate code that contains `..()` at the `Browse>` prompt, 393 | #' make sure it's wrapped in `metaExpr` before evaluating it. Also, note that when 394 | #' stepping through a `metaExpr` at the `Browse>` prompt with `n`, the debugger 395 | #' will echo the actual code that's evaluated during normal execution (i.e., `..()` is stripped), 396 | #' so that's another option for interrogating what happens during normal execution. 397 | #' On the other hand, if you are wanting to interrogate what happens during meta-execution, 398 | #' you can wrap a `metaExpr` with `expandChain()`. 399 | #' 400 | #' 2. `..()` is used in a non-`metaExpr` portions of `metaReactive2`, `metaObserve2`, and 401 | #' `metaRender2`. As discussed in [The execution model](https://rstudio.github.io/shinymeta/articles/code-generation.html#execution), 402 | #' non-`metaExpr` portions of `-2` variants always use normal execution and are completely 403 | #' ignored at code generation time, so `..()` isn't needed in this context. 404 | #' 405 | #' 3. Crafted a bit of code that uses `..()` in a way that was too clever for 406 | #' shinymeta to understand. For example, `lapply(1:5, ..)` is syntactically valid R code, 407 | #' but it's nonsense from a shinymeta perspective. 408 | #' 409 | #' @seealso [metaExpr()], [metaReactive()], [metaObserve()], [metaRender()] 410 | #' 411 | #' @param expr A single code expression. Required. 412 | #' @return `expr`, but annotated. 413 | #' 414 | #' @rdname dotdot 415 | #' @name dotdot 416 | #' @keywords internal 417 | #' @export 418 | .. <- function(expr) { 419 | stop(call. = FALSE, 420 | "The ..() function is not defined outside of a `metaExpr` context ", 421 | "(or its higher-level friends `metaReactive`, `metaObserve`, and `metaRender`). ", 422 | "You might need to wrap this code inside a `metaExpr` before evaluating it ", 423 | "see ?shinymeta::.. for more details." 424 | ) 425 | } 426 | 427 | #' Mark an expression as a meta-expression 428 | #' 429 | #' 430 | #' 431 | #' @param expr An expression (quoted or unquoted). 432 | #' @param env An environment. 433 | #' @param quoted Is the expression quoted? This is useful when you want to use an expression 434 | #' that is stored in a variable; to do so, it must be quoted with [`quote()`]. 435 | #' @param localize Whether or not to wrap the returned expression in [`local()`]. 436 | #' The default, `"auto"`, only wraps expressions with a top-level [`return()`] 437 | #' statement (i.e., return statements in anonymized functions are ignored). 438 | #' @param bindToReturn For non-`localize`d expressions, should an assignment 439 | #' of a meta expression be applied to the _last child_ of the top-level `\{` call? 440 | #' @return If inside meta mode, a quoted form of `expr` for use inside of 441 | #' [metaReactive2()], [metaObserve2()], or [metaRender2()]. Otherwise, in 442 | #' normal execution, the result of evaluating `expr`. 443 | #' 444 | #' @seealso [metaReactive2()], [metaObserve2()], [metaRender2()], [`..`][shinymeta::dotdot] 445 | #' @export 446 | metaExpr <- function(expr, env = parent.frame(), quoted = FALSE, localize = "auto", bindToReturn = FALSE) { 447 | 448 | if (!quoted) { 449 | expr <- substitute(expr) 450 | quoted <- TRUE 451 | } 452 | 453 | if (switchMetaMode(normal = TRUE, meta = FALSE, mixed = FALSE)) { 454 | expr <- cleanExpr(expr) 455 | return(eval(expr, envir = env)) 456 | } 457 | 458 | # metaExpr() moves us from mixed to meta state 459 | withMetaMode(mode = TRUE, { 460 | expr <- comment_flags(expr) 461 | expr <- expandExpr(expr, env) 462 | expr <- strip_outer_brace(expr) 463 | 464 | # Note that bindToReturn won't make sense for a localized call, 465 | # so determine we need local scope first, then add a special class 466 | # (we don't yet have the name for binding the return value) 467 | expr <- add_local_scope(expr, localize) 468 | 469 | # Apply bindToReturn rules, if relevant 470 | expr <- bind_to_return(expr) 471 | 472 | # TODO: let user opt-out of comment elevation 473 | # (I _think_ this is always safe)? 474 | expr <- elevate_comments(expr) 475 | 476 | # flag the call so that we know to bind next time we see this call 477 | # inside an assign call, we should modify it 478 | if (bindToReturn && rlang::is_call(expr, "{")) { 479 | expr <- prefix_class(expr, "bindToReturn") 480 | } 481 | 482 | prefix_meta_classes(expr) 483 | }) 484 | } 485 | 486 | 487 | #' @rdname expandChain 488 | #' @name expandChain 489 | #' @export 490 | newExpansionContext <- function() { 491 | self <- structure( 492 | list( 493 | uidToVarname = fastmap::fastmap(missing_default = NULL), 494 | seenVarname = fastmap::fastmap(missing_default = FALSE), 495 | uidToSubstitute = fastmap::fastmap(missing_default = NULL), 496 | # Function to make a (hopefully but not guaranteed to be new) varname 497 | makeVarname = local({ 498 | nextVarId <- 0L 499 | function() { 500 | nextVarId <<- nextVarId + 1L 501 | paste0("var_", nextVarId) 502 | } 503 | }), 504 | substituteMetaReactive = function(mrobj, callback) { 505 | if (!inherits(mrobj, "shinymeta_reactive")) { 506 | stop(call. = FALSE, "Attempted to substitute an object that wasn't a metaReactive") 507 | } 508 | if (!is.function(callback) || length(formals(callback)) != 0) { 509 | stop(call. = FALSE, "Substitution callback should be a function that takes 0 args") 510 | } 511 | 512 | uid <- attr(mrobj, "shinymetaUID", exact = TRUE) 513 | 514 | if (!is.null(self$uidToVarname$get(uid))) { 515 | stop(call. = FALSE, "Attempt to substitute a metaReactive object that's already been rendered into code") 516 | } 517 | 518 | self$uidToSubstitute$set(uid, callback) 519 | invisible(self) 520 | } 521 | ), 522 | class = "shinymetaExpansionContext" 523 | ) 524 | self 525 | } 526 | 527 | #' @export 528 | print.shinymetaExpansionContext <- function(x, ...) { 529 | map <- x$uidToVarname 530 | cat(sprintf("%s [id: %s]", map$mget(map$keys()), map$keys()), sep = "\n") 531 | } 532 | 533 | #' Expand code objects 534 | #' 535 | #' Use `expandChain` to write code out of one or more metaReactive objects. 536 | #' Each meta-reactive object (expression, observer, or renderer) will cause not 537 | #' only its own code to be written, but that of its dependencies as well. 538 | #' 539 | #' @param ... All arguments must be unnamed, and must be one of: 1) calls to 540 | #' meta-reactive objects, 2) comment string (e.g. `"# A comment"`), 3) 541 | #' language object (e.g. `quote(print(1 + 1))`), or 4) `NULL` (which will be 542 | #' ignored). Calls to meta-reactive objects can optionally be [invisible()], 543 | #' see Details. 544 | #' @param .expansionContext Accept the default value if calling `expandChain` a 545 | #' single time to generate a corpus of code; or create an expansion context 546 | #' object using `newExpansionContext()` and pass it to multiple related calls 547 | #' of `expandChain`. See Details. 548 | #' 549 | #' @return The return value of `expandChain()` is a code object that's suitable for 550 | #' printing or passing to [displayCodeModal()], [buildScriptBundle()], or 551 | #' [buildRmdBundle()]. 552 | #' 553 | #' The return value of `newExpansionContext` is an object that should be 554 | #' passed to multiple `expandChain()` calls. 555 | #' 556 | #' @references 557 | #' 558 | #' @details 559 | #' 560 | #' There are two ways to extract code from meta objects (i.e. [metaReactive()], 561 | #' [metaObserve()], and [metaRender()]): `withMetaMode()` and `expandChain()`. 562 | #' The simplest is `withMetaMode(obj())`, which crawls the tree of meta-reactive 563 | #' dependencies and expands each `..()` in place. 564 | #' 565 | #' For example, consider these meta objects: 566 | #' 567 | #' ``` 568 | #' nums <- metaReactive({ runif(100) }) 569 | #' obs <- metaObserve({ 570 | #' summary(..(nums())) 571 | #' hist(..(nums())) 572 | #' }) 573 | #' ``` 574 | #' 575 | #' When code is extracted using `withMetaMode`: 576 | #' ``` 577 | #' withMetaMode(obs()) 578 | #' ``` 579 | #' 580 | #' The result looks like this: 581 | #' 582 | #' ``` 583 | #' summary(runif(100)) 584 | #' plot(runif(100)) 585 | #' ``` 586 | #' 587 | #' Notice how `runif(100)` is inlined wherever `..(nums())` 588 | #' appears, which is not desirable if we wish to reuse the same 589 | #' values for `summary()` and `plot()`. 590 | #' 591 | #' The `expandChain` function helps us workaround this issue 592 | #' by assigning return values of `metaReactive()` expressions to 593 | #' a name, then replaces relevant expansion (e.g., `..(nums())`) 594 | #' with the appropriate name (e.g. `nums`). 595 | #' 596 | #' ``` 597 | #' expandChain(obs()) 598 | #' ``` 599 | #' 600 | #' The result looks like this: 601 | #' 602 | #' ``` 603 | #' nums <- runif(100) 604 | #' summary(nums) 605 | #' plot(nums) 606 | #' ``` 607 | #' 608 | #' You can pass multiple meta objects and/or comments to `expandChain`. 609 | #' 610 | #' ``` 611 | #' expandChain( 612 | #' "# Generate values", 613 | #' nums(), 614 | #' "# Summarize and plot", 615 | #' obs() 616 | #' ) 617 | #' ``` 618 | #' 619 | #' Output: 620 | #' 621 | #' ``` 622 | #' # Load data 623 | #' nums <- runif(100) 624 | #' nums 625 | #' # Inspect data 626 | #' summary(nums) 627 | #' plot(nums) 628 | #' ``` 629 | #' 630 | #' You can suppress the printing of the `nums` vector in the previous example by 631 | #' wrapping the `nums()` argument to `expandChain()` with `invisible(nums())`. 632 | #' 633 | #' @section Preserving dependencies between `expandChain()` calls: 634 | #' 635 | #' Sometimes we may have related meta objects that we want to generate code for, 636 | #' but we want the code for some objects in one code chunk, and the code for 637 | #' other objects in another code chunk; for example, you might be constructing 638 | #' an R Markdown report that has a specific place for each code chunk. 639 | #' 640 | #' Within a single `expandChain()` call, all `metaReactive` objects are 641 | #' guaranteed to only be declared once, even if they're declared on by multiple 642 | #' meta objects; but since we're making two `expandChain()` calls, we will end 643 | #' up with duplicated code. To remove this duplication, we need the second 644 | #' `expandChain` call to know what code was emitted in the first `expandChain` 645 | #' call. 646 | #' 647 | #' We can achieve this by creating an "expansion context" and sharing it between 648 | #' the two calls. 649 | #' 650 | #' ``` 651 | #' exp_ctx <- newExpansionContext() 652 | #' chunk1 <- expandChain(.expansionContext = exp_ctx, 653 | #' invisible(nums()) 654 | #' ) 655 | #' chunk2 <- expandChain(.expansionContext = exp_ctx, 656 | #' obs() 657 | #' ) 658 | #' ``` 659 | #' 660 | #' After this code is run, `chunk1` contains only the definition of `nums` and 661 | #' `chunk2` contains only the code for `obs`. 662 | #' 663 | #' @section Substituting `metaReactive` objects: 664 | #' 665 | #' Sometimes, when generating code, we want to completely replace the 666 | #' implementation of a `metaReactive`. For example, our Shiny app might contain 667 | #' this logic, using [shiny::fileInput()]: 668 | #' 669 | #' ``` 670 | #' data <- metaReactive2({ 671 | #' req(input$file_upload) 672 | #' metaExpr(read.csv(..(input$file_upload$datapath))) 673 | #' }) 674 | #' obs <- metaObserve({ 675 | #' summary(..(data())) 676 | #' }) 677 | #' ``` 678 | #' 679 | #' Shiny's file input works by saving uploading files to a temp directory. The 680 | #' file referred to by `input$file_upload$datapath` won't be available when 681 | #' another user tries to run the generated code. 682 | #' 683 | #' You can use the expansion context object to swap out the implementation of 684 | #' `data`, or any other `metaReactive`: 685 | #' 686 | #' ``` 687 | #' ec <- newExpansionContext() 688 | #' ec$substituteMetaReactive(data, function() { 689 | #' metaExpr(read.csv("data.csv")) 690 | #' }) 691 | #' 692 | #' expandChain(.expansionContext = ec, obs()) 693 | #' ``` 694 | #' 695 | #' Result: 696 | #' 697 | #' ``` 698 | #' data <- read.csv("data.csv") 699 | #' summary(data) 700 | #' ``` 701 | #' 702 | #' Just make sure this code ends up in a script or Rmd bundle that includes the 703 | #' uploaded file as `data.csv`, and the user will be able to reproduce your 704 | #' analysis. 705 | #' 706 | #' The `substituteMetaReactive` method takes two arguments: the `metaReactive` 707 | #' object to substitute, and a function that takes zero arguments and returns a 708 | #' quoted expression (for the nicest looking results, use `metaExpr` to create 709 | #' the expression). This function will be invoked the first time the 710 | #' `metaReactive` object is encountered (or if the `metaReactive` is defined 711 | #' with `inline = TRUE`, then every time it is encountered). 712 | #' 713 | #' @examples 714 | #' input <- list(dataset = "cars") 715 | #' 716 | #' # varname is only required if srcref aren't supported 717 | #' # (R CMD check disables them for some reason?) 718 | #' mr <- metaReactive({ 719 | #' get(..(input$dataset), "package:datasets") 720 | #' }) 721 | #' 722 | #' top <- metaReactive({ 723 | #' head(..(mr())) 724 | #' }) 725 | #' 726 | #' bottom <- metaReactive({ 727 | #' tail(..(mr())) 728 | #' }) 729 | #' 730 | #' obs <- metaObserve({ 731 | #' message("Top:") 732 | #' summary(..(top())) 733 | #' message("Bottom:") 734 | #' summary(..(bottom())) 735 | #' }) 736 | #' 737 | #' # Simple case 738 | #' expandChain(obs()) 739 | #' 740 | #' # Explicitly print top 741 | #' expandChain(top(), obs()) 742 | #' 743 | #' # Separate into two code chunks 744 | #' exp_ctx <- newExpansionContext() 745 | #' expandChain(.expansionContext = exp_ctx, 746 | #' invisible(top()), 747 | #' invisible(bottom())) 748 | #' expandChain(.expansionContext = exp_ctx, 749 | #' obs()) 750 | #' 751 | #' @export 752 | expandChain <- function(..., .expansionContext = newExpansionContext()) { 753 | # As we come across previously unseen objects (i.e. the UID has not been 754 | # encountered before) we have to make some decisions about what variable name 755 | # (i.e. varname) to use to represent that object. This varname is either 756 | # auto-detected based on the metaReactive's variable name, or provided 757 | # explicitly by the user when the metaReactive is created. (If the object 758 | # belongs to a module, then we use the module ID to prefix the varname.) 759 | # 760 | # But, the desired variable name might already have been used by a different 761 | # metaReactive (i.e. two objects have the same label). In this case, we can 762 | # also use a var_1, var_2, etc. (and this is what the code currently does) 763 | # but it'd be even better to try to disambiguate by using the desired name 764 | # plus _1, _2, etc. (keep going til you find one that hasn't been used yet). 765 | # 766 | # IDEA: 767 | # A different strategy we could use is to generate a gensym as the label at 768 | # first, keeping track of the metadata for every gensym (label, module id). 769 | # Then after the code generation is done, we can go back and see what the 770 | # best overall set of variable names is. For example, if the same variable 771 | # name "df" is used within module IDs "one" and "two", we can use "one_df" 772 | # and "two_df"; but if only module ID "one" is used, we can just leave it 773 | # as "df". (As opposed to the current strategy, where if "one" and "two" 774 | # are both used, we end up with "df" and "df_two".) 775 | 776 | # Keep track of what label we have used for each UID we have previously 777 | # encountered. If a UID isn't found in this map, then we haven't yet 778 | # encountered it. 779 | uidToVarname <- .expansionContext$uidToVarname 780 | # Keep track of what labels we have used, so we can be sure we don't 781 | # reuse them. 782 | seenVarname <- .expansionContext$seenVarname 783 | 784 | # As we encounter metaReactives that we depend on (directly or indirectly), 785 | # we'll append their code to this list (including assigning them to a label). 786 | dependencyCode <- list() 787 | 788 | # Override the rexprMetaReadFilter while we generate code. This is a filter 789 | # function that metaReactive/metaReactive2 will call when someone asks them 790 | # for their meta value. The `x` is the (lazily evaluated) logic for actually 791 | # generating their code (or retrieving it from cache). 792 | oldFilter <- .globals$rexprMetaReadFilter 793 | .globals$rexprMetaReadFilter <- function(x, rexpr) { 794 | # Read this object's UID. 795 | uid <- attr(rexpr, "shinymetaUID", exact = TRUE) 796 | domain <- attr(rexpr, "shinymetaDomain", exact = TRUE) 797 | inline <- attr(rexpr, "shinymetaInline", exact = TRUE) 798 | 799 | exec <- function() { 800 | subfunc <- .expansionContext$uidToSubstitute$get(uid) 801 | if (!is.null(subfunc)) { 802 | withMetaMode(subfunc()) 803 | } else { 804 | x 805 | } 806 | } 807 | 808 | if (isTRUE(inline)) { 809 | # The metaReactive doesn't want to have its own variable 810 | return(exec()) 811 | } 812 | 813 | # Check if we've seen this UID before, and if so, just return the same 814 | # varname as we used last time. 815 | varname <- uidToVarname$get(uid) 816 | if (!is.null(varname)) { 817 | return(structure(varname, class = "shinymeta_symbol")) 818 | } 819 | 820 | # OK, we haven't seen this UID before. We need to figure out what variable 821 | # name to use. 822 | 823 | # Our first choice would be whatever varname the object itself has (the true 824 | # var name of this metaReactive, or a name the user explicitly provided). 825 | varname <- attr(rexpr, "shinymetaVarname", exact = TRUE) 826 | 827 | # If there wasn't either a varname or explicitly provided name, just make 828 | # a totally generic one up. 829 | if (is.null(varname) || varname == "" || length(varname) != 1) { 830 | varname <- .expansionContext$makeVarname() 831 | } else { 832 | if (!is.null(domain)) { 833 | varname <- gsub("-", "_", domain$ns(varname)) 834 | } 835 | } 836 | 837 | # Make sure we don't use a variable name that has already been used. 838 | while (seenVarname$get(varname)) { 839 | varname <- .expansionContext$makeVarname() 840 | } 841 | 842 | # Remember this UID/varname combination for the future. 843 | uidToVarname$set(uid, varname) 844 | # Make sure this varname doesn't get used again. 845 | seenVarname$set(varname, TRUE) 846 | 847 | # Since this is the first time we're seeing this object, now we need to 848 | # generate its code and store it in our running list of dependencies. 849 | expr <- rlang::expr(`<-`(!!as.symbol(varname), !!exec())) 850 | dependencyCode <<- c(dependencyCode, list(expr)) 851 | 852 | # This is what we're returning to the caller; whomever wanted the code for 853 | # this metaReactive is going to get this variable name instead. 854 | return(structure(varname, class = "shinymeta_symbol")) 855 | } 856 | on.exit(.globals$rexprMetaReadFilter <- oldFilter, add = TRUE) 857 | 858 | withMetaMode({ 859 | # Trigger evaluation of the ..., which will also cause dependencyCode to be 860 | # populated. The value of list(...) should all be code expressions, unless 861 | # the user passed in something wrong. 862 | dot_args <- eval(substitute(alist(...))) 863 | if (!is.null(names(dot_args))) { 864 | stop(call. = FALSE, "Named ... arguments to expandChain are not supported") 865 | } 866 | 867 | res <- lapply(seq_along(dot_args), function(i) { 868 | # Grab the nth element. We do it with this gross `..n` business because 869 | # we want to make sure we trigger evaluation of the arguments one at a 870 | # time. We can't use rlang's dots-related functions, because it eagerly 871 | # expands the `!!` in arguments, which we want to leave alone. 872 | # 873 | # Use `withVisible` because invisible() arguments should have their 874 | # deps inserted, but not their actual code. Note that metaReactives 875 | # consider *themselves* their own dependencies, so for metaReactive 876 | # this means the code that assigns it is created (`mr <- ...`), 877 | # but the additional line for printing it (`mr`) will be suppressed. 878 | x_vis <- withVisible(eval(as.symbol(paste0("..", i)), envir = environment())) 879 | x <- x_vis$value 880 | 881 | val <- if (is_comment(x)) { 882 | do.call(metaExpr, list(rlang::expr({!!x; {}}))) 883 | } else if (inherits(x, "shinymeta_symbol")) { 884 | as.symbol(x) 885 | } else if (is.language(x)) { 886 | x 887 | } else if (is.null(x)) { 888 | x 889 | } else { 890 | stop(call. = FALSE, "expandChain() understands language objects, comment-strings, and NULL; but not ", class(x)[1], " objects") 891 | } 892 | myDependencyCode <- dependencyCode 893 | dependencyCode <<- list() 894 | if (x_vis$visible) { 895 | c(myDependencyCode, list(val)) 896 | } else { 897 | myDependencyCode 898 | } 899 | }) 900 | res <- unlist(res, recursive = FALSE) 901 | res <- res[!vapply(res, is.null, logical(1))] 902 | 903 | # Expand into a block of code 904 | metaExpr(as.call(c(list(quote(`{`)), res)), quoted = TRUE) 905 | }) 906 | } 907 | 908 | 909 | is_output_read <- function(expr) { 910 | if (!rlang::is_call(expr)) return(FALSE) 911 | if (length(expr) == 1) expr <- expr[[1]] 912 | is_dollar <- rlang::is_call(expr, name = "$", n = 2) && 913 | rlang::is_symbol(expr[[2]], "output") && 914 | rlang::is_symbol(expr[[3]]) 915 | is_bracket <- rlang::is_call(expr, name = "[[", n = 2) && 916 | rlang::is_symbol(expr[[2]], "output") && 917 | is.character(expr[[3]]) 918 | is_dollar || is_bracket 919 | } 920 | 921 | prefix_meta_classes <- function(expr) { 922 | expr <- prefix_class(expr, "shinyMetaExpr") 923 | if (is.character(expr)) { 924 | expr <- prefix_class(expr, "shinyMetaString") 925 | } 926 | expr 927 | } 928 | 929 | prefix_class <- function (x, y) { 930 | # Can't set attributes on a symbol, but that's alright because 931 | # we don't need to flag or compute on symbols 932 | if (is.symbol(x)) return(x) 933 | oldClass(x) <- unique(c(y, oldClass(x))) 934 | x 935 | } 936 | 937 | remove_class <- function(x, y) { 938 | if (is.symbol(x)) return(x) 939 | oldClass(x) <- setdiff(oldClass(x), y) 940 | x 941 | } 942 | --------------------------------------------------------------------------------