Implement arbitrary file downloads

DESCRIPTION

@@ -29,7 +29,7 @@ URL: https://github.com/rstudio/shiny, http://rstudio.github.com/shiny/tutorial
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
     'map.R'
-    'random.R'
+    'utils.R'
     'timer.R'
     'tags.R'
     'cache.R'

NAMESPACE

@@ -8,6 +8,9 @@ export(checkboxInput)
 export(code)
 export(conditionalPanel)
 export(div)
+export(downloadButton)
+export(downloadHandler)
+export(downloadLink)
 export(em)
 export(fileInput)
 export(h1)

R/bootstrap.R

@@ -793,3 +793,47 @@ htmlOutput <- function(outputId) {
 uiOutput <- function(outputId) {
   htmlOutput(outputId)
 }
+
+#' Create a download button or link
+#' 
+#' Use these functions to create a download button or link; when clicked, it 
+#' will initiate a browser download. The filename and contents are specified by 
+#' the corresponding \code{\link{downloadHandler}} defined in the server 
+#' function.
+#' 
+#' @examples
+#' \dontrun{
+#' # In server.R:
+#' output$downloadData <- downloadHandler(
+#'   filename = function() {
+#'     paste('data-', Sys.Date(), '.csv', sep='')
+#'   },
+#'   content = function(con) {
+#'     write.csv(data, con)
+#'   }
+#' )
+#' 
+#' # In ui.R:
+#' downloadLink('downloadData', 'Download')
+#' }
+#' 
+#' @aliases downloadLink
+#' @seealso downloadHandler
+#' @export
+downloadButton <- function(outputId, label="Download", class=NULL) {
+  tags$a(id=outputId,
+         class=paste(c('btn shiny-download-link', class), collapse=" "),
+         href='',
+         target='_blank',
+         label)
+}
+
+#' @rdname downloadButton
+#' @export
+downloadLink <- function(outputId, label="Download", class=NULL) {
+  tags$a(id=outputId,
+         class=paste(c('shiny-download-link', class), collapse=" "),
+         href='',
+         target='_blank',
+         label)
+}

R/map.R

@@ -28,6 +28,12 @@ Map <- setRefClass(
       assign(key, value, pos=.env, inherits=FALSE)
       return(value)
     },
+    mset = function(...) {
+      args <- list(...)
+      for (key in names(args))
+        set(key, args[[key]])
+      return()
+    },
     remove = function(key) {
       if (.self$containsKey(key)) {
         result <- .self$get(key)

R/random.R

@@ -1,41 +0,0 @@
-#' Make a random number generator repeatable
-#' 
-#' Given a function that generates random data, returns a wrapped version of 
-#' that function that always uses the same seed when called. The seed to use can
-#' be passed in explicitly if desired; otherwise, a random number is used.
-#' 
-#' @param rngfunc The function that is affected by the R session's seed.
-#' @param seed The seed to set every time the resulting function is called.
-#' @return A repeatable version of the function that was passed in.
-#'   
-#' @note When called, the returned function attempts to preserve the R session's
-#'   current seed by snapshotting and restoring
-#'   \code{\link[base]{.Random.seed}}.
-#'
-#' @examples
-#' rnormA <- repeatable(rnorm)
-#' rnormB <- repeatable(rnorm)
-#' rnormA(3)  # [1]  1.8285879 -0.7468041 -0.4639111
-#' rnormA(3)  # [1]  1.8285879 -0.7468041 -0.4639111
-#' rnormA(5)  # [1]  1.8285879 -0.7468041 -0.4639111 -1.6510126 -1.4686924
-#' rnormB(5)  # [1] -0.7946034  0.2568374 -0.6567597  1.2451387 -0.8375699
-#' 
-#' @export
-repeatable <- function(rngfunc, seed = runif(1, 0, .Machine$integer.max)) {
-  force(seed)
-  
-  function(...) {
-    # When we exit, restore the seed to its original state
-    if (exists('.Random.seed', where=globalenv())) {
-      currentSeed <- get('.Random.seed', pos=globalenv())
-      on.exit(assign('.Random.seed', currentSeed, pos=globalenv()))
-    }
-    else {
-      on.exit(rm('.Random.seed', pos=globalenv()))
-    }
-    
-    set.seed(seed)
-    
-    do.call(rngfunc, list(...))
-  }
-}

R/shiny.R

@@ -23,6 +23,7 @@ ShinyApp <- setRefClass(
     session = 'Values',
     token = 'character',  # Used to identify this instance in URLs
     plots = 'Map',
+    downloads = 'Map',
     allowDataUriScheme = 'logical'
   ),
   methods = list(
@@ -191,21 +192,98 @@ ShinyApp <- setRefClass(
         return(httpResponse(400, 'text/html', '<h1>Bad Request</h1>'))
       
       if (matches[2] == 'plot') {
-        savedPlot <- plots$get(matches[3])
+        savedPlot <- plots$get(utils::URLdecode(matches[3]))
         if (is.null(savedPlot))
           return(httpResponse(404, 'text/html', '<h1>Not Found</h1>'))
         
         return(httpResponse(200, savedPlot$contentType, savedPlot$data))
       }
       
+      if (matches[2] == 'download') {
+        
+        # A bunch of ugliness here. Filenames can be dynamically generated by
+        # the user code, so we don't know what they'll be in advance. But the
+        # most reliable way to use non-ASCII filenames for downloads is to
+        # put the actual filename in the URL. So we will start with URLs in
+        # the form:
+        # 
+        #   /session/$TOKEN/download/$NAME
+        #
+        # When a request matching that pattern is received, we will calculate
+        # the filename and see if it's non-ASCII; if so, we'll redirect to
+        #
+        #   /session/$TOKEN/download/$NAME/$FILENAME
+        #
+        # And when that pattern is received, we will actually return the file.
+        # Note that this means the filename and contents could be determined
+        # a few moments apart from each other (an HTTP roundtrip basically),
+        # hopefully that won't be enough to matter for anyone.
+        
+        dlmatches <- regmatches(matches[3],
+                                regexec("^([^/]+)(/[^/]+)?$",
+                                        matches[3]))[[1]]
+        dlname <- utils::URLdecode(dlmatches[2])
+        download <- downloads$get(dlname)
+        if (is.null(download))
+          return(httpResponse(404, 'text/html', '<h1>Not Found</h1>'))
+        
+        filename <- ifelse(is.function(download$filename),
+                           Context$new()$run(download$filename),
+                           download$filename)
+
+        # If the URL does not contain the filename, and the desired filename
+        # contains non-ASCII characters, then do a redirect with the desired
+        # name tacked on the end.
+        if (dlmatches[3] == '' && grepl('[^ -~]', filename)) {
+          
+          return(httpResponse(302, 'text/html', '<h1>Found</h1>', c(
+            'Location' = sprintf('%s/%s',
+                                 utils::URLencode(dlname, TRUE),
+                                 utils::URLencode(filename, TRUE)),
+            'Cache-Control' = 'no-cache')))
+        }
+        
+        tmpdata <- tempfile()
+        on.exit(unlink(tmpdata))
+        conn <- file(tmpdata, open = 'wb')
+        result <- try(Context$new()$run(function() { download$func(conn) }))
+        if (is(result, 'try-error')) {
+          return(httpResponse(500, 'text/plain', 
+                              attr(result, 'condition')$message))
+        }
+        close(conn)
+        return(httpResponse(
+          200,
+          download$contentType %OR% getContentType(tools::file_ext(filename)),
+          readBin(tmpdata, 'raw', n=file.info(tmpdata)$size),
+          c(
+            'Content-Disposition' = ifelse(
+              dlmatches[3] == '',
+              'attachment; filename="' %.% 
+                gsub('(["\\\\])', '\\\\\\1', filename) %.%  # yes, that many \'s
+                '"',
+              'attachment'
+            ),
+            'Cache-Control'='no-cache')))
+      }
+      
       return(httpResponse(404, 'text/html', '<h1>Not Found</h1>'))
     },
     savePlot = function(name, data, contentType) {
       plots$set(name, list(data=data, contentType=contentType))
       return(sprintf('session/%s/plot/%s?%s',
-                     URLencode(token),
-                     URLencode(name),
+                     URLencode(token, TRUE),
+                     URLencode(name, TRUE),
                      createUniqueId(8)))
+    },
+    registerDownload = function(name, filename, contentType, func) {
+      
+      downloads$set(name, list(filename = filename,
+                               contentType = contentType,
+                               func = func))
+      return(sprintf('session/%s/download/%s',
+                     URLencode(token, TRUE),
+                     URLencode(name, TRUE)))
     }
   )
 )
@@ -361,50 +439,7 @@ staticHandler <- function(root) {
       return(NULL)
     
     ext <- tools::file_ext(abs.path)
-    content.type <- switch(
-      ext,
-      html='text/html; charset=UTF-8',
-      htm='text/html; charset=UTF-8',
-      js='text/javascript',
-      css='text/css',
-      png='image/png',
-      jpg='image/jpeg',
-      jpeg='image/jpeg',
-      gif='image/gif',
-      svg='image/svg+xml',
-      txt='text/plain',
-      pdf='application/pdf',
-      ps='application/postscript',
-      xml='application/xml',
-      m3u='audio/x-mpegurl',
-      m4a='audio/mp4a-latm',
-      m4b='audio/mp4a-latm',
-      m4p='audio/mp4a-latm',
-      mp3='audio/mpeg',
-      wav='audio/x-wav',
-      m4u='video/vnd.mpegurl',
-      m4v='video/x-m4v',
-      mp4='video/mp4',
-      mpeg='video/mpeg',
-      mpg='video/mpeg',
-      avi='video/x-msvideo',
-      mov='video/quicktime',
-      ogg='application/ogg',
-      swf='application/x-shockwave-flash',
-      doc='application/msword',
-      xls='application/vnd.ms-excel',
-      ppt='application/vnd.ms-powerpoint',
-      xlsx='application/vnd.openxmlformats-officedocument.spreadsheetml.sheet',
-      xltx='application/vnd.openxmlformats-officedocument.spreadsheetml.template',
-      potx='application/vnd.openxmlformats-officedocument.presentationml.template',
-      ppsx='application/vnd.openxmlformats-officedocument.presentationml.slideshow',
-      pptx='application/vnd.openxmlformats-officedocument.presentationml.presentation',
-      sldx='application/vnd.openxmlformats-officedocument.presentationml.slide',
-      docx='application/vnd.openxmlformats-officedocument.wordprocessingml.document',
-      dotx='application/vnd.openxmlformats-officedocument.wordprocessingml.template',
-      xlam='application/vnd.ms-excel.addin.macroEnabled.12',
-      xlsb='application/vnd.ms-excel.sheet.binary.macroEnabled.12',
-      'application/octet-stream')
+    content.type <- getContentType(ext)
     response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
     return(httpResponse(200, content.type, response.content))
   })

R/shinywrappers.R

@@ -184,3 +184,50 @@ reactiveUI <- function(func) {
     return(as.character(result))
   })
 }
