在 R shiny 中调用 downloadHandler 函数时,如何生成带有选择提示的弹出窗口,提示要下载哪个对象?

How to generate a pop up with a selection prompt for which object to download when invoking the downloadHandler function in R shiny?

在下面的 MWE 代码中,downloadHandler 成功地允许用户下载下面在函数 vectorVariable(input$base_input[1,1],vector1_input()) 中定义的第一个绘图“vector1”。但是,我正在尝试修改下面的内容,以便在单击下载按钮时,系统会通过弹出窗口提示用户下载 selection 下载 vector1 或 vector2,后者在函数 [=13 中定义如下=].

有人可以帮我编写一个带有某种 selectInput 或类似下载对象的条件弹出窗口,通过单击下载按钮触发吗?

我试图坚持使用本机 Shiny 函数 downloadHandler 因为它在提示用户选择下载目录方面做得非常好。我发现在 downloadHandler.

之外很难做到这一点

请注意,在这个 MWE 派生的完整应用程序中,有两个以上的 PNG 文件可供 select 下载。此外,在完整的应用程序中,相同的下载按钮用于单独的 server 部分,此 MWE 中未显示用于下载数据表(效果很好)---因此对象下载的任何更改 selection 需要在 server 部分中完成,而 UI 部分中的 downloadButton("download", "Download") 保持不变,因为它处理的不仅仅是此 MWE 中显示的这些 PNG 文件(我想这意味着某种 renderUI...).

MWE 代码:

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)

matrix1.input <- function(x){
  matrixInput(x, 
              value = matrix(c(0.2), 2, 1, dimnames = list(c("A","B"),NULL)),
              rows = list(extend = FALSE,  names = TRUE),
              cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

matrix2.input <- function(x,y,z){
  matrixInput(x,
              value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
              rows = list(extend = TRUE,  names = FALSE),
              cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
              class = "numeric")}  

matrix.validate <- function(x,y){
  a <- y        
  a[,1][a[,1]>x] <- x 
  b <- diff(a[,1,drop=FALSE]) 
  b[b<=0] <- NA               
  b <- c(1,b)                 
  a <- cbind(a,b)
  a <- na.omit(a) 
  a <- a[,-c(3),drop=FALSE]         
  return(a)}

vector.base <- function(x,y){
  a <- rep(y,x) 
  b <- seq(1:x) 
  c <- data.frame(x = b, y = a) 
  return(c)}

vector.multi <- function(x,y,z){                                            
  a <- rep(NA, x)
  a[y] <- z       
  a[seq_len(min(y)-1)] <- a[min(y)] 
  if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}   
  a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y  
  b <- seq(1:x)                                                     
  c <- data.frame(x = b, z = a)                                     
  return(c)}

vector.multiFinal <- function(x,y){
  vector.multi(x,matrix.validate(x,y)[,1],matrix.validate(x,y)[,2])}

matrix.link <- function(x,y){
  observeEvent(input$periods|input$base_input,{
    updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))})}

ui <- 
  pageWithSidebar(
    headerPanel("Model"),
    sidebarPanel(uiOutput("Panels")),
    mainPanel(
      tabsetPanel(
        tabPanel("Dynamic", value=2,
                 actionButton('showVectorPlotBtn','Vector plots'),
                 actionButton('showVectorValueBtn','Vector values'),
                 
                 downloadButton("download", "Download"),
                 
                 uiOutput("vectorTable")),
        id = "tabselected")
    ) # close main panel
  ) # close page with sidebar

server <- function(input,output,session)({
  periods       <- reactive(input$periods)
  base_input    <- reactive(input$base_input)
  vector1_input <- reactive(input$vector1_input)
  vector2_input <- reactive(input$vector2_input)
  yld           <- reactiveValues()
  
  vectorVariable <- function(x,y){
    if(input$showVectorBtn == 0) vector.base(input$periods,x)
    else vector.multiFinal(input$periods,matrix.validate(input$periods,y))}
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==2",
        sliderInput('periods','',min=1,max=120,value=60),
        matrix1.input("base_input"),
        useShinyjs(),
        actionButton('showVectorBtn','Show'), 
        actionButton('hideVectorBtn','Hide'),
        actionButton('resetVectorBtn','Reset'),
        hidden(uiOutput("Vectors"))))})
  
  renderUI({
    matrix.link("vector1_input",input$base_input[1,1])
    matrix.link("vector2_input",input$base_input[2,1])})
  
  output$Vectors <- renderUI({input$resetVectorBtn
    tagList(matrix2.input("vector1_input",input$periods,input$base_input[1,1]),
            matrix2.input("vector2_input",input$periods,input$base_input[2,1]))})
  
  observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
  observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
  
  output$graph1 <- renderPlot(plot(vectorVariable(input$base_input[1,1],vector1_input())))
  output$graph2 <- renderPlot(plot(vectorVariable(input$base_input[2,1],vector2_input())))
  
  output$download <- downloadHandler(
    filename = function() {paste("vector1","png",sep=".")},
    content = function(file){
      png(file)
      plot(vectorVariable(input$base_input[1,1],vector1_input()))
      dev.off()}
  ) # close download handler
  
  output$table1 <- renderDT({vectorsAll()})
  
  observeEvent(input$showVectorPlotBtn,{yld$showme <- tagList(plotOutput("graph1"), plotOutput("graph2"))},ignoreNULL = FALSE)
  observeEvent(input$showVectorValueBtn,{yld$showme <- DTOutput("table1")})
  
  output$vectorTable <- renderUI({yld$showme})
  
  vectorsAll <- reactive({
    cbind(1:periods(),
          vectorVariable(input$base_input[1,1],vector1_input())[,2],
          vectorVariable(input$base_input[2,1],vector2_input())[,2])})})

