生成采用来自闪亮应用程序的用户输入的 R 脚本

Question

我想将 r 代码（在激活操作按钮时进行评估）与相应的用户输入一起导出为 r 脚本。

抱歉，如果我不准确或者这个问题已经在其他地方提出过，但我不熟悉要搜索的正确术语和关键字。

我有以下 UI (similar to this app) 并添加了一个操作按钮：

library(shiny)
library(dplyr)
ui <- fluidPage(
          fluidRow(
                    column(4,
                           selectInput(
                                     "var",
                                     "Variables:",
                                     c("All", colnames(iris)),
                                     selected = c("Sepal.Length","Petal.Length"),
                                     multiple = T)
                    ),
                    column(4,
                           textInput("filter",
                                     "Filter Data",
                                     value = "Sepal.Length < 5"))
          ),
          DT::dataTableOutput("table"),
          actionButton("script",
                       "Save script")
)

我们的想法是使用标准 r / dplyr 语法和准引用 (reference) 让数据集中的用户 select 列 (iris) 和 filter 它

server <- function(input, output){
          dat <- reactive({
                    data <- iris
                    if(!input$var %in% "All"){
                              data <- data %>% select(input$var)
                    }
                    if(input$filter != ""){
                              data <- data %>% filter(!!rlang::parse_expr(input$filter))
                    }
                    data
          })
          output$table <- DT::renderDataTable(DT::datatable(dat()))
          # insert code below here
}
shinyApp(ui, server)

这按预期工作。但是，我想导出 r 代码，它提供所需的输出并将其保存在新的 r 文件中。也就是说，按下操作按钮后，代码将被打印 (cat) 并且用户输入 (input) 会填充空白：

            observeEvent(input$script, {
                    cat('#this is an automatically generated r script
                         data <- iris
                         if(!',paste0("c(",paste(paste0('"',input$var, '"'), collapse = ","), ")"), '%in% "All"){
                                      data <- data %>% select(',paste(input$var, collapse = ","),')
                         }
                        if(',paste0("c(",paste(paste0('"',input$filter, '"'), collapse = ","), ")"),' != ""){
                             data <- data %>% filter(',input$filter,')
                         }', file =  "r_script.r")
          })

这种可憎的代码实际上正在运行，生成的 r_script.r 文件包含以下代码：

#this is an automatically generated r script
                         data <- iris
                         if(! c("Sepal.Length","Petal.Length") %in% "All"){
                                      data <- data %>% select( Sepal.Length,Petal.Length )
                         }
                        if( c("Sepal.Length < 5")  != ""){
                             data <- data %>% filter( Sepal.Length < 5 )
                         }

我的问题是：是否有更简单的方法来访问服务器上运行的底层代码并将其导出为 r 脚本，最好使用已评估的 if 语句：

#this is an automatically generated r script
                         data <- iris                      
                         data <- data %>% select( Sepal.Length,Petal.Length )
                         data <- data %>% filter( Sepal.Length < 5 )                

非常感谢任何帮助！

Answer 1

您需要使用rlang 包将代码转换为可以打印为文本或评估的表达式。示例代码：

server <- function(input,output,session){
    
    user_script <- reactiveVal()
    
    observe({
        req(input$var)
        req(input$filter)
        
        # you need to sanitize user input to prevent error, now I just wrote a tryCatch()
        dplyr_expr <- tryCatch({
            # check user input
            if(any(input$var == "All")){
                columns <- colnames(iris)
            } else {
                columns <- input$var
            }
            
            dplyr_expr <- expr({
                data <- iris                     
                data <- data %>% select( !!!syms(columns))
                data <- data %>% filter( !!parse_expr(input$filter) )    
            })
            # save script
            expression_string <- capture.output(dplyr_expr)
            script_text <- paste0(
                expression_string[2:(length(expression_string)-1)],collapse = "<br>"
            )
            
            user_script(script_text)
            # evaluate expression
            eval(dplyr_expr)
            user_script(script_text)
            output$table <- renderDataTable(data)
        },error = function(e){
            print("user input caused an error")
        })
    })
    
    observeEvent(input$script,{
        req(user_script())
        showModal(
            modalDialog(
                HTML(
                    paste(
                        "# this is an automatically generated r script<br>",
                        user_script()
                    )
                )
            )
        )
    })
    
}

为了帮助您更好地理解，让我们先在闪亮的外面做。

让我们首先从 UI 模拟用户输入：

input1 <- c("Species","Sepal.Length")
input2 <- c("Sepal.Length < 5")
user_data <- iris

服务器处理

# read user input and convert it to expression
dplyr_expr <- expr({
    data <- !!expr(user_data)                     
    data <- data %>% select( !!!syms(input1))
    data <- data %>% filter( !!!parse_expr(input2) )    
})

以字符串形式返回值：

expression_string <- capture.output(dplyr_expr)
writeLines(paste0(expression_string[2:(length(expression_string)-1)],collapse = "\n"))

返回

    data <- user_data
    data <- data %>% select(Species, Sepal.Length)
    data <- data %>% filter(Sepal.Length < 5)

评估

eval(dplyr_expr)
str(data)

返回

'data.frame':   22 obs. of  2 variables:
 $ Species     : Factor w/ 3 levels "setosa","versicolor",..: 1 1 1 1 1 1 1 1 1 1 ...
 $ Sepal.Length: num  4.9 4.7 4.6 4.6 4.4 4.9 4.8 4.8 4.3 4.6 ...