+
+#' File Downloads
+#' 
+#' Allows content from the Shiny application to be made available to the user as
+#' file downloads (for example, downloading the currently visible data as a CSV 
+#' file). Both filename and contents can be calculated dynamically at the time 
+#' the user initiates the download. Assign the return value to a slot on 
+#' \code{output} in your server function, and in the UI use 
+#' \code{\link{downloadButton}} or \code{\link{downloadLink}} to make the
+#' download available.
+#' 
+#' @param filename A string of the filename, including extension, that the 
+#'   user's web browser should default to when downloading the file; or a 
+#'   function that returns such a string. (Reactive values and functions may be 
+#'   used from this function.)
+#' @param content A function that takes a single argument \code{con} that is a 
+#'   file connection opened in mode \code{wb}, and writes the content of the 
+#'   download into the connection. (Reactive values and functions may be used 
+#'   from this function.)
+#' @param contentType A string of the download's 
+#'   \href{http://en.wikipedia.org/wiki/Internet_media_type}{content type}, for 
+#'   example \code{"text/csv"} or \code{"image/png"}. If \code{NULL} or 
+#'   \code{NA}, the content type will be guessed based on the filename 
+#'   extension, or \code{application/octet-stream} if the extension is unknown.
+#'   
+#' @examples
+#' \dontrun{
+#' # In server.R:
+#' output$downloadData <- downloadHandler(
+#'   filename = function() {
+#'     paste('data-', Sys.Date(), '.csv', sep='')
+#'   },
+#'   content = function(con) {
+#'     write.csv(data, con)
+#'   }
+#' )
+#' 
+#' # In ui.R:
+#' downloadLink('downloadData', 'Download')
+#' }
+#' 
+#' @export
+downloadHandler <- function(filename, content, contentType=NA) {
+  return(function(shinyapp, name, ...) {
+    shinyapp$registerDownload(name, filename, contentType, content)
+  })
+}