shinyApp(ui, server)

为了回应 ismirsehregal 的评论,下面是使用 actionButton 的工作 MWE,它触发一个带有 selectInput 和下载按钮的模态插入到所述模态中。这是来自 ismirsehregal 的干净解决方案。

MWE 代码(为简洁起见,省略了原始 MWE 中的库和函数定义;如果您想 运行 下面的 MWE,请确保从上面复制库和定义的函数! !):

ui <- 
  pageWithSidebar(
    headerPanel("Model"),
    sidebarPanel(uiOutput("Panels")),
    mainPanel(
      tabsetPanel(
        tabPanel("Dynamic", value=2,
                 actionButton('showVectorPlotBtn','Vector plots'),
                 actionButton('showVectorValueBtn','Vector values'),
                 
                 actionButton("showDownload", "Download"),
                 
                 uiOutput("vectorTable")),
        id = "tabselected")
    ) # close main panel
  ) # close page with sidebar

server <- function(input,output,session)({
  periods       <- reactive(input$periods)
  base_input    <- reactive(input$base_input)
  vector1_input <- reactive(input$vector1_input)
  vector2_input <- reactive(input$vector2_input)
  yld           <- reactiveValues()
  
  vectorVariable <- function(x,y){
    if(input$showVectorBtn == 0) vector.base(input$periods,x)
    else vector.multiFinal(input$periods,matrix.validate(input$periods,y))}
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==2",
        sliderInput('periods','',min=1,max=120,value=60),
        matrix1.input("base_input"),
        useShinyjs(),
        actionButton('showVectorBtn','Show'), 
        actionButton('hideVectorBtn','Hide'),
        actionButton('resetVectorBtn','Reset'),
        hidden(uiOutput("Vectors"))))})
  
  renderUI({
    matrix.link("vector1_input",input$base_input[1,1])
    matrix.link("vector2_input",input$base_input[2,1])})
  
  output$Vectors <- renderUI({input$resetVectorBtn
    tagList(matrix2.input("vector1_input",input$periods,input$base_input[1,1]),
            matrix2.input("vector2_input",input$periods,input$base_input[2,1]))})
  
  observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
  observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
  
  output$graph1 <- renderPlot(plot(vectorVariable(input$base_input[1,1],vector1_input())))
  output$graph2 <- renderPlot(plot(vectorVariable(input$base_input[2,1],vector2_input())))
  
  output$download <- downloadHandler(
    filename = function() {
          if (input$downloadItem == "Vector1") {paste("Vector1","png",sep=".")}
          else {paste("Vector2","png",sep=".")}
      },
    content = function(file){
      png(file)
      if (input$downloadItem == "Vector1"){plot(vectorVariable(input$base_input[1,1],vector1_input()))}
      else {plot(vectorVariable(input$base_input[2,1],vector2_input()))}
      dev.off()}
  ) # close download handler
  
  observeEvent(input$showDownload,
               {showModal(modalDialog(
                   selectInput("downloadItem","Select item to download:",
                               c("Vector1","Vector2")),
                   downloadButton("download", "Download")
                 
                 ) # close modalDialog
                ) # close showModal
               } # close showModal function
  ) # close observeEvent
  
  output$table1 <- renderDT({vectorsAll()})
  
  observeEvent(input$showVectorPlotBtn,{yld$showme <- tagList(plotOutput("graph1"), plotOutput("graph2"))},ignoreNULL = FALSE)
  observeEvent(input$showVectorValueBtn,{yld$showme <- DTOutput("table1")})
  
  output$vectorTable <- renderUI({yld$showme})
  
  vectorsAll <- reactive({
    cbind(1:periods(),
          vectorVariable(input$base_input[1,1],vector1_input())[,2],
          vectorVariable(input$base_input[2,1],vector2_input())[,2])})})

shinyApp(ui, server)