Rshiny Download Button That Gathers Multiple Files From Various Locations

I am looking for info on having a download button in my app that pulls various files into a zip archive. My app displays a timeline and a datatable, and will have files associated

Solution 1:

Here is a way using the JavaScript libraries

• dom-to-image to export the timeline as a PNG image;

• table2CSV to convert the table to a CSV string;

• JSZip to zip.

---

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

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)
)

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 <- "
$(document).ready(function(){
  $('#download').on('click', function(){
    var csv = $('#table table').table2CSV({delivery:'value'});
    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();
        });
      });
  });
});"

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://cdn.jsdelivr.net/gh/rubo77/table2CSV/table2CSV.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;  }
                    "))),
  timevisOutput("appts"),
  div("Selected items:", textOutput("selected", inline = TRUE)),
  div("Visible window:", textOutput("window", inline = TRUE)),
  tableOutput("table"),
  actionButton("download", "Download timeline", class = "btn-success")
)

server <- function(input, output) {
  output$appts <- renderTimevis(
    timevis(
      data = data,
      groups = groups,
      fit = TRUE,
      options = list(editable = TRUE, multiselect = TRUE, align = "center", stack = TRUE,start = todayAM,
                     end = todayPM,showCurrentTime = FALSE,showMajorLabels=FALSE)
    )
  )
  
  output$selected <- renderText(
    paste(input$appts_selected, collapse = " ")
  )
  
  output$window <- renderText(
    paste(input$appts_window[1], "to", input$appts_window[2])
  )
  
  output$table <- renderTable(
    input$appts_data
  )
  
}

shinyApp(ui, server)

EDIT

In order for the above solution to work, the table must be displayed in the page. Below is a solution which does not require that. It uses the JavaScript library PapaParse.

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)
)

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;  }
                    "))),
  timevisOutput("appts"),
  div("Selected items:", textOutput("selected", inline = TRUE)),
  div("Visible window:", textOutput("window", inline = TRUE)),
  actionButton("download", "Download timeline", class = "btn-success")
)

server <- function(input, output, session) {
  output$appts <- renderTimevis(
    timevis(
      data = data,
      groups = groups,
      fit = TRUE,
      options = list(editable = TRUE, multiselect = TRUE, align = "center", stack = TRUE,start = todayAM,
                     end = todayPM,showCurrentTime = FALSE,showMajorLabels=FALSE)
    )
  )
  
  output$selected <- renderText(
    paste(input$appts_selected, collapse = " ")
  )
  
  output$window <- renderText(
    paste(input$appts_window[1], "to", input$appts_window[2])
  )
  
  observeEvent(input$download, {
    session$sendCustomMessage(
      "download", 
      fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
    )
  })
  
}

shinyApp(ui, server)