如何从 Shiny 中的自定义按钮触发下载处理程序

Question

我有一个闪亮的应用程序。该应用程序包含一个表格。表格中的每一行都包含一个按钮，用户可以通过该按钮将该行中的数据下载到报告中。

我只是坚持能够将自定义行按钮连接到下载处理程序。通常我会使用下载按钮来执行此操作，但是如何使用自定义按钮来执行此操作。

我的观察活动：

observeEvent(input$lastClick,
               {
                 if (input$lastClickId%like%"letter")
                 {
                   row_to_report=as.numeric(gsub("letter_","",input$lastClickId))
                   MyLetter=RV4$data[row_to_report,]

这里如何使用downloadHandler触发下载：

                 downloadHandler(
                 filename = "letter.docx",
                 content = function(file) {
                   tempReport <- file.path(tempdir(), "letter.Rmd")
                   file.copy("letter.Rmd", tempReport, overwrite = TRUE)

                   # Set up parameters to pass to Rmd document
                   params <- list(MyLetter)

                   rmarkdown::render(tempReport, output_file = file,
                                     params = params,
                                     envir = new.env(parent = globalenv()),

                   )
                 }
               )
             }
             else if (input$lastClickId%like%"delete")
             {
               row_to_del=as.numeric(gsub("delete_","",input$lastClickId))
               RV3$data=RV3$data[-row_to_del,]
             }
           }

)

我的数据表是这样创建的：

  output$drilldownBarr <- DT::renderDT({

      if (!is.null(drilldataBarrd())) {  

        browser()
        drilldataBarrdf<-drilldataBarrd()
        drilldataBarrdf$Actions<-
         paste0('
                <div class="btn-group" role="group" aria-label="Basic example">
                <button type="button" class="btn btn-secondary letter" id=letter_',1:nrow(drilldataBarrd()),'>Letter</button>
                </div>
                ')
     }

    datatable(drilldataBarrdf,escape=F, extensions = c("Select","Buttons"), selection = "none",

              options = list(
                scrollX = TRUE,
                scrollY = TRUE,
                pageLength = 200,
                select = "api",
                dom = 'Bfrtip',
                buttons = c('copy', 'csv', 'excel', 'pdf', 'print','colvis'))
    )
  })

也许有更好的方法？例如在每一行中创建一个下载按钮。但是如何做到这一点呢？

Answer 1

这是一个使用 base64 编码的报告文件的解决方案。它不使用downloadHandler。

library(shiny)
library(DT)
library(base64enc)
library(rmarkdown)

js <- '
Shiny.addCustomMessageHandler("download", function(b64){
  const a = document.createElement("a");
  document.body.append(a);
  a.download = "report.docx";
  a.href = b64;
  a.click();
  a.remove();
})
'

buttonHTML <- function(i){
  as.character(
    actionButton(
      paste0("button_", i), label = "Report", 
      onclick = sprintf("Shiny.setInputValue('button', %d);", i)           
    )
  )
}

dat <- iris[1:5,]
dat$Action <- sapply(1:nrow(dat), buttonHTML)

ui <- fluidPage(
  tags$head(tags$script(HTML(js))),
  br(),
  DTOutput("dtable")
)

server <- function(input, output, session){

  output[["dtable"]] <- renderDT({
    datatable(dat, escape = -ncol(dat)-1)
  })

  observeEvent(input[["button"]], {
    showNotification("Creating report...", type = "message")
    tmpReport <- tempfile(fileext = ".Rmd")
    file.copy("report.Rmd", tmpReport)
    outfile <- file.path(tempdir(), "report.docx")
    render(tmpReport, output_file = outfile, 
           params = list(data = dat[input[["button"]], -ncol(dat)]))
    b64 <- dataURI(
      file = outfile, 
      mime = "application/vnd.openxmlformats-officedocument.wordprocessingml.document"
    )
    session$sendCustomMessage("download", b64)
  })

}

shinyApp(ui, server)

rmarkdown 文件report.Rmd：

---
title: "Untitled"
author: "Stéphane Laurent"
date: "16 avril 2020"
output: word_document
params:
  data: "x"
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```

```{r}
params$data
```