R Shiny Pass 文件列表到 Javascript 下载器

Posted

技术标签:

【中文标题】R Shiny Pass 文件列表到 Javascript 下载器【英文标题】:Rshiny Pass list of files to Javascript downloader 【发布时间】:2020-10-29 00:30:54 【问题描述】:

感谢Stephane Laurent!

我有一个 Rshiny 应用程序,它根据用户从数据表中选择行来生成时间线。然后,用户可以下载一个 zip 文件,其中包含表格、时间线以及希望与表格中所选行相关的文件。

我相信我需要将文件名从我的 Rshiny 表传递给 JS,以便 JS 将文件 URL 添加到 JSZip 的函数中。这些文件存储在 www 文件夹下的我的应用程序目录中。所以“https://server.me/myapp/Room.pdf”是导航到文件的方式。 (我过去只用 php 做过类似的事情。)

所以在下面的代码中,如果用户点击 Big Room 和 Red Rover,然后生成一个时间线,然后下载。他们会得到一个包含timeline.png、timeline.csv、Room.pdf和Activity.docx的zip文件

奖金 我还希望能够将特定文件添加到所有下载中。 (我想这相当简单,因为我可以将它指向特定的 url “https://server.me/myapp/Thanks_for_visiting.pdf”,而不需要 Rshiny 做任何事情。)

我可以传递多个“事物:使用 session$sendCustomMessage 吗?还是做两次?比如:

file_list <- as.data.frame(row_data$file_name)
    
    output$tbl2 <- DT::renderDataTable(
      file_list)

session$sendCustomMessage("file_list",
                              fromJSON(toJSON(input$file_list), simplifyDataFrame = FALSE))

代码

library(shiny)
library(timevis)
library(lubridate)
library(dplyr)
library(jsonlite)

starthour <- 8
today <- as.character(Sys.Date())
todayzero <- paste(today, "00:00:00")
todayAM <- paste(today, "07:00:00")
todayPM <- paste(today, "18:00:00")

items <- data.frame(
  category = c("Room", "IceBreaker", "Activity", "Break"),
  group = c(1, 2, 3, 4),
  className   = c ("red_point", "blue_point", "green_point", "purple_point"),
  content = c("Big Room", "Introductions", "Red Rover", "Lunch"),
  length = c(480, 60, 120, 90),
  file_name = c("Room.pdf", "NA", "Activity.docx", "Break.txt")
)

groups <- data.frame(id = items$group, content = items$category)

data <- items %>% mutate(
  id = 1:4,
  start = as.POSIXct(todayzero) + hours(starthour),
  end   = as.POSIXct(todayzero) + hours(starthour) + minutes(items$length)
)

js <- "
function downloadZIP(jsontable)
var csv = Papa.unparse(jsontable);
domtoimage.toPng(document.getElementById('appts'), bgcolor: 'white')
.then(function (dataUrl) 
var zip = new JSZip();
var idx = dataUrl.indexOf('base64,') + 'base64,'.length;
var content = dataUrl.substring(idx);
zip.file('timeline.png', content, base64: true)
.file('timeline.csv', btoa(csv), base64: true);
zip.generateAsync(type:'base64').then(function (b64) 
var link = document.createElement('a');
link.download = 'mytimeline.zip';
link.href = 'data:application/zip;base64,' + b64;
link.click();
);
);

$(document).on('shiny:connected', function()
Shiny.addCustomMessageHandler('download', downloadZIP);
);"

ui <- fluidPage(
  tags$head(
    tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/dom-to-image/2.6.0/dom-to-image.min.js"),
    tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.5.0/jszip.min.js"),
    tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/PapaParse/5.2.0/papaparse.min.js"),
    tags$script(html(js)),
    tags$style(
      HTML(
        "
        .red_point   border-color: red; border-width: 2px;   
        .blue_point  border-color: blue; border-width: 2px;  
        .green_point   border-color: green; border-width: 2px;   
        .purple_point  border-color: purple; border-width: 2px;  
        "
      )
      )
      ),
  DT::dataTableOutput("tbl1"),
  conditionalPanel(
    condition = "typeof input.tbl1_rows_selected  !== 'undefined' && input.tbl1_rows_selected.length > 1",
    actionButton(class = "btn-success",
                 "button2",
                 "GENERATE TIMELINE")
  ),
  
  conditionalPanel(
    condition = "input.button2 > 0",
    
    timevisOutput("appts"),
    actionButton("download", "Download timeline", class = "btn-success")
  )
      )

server <- function(input, output, session) 
  output$tbl1 <- DT::renderDataTable(
    data
  ,
  caption = 'Select desired options and scroll down to continue.',
  selection = 'multiple',
  class = "display nowrap compact",
  extensions = 'Scroller',
  options = list(
    dom = 'Bfrtip',
    paging = FALSE,
    columnDefs = list(list(visible = FALSE))
  ))
  
  
  observeEvent(input$button2, 
    row_data <- data[input$tbl1_rows_selected, ]
    
    output$appts <- renderTimevis(timevis(
      data = row_data,
      groups = groups,
      fit = TRUE,
      options = list(
        editable = TRUE,
        multiselect = TRUE,
        align = "center",
        stack = TRUE,
        start = todayAM,
        end = todayPM,
        showCurrentTime = FALSE,
        showMajorLabels = FALSE
      )
    ))
  )
  
  observeEvent(input$download, 
    session$sendCustomMessage("download",
                              fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE))
  )
  