R/utils.R

@@ -0,0 +1,104 @@
+#' Make a random number generator repeatable
+#' 
+#' Given a function that generates random data, returns a wrapped version of 
+#' that function that always uses the same seed when called. The seed to use can
+#' be passed in explicitly if desired; otherwise, a random number is used.
+#' 
+#' @param rngfunc The function that is affected by the R session's seed.
+#' @param seed The seed to set every time the resulting function is called.
+#' @return A repeatable version of the function that was passed in.
+#'   
+#' @note When called, the returned function attempts to preserve the R session's
+#'   current seed by snapshotting and restoring
+#'   \code{\link[base]{.Random.seed}}.
+#'
+#' @examples
+#' rnormA <- repeatable(rnorm)
+#' rnormB <- repeatable(rnorm)
+#' rnormA(3)  # [1]  1.8285879 -0.7468041 -0.4639111
+#' rnormA(3)  # [1]  1.8285879 -0.7468041 -0.4639111
+#' rnormA(5)  # [1]  1.8285879 -0.7468041 -0.4639111 -1.6510126 -1.4686924
+#' rnormB(5)  # [1] -0.7946034  0.2568374 -0.6567597  1.2451387 -0.8375699
+#' 
+#' @export
+repeatable <- function(rngfunc, seed = runif(1, 0, .Machine$integer.max)) {
+  force(seed)
+  
+  function(...) {
+    # When we exit, restore the seed to its original state
+    if (exists('.Random.seed', where=globalenv())) {
+      currentSeed <- get('.Random.seed', pos=globalenv())
+      on.exit(assign('.Random.seed', currentSeed, pos=globalenv()))
+    }
+    else {
+      on.exit(rm('.Random.seed', pos=globalenv()))
+    }
+    
+    set.seed(seed)
+    
+    do.call(rngfunc, list(...))
+  }
+}
+
+`%OR%` <- function(x, y) {
+  ifelse(is.null(x) || is.na(x), y, x)
+}
+
+`%AND%` <- function(x, y) {
+  if (!is.null(x) && !is.na(x))
+    if (!is.null(y) && !is.na(y))
+      return(y)
+  return(NULL)
+}
+
+`%.%` <- function(x, y) {
+  paste(x, y, sep='')
+}
+
+knownContentTypes <- Map$new()
+knownContentTypes$mset(
+  html='text/html; charset=UTF-8',
+  htm='text/html; charset=UTF-8',
+  js='text/javascript',
+  css='text/css',
+  png='image/png',
+  jpg='image/jpeg',
+  jpeg='image/jpeg',
+  gif='image/gif',
+  svg='image/svg+xml',
+  txt='text/plain',
+  pdf='application/pdf',
+  ps='application/postscript',
+  xml='application/xml',
+  m3u='audio/x-mpegurl',
+  m4a='audio/mp4a-latm',
+  m4b='audio/mp4a-latm',
+  m4p='audio/mp4a-latm',
+  mp3='audio/mpeg',
+  wav='audio/x-wav',
+  m4u='video/vnd.mpegurl',
+  m4v='video/x-m4v',
+  mp4='video/mp4',
+  mpeg='video/mpeg',
+  mpg='video/mpeg',
+  avi='video/x-msvideo',
+  mov='video/quicktime',
+  ogg='application/ogg',
+  swf='application/x-shockwave-flash',
+  doc='application/msword',
+  xls='application/vnd.ms-excel',
+  ppt='application/vnd.ms-powerpoint',
+  xlsx='application/vnd.openxmlformats-officedocument.spreadsheetml.sheet',
+  xltx='application/vnd.openxmlformats-officedocument.spreadsheetml.template',
+  potx='application/vnd.openxmlformats-officedocument.presentationml.template',
+  ppsx='application/vnd.openxmlformats-officedocument.presentationml.slideshow',
+  pptx='application/vnd.openxmlformats-officedocument.presentationml.presentation',
+  sldx='application/vnd.openxmlformats-officedocument.presentationml.slide',
+  docx='application/vnd.openxmlformats-officedocument.wordprocessingml.document',
+  dotx='application/vnd.openxmlformats-officedocument.wordprocessingml.template',
+  xlam='application/vnd.ms-excel.addin.macroEnabled.12',
+  xlsb='application/vnd.ms-excel.sheet.binary.macroEnabled.12')
+
+getContentType <- function(ext, defaultType='application/octet-stream') {
+  knownContentTypes$get(tolower(ext)) %OR% defaultType
+}