shinyApp(ui, server)

【问题讨论】:

【参考方案1】:
library(base64enc)

js <- "
function downloadZIP(x)
  var csv = Papa.unparse(x.table);
  var URIs = x.URIs;
  domtoimage.toPng(document.getElementById('appts'), bgcolor: 'white')
    .then(function (dataUrl) 
      var zip = new JSZip();
      var idx = dataUrl.indexOf('base64,') + 'base64,'.length;
      var content = dataUrl.substring(idx);
      zip.file('timeline.png', content, base64: true)
       .file('timeline.csv', btoa(csv), base64: true);
      for(let i=0; i < URIs.length; ++i)
        zip.file(URIs[i].filename, URIs[i].uri, base64: true);
      
      zip.generateAsync(type:'base64').then(function (b64) 
        var link = document.createElement('a');
        link.download = 'mytimeline.zip';
        link.href = 'data:application/zip;base64,' + b64;
        link.click();
      );
    );

$(document).on('shiny:connected', function()
  Shiny.addCustomMessageHandler('download', downloadZIP);
);"

  observeEvent(input$download, 
    filenames <- data[input$tbl1_rows_selected, "file_name"]
    files <- file.path(".", "www", filenames)
    URIs <- lapply(seq_along(files), function(i)
      URI <- dataURI(file = files[i])
      list(filename = filenames[i], uri = substr(URI, 14, nchar(URI)))
    )
    table <- fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
    session$sendCustomMessage(
      "download",
      list(table = table, URIs = URIs)
    )
  )

【讨论】:

目前不在电脑前试一试。但看起来我可以将任何静态(非用户选择)文件附加到文件名对象以便下载它们? @Steve 是的,你可以这样做。 试图实现这一点,你如何处理 NA 值?我应该用NULL替换那些吗? (列表中的第二项没有与之关联的文件。) @Steve 使用真正的NA,而不是字符串"NA",并使用filenames &lt;- na.omit(data[input$tbl1_rows_selected, "file_name"]) 效果很好。为什么我很难将名称附加到文件名列表中?我可以使用 renderTable 显示列表,但是任何尝试 rbind、追加、合并等都会导致崩溃。好像跟因素有关?

以上是关于R Shiny Pass 文件列表到 Javascript 下载器的主要内容,如果未能解决你的问题,请参考以下文章

导入文件并附加到 r shiny 中先前加载的文件

从 SelectInput (R Shiny) 中的分组选项列表中获取组标签

R-Shiny:在文件输入上选择输入反应

R shiny 中的级别替换创建两个级别列表,一个为 NULL

R and Shiny:使用反应函数的输出

R Shiny Dynamic选择输入 - 捕获事件