inst/examples/10_download/server.R

@@ -0,0 +1,18 @@
+shinyServer(function(input, output) {
+  datasetInput <- reactive(function() {
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+  
+  output$table <- reactiveTable(function() {
+    datasetInput()
+  })
+  
+  output$downloadData <- downloadHandler(
+    filename = function() { paste(input$dataset, '.csv', sep='') },
+    content = function(conn) {
+      write.csv(datasetInput(), conn)
+    })
+})

inst/examples/10_download/ui.R

@@ -0,0 +1,11 @@
+shinyUI(pageWithSidebar(
+  headerPanel('Download Example'),
+  sidebarPanel(
+    selectInput("dataset", "Choose a dataset:", 
+                choices = c("rock", "pressure", "cars")),
+    downloadButton('downloadData', 'Download')
+  ),
+  mainPanel(
+    tableOutput('table')
+  )
+))

inst/www/shared/shiny.js

@@ -910,6 +910,17 @@
     }
   });
   outputBindings.register(htmlOutputBinding, 'shiny.htmlOutput');
+  
+  var downloadLinkOutputBinding = new OutputBinding();
+  $.extend(downloadLinkOutputBinding, {
+    find: function(scope) {
+      return $(scope).find('a.shiny-download-link');
+    },
+    renderValue: function(el, data) {
+      $(el).attr('href', data);
+    }
+  })
+  outputBindings.register(downloadLinkOutputBinding, 'shiny.downloadLink');
 
 
   var InputBinding = exports.InputBinding = function() {

man/downloadButton.Rd

@@ -0,0 +1,37 @@
+\name{downloadButton}
+\alias{downloadButton}
+\alias{downloadLink}
+\title{Create a download button or link}
+\usage{
+  downloadButton(outputId, label = "Download",
+    class = NULL)
+
+  downloadLink(outputId, label = "Download", class = NULL)
+}
+\description{
+  Use these functions to create a download button or link;
+  when clicked, it will initiate a browser download. The
+  filename and contents are specified by the corresponding
+  \code{\link{downloadHandler}} defined in the server
+  function.
+}
+\examples{
+\dontrun{
+# In server.R:
+output$downloadData <- downloadHandler(
+  filename = function() {
+    paste('data-', Sys.Date(), '.csv', sep='')
+  },
+  content = function(con) {
+    write.csv(data, con)
+  }
+)
+
+# In ui.R:
+downloadLink('downloadData', 'Download')
+}
+}
+\seealso{
+  downloadHandler
+}
+

man/downloadHandler.Rd

@@ -0,0 +1,55 @@
+\name{downloadHandler}
+\alias{downloadHandler}
+\title{File Downloads}
+\usage{
+  downloadHandler(filename, content, contentType = NA)
+}
+\arguments{
+  \item{filename}{A string of the filename, including
+  extension, that the user's web browser should default to
+  when downloading the file; or a function that returns
+  such a string. (Reactive values and functions may be used
+  from this function.)}
+
+  \item{content}{A function that takes a single argument
+  \code{con} that is a file connection opened in mode
+  \code{wb}, and writes the content of the download into
+  the connection. (Reactive values and functions may be
+  used from this function.)}
+
+  \item{contentType}{A string of the download's
+  \href{http://en.wikipedia.org/wiki/Internet_media_type}{content
+  type}, for example \code{"text/csv"} or
+  \code{"image/png"}. If \code{NULL} or \code{NA}, the
+  content type will be guessed based on the filename
+  extension, or \code{application/octet-stream} if the
+  extension is unknown.}
+}
+\description{
+  Allows content from the Shiny application to be made
+  available to the user as file downloads (for example,
+  downloading the currently visible data as a CSV file).
+  Both filename and contents can be calculated dynamically
+  at the time the user initiates the download. Assign the
+  return value to a slot on \code{output} in your server
+  function, and in the UI use \code{\link{downloadButton}}
+  or \code{\link{downloadLink}} to make the download
+  available.
+}
+\examples{
+\dontrun{
+# In server.R:
+output$downloadData <- downloadHandler(
+  filename = function() {
+    paste('data-', Sys.Date(), '.csv', sep='')
+  },
+  content = function(con) {
+    write.csv(data, con)
+  }
+)
+
+# In ui.R:
+downloadLink('downloadData', 'Download')
+}
+}
+

man/reactivePlot.Rd

@@ -9,11 +9,17 @@
 
   \item{width}{The width of the rendered plot, in pixels;
   or \code{'auto'} to use the \code{offsetWidth} of the
-  HTML element that is bound to this plot.}
+  HTML element that is bound to this plot.  You can also
+  pass in a function that returns the width in pixels or
+  \code{'auto'}; in the body of the function you may
+  reference reactive values and functions.}
 
   \item{height}{The height of the rendered plot, in pixels;
   or \code{'auto'} to use the \code{offsetHeight} of the
-  HTML element that is bound to this plot.}
+  HTML element that is bound to this plot.  You can also
+  pass in a function that returns the width in pixels or
+  \code{'auto'}; in the body of the function you may
+  reference reactive values and functions.}
 
   \item{...}{Arguments to be passed through to
   \code{\link[grDevices]{png}}.  These can be used to set

man/reactiveTable.Rd

@@ -9,7 +9,8 @@
   be used with \code{\link[xtable]{xtable}}.}
 
   \item{...}{Arguments to be passed through to
-  \code{\link[xtable]{xtable}}.}
+  \code{\link[xtable]{xtable}} and
+  \code{\link[xtable]{print.xtable}}.}
 }
 \description{
   Creates a reactive table that is suitable for assigning