Update NEWS

R CMD check didn't like Cairo::CairoPNG. With this method, check wants
Cairo to be imported in NAMESPACE, but it shouldn't be - Cairo should
be optional.

DESCRIPTION

@@ -1,34 +1,40 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.1.8
-Date: 2012-10-26
+Version: 0.2.4
+Date: 2012-11-30
 Author: RStudio, Inc.
-Maintainer: Joe Cheng <joe@rstudio.org>
+Maintainer: Winston Chang <winston@rstudio.com>
 Description: Shiny makes it incredibly easy to build interactive web
     applications with R. Automatic "reactive" binding between inputs and
     outputs and extensive pre-built widgets make it possible to build
     beautiful, responsive, and powerful applications with minimal effort.
 License: GPL-3
 Depends:
-    R (>= 2.14.1), websockets (>= 1.1.5)
+    R (>= 2.14.1)
 Imports:
     stats,
     tools,
     utils,
     datasets,
     methods,
+    websockets (>= 1.1.6),
     caTools,
     RJSONIO,
     xtable,
     digest
+Suggests:
+    markdown,
+    Cairo
 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'
+    'tar.R'
     'timer.R'
     'tags.R'
+    'cache.R'
     'react.R'
     'reactives.R'
     'fileupload.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)
@@ -21,9 +24,13 @@ export(helpText)
 export(HTML)
 export(htmlOutput)
 export(img)
+export(includeHTML)
+export(includeMarkdown)
+export(includeText)
 export(invalidateLater)
 export(mainPanel)
 export(numericInput)
+export(observe)
 export(p)
 export(pageWithSidebar)
 export(plotOutput)

NEWS

@@ -1,3 +1,83 @@
+shiny 0.2.3
+--------------------------------------------------------------------------------
+
+* Ignore request variables for routing purposes
+
+* `runGist` has been updated to use the new download URLs from
+  https://gist.github.com.
+
+* Shiny now uses `CairoPNG()` for output, when the Cairo package is available.
+  This provides better-looking output on Linux and Windows.
+
+shiny 0.2.2
+--------------------------------------------------------------------------------
+
+* Fix CRAN warning (assigning to global environment)
+
+
+shiny 0.2.1
+--------------------------------------------------------------------------------
+
+* [BREAKING] Modify API of `downloadHandler`: The `content` function now takes
+  a file path, not writable connection, as an argument. This makes it much
+  easier to work with APIs that only write to file paths, not connections.
+
+
+shiny 0.2.0
+--------------------------------------------------------------------------------
+
+* Fix subtle name resolution bug--the usual symptom being S4 methods not being
+  invoked correctly when called from inside of ui.R or server.R
+
+
+shiny 0.1.14
+--------------------------------------------------------------------------------
+
+* Fix slider animator, which broke in 0.1.10
+
+
+shiny 0.1.13
+--------------------------------------------------------------------------------
+
+* Fix temp file leak in reactivePlot
+
+
+shiny 0.1.12
+--------------------------------------------------------------------------------
+
+* Fix problems with runGist on Windows
+* Add feature for on-the-fly file downloads (e.g. CSV data, PDFs)
+* Add CSS hooks for app-wide busy indicators
+
+
+shiny 0.1.11
+--------------------------------------------------------------------------------
+
+* Fix input binding with IE8 on Shiny Server
+* Fix issue #41: reactiveTable should allow print options too
+* Allow dynamic sizing of reactivePlot (i.e. using a function instead of a fixed
+  value)
+
+
+shiny 0.1.10
+--------------------------------------------------------------------------------
+
+* Support more MIME types when serving out of www
+* Fix issue #35: Allow modification of untar args
+* headerPanel can take an explicit window title parameter
+* checkboxInput uses correct attribute `checked` instead of `selected`
+* Fix plot rendering with IE8 on Shiny Server
+
+
+shiny 0.1.9
+--------------------------------------------------------------------------------
+
+* Much less flicker when updating plots
+* More customizable error display
+* Add `includeText`, `includeHTML`, and `includeMarkdown` functions for putting
+  text, HTML, and Markdown content from external files in the application's UI.
+
+
 shiny 0.1.8
 --------------------------------------------------------------------------------
 

R/bootstrap.R

@@ -24,6 +24,12 @@ bootstrapPage <- function(...) {
     bs <- "shared/bootstrap/"
     
     result <- tags$head(
+      tags$link(rel="stylesheet", 
+                type="text/css", 
+                href="shared/slider/css/jquery.slider.min.css"),
+      
+      tags$script(src="shared/slider/js/jquery.slider.min.js"),
+      
       tags$link(rel="stylesheet", 
                 type="text/css", 
                 href=paste(bs, "css/bootstrap", cssExt, sep="")),
@@ -109,14 +115,16 @@ pageWithSidebar <- function(headerPanel, sidebarPanel, mainPanel) {
 #' Create a header panel containing an application title.
 #' 
 #' @param title An application title to display
+#' @param windowTitle The title that should be displayed by the browser window. 
+#'   Useful if \code{title} is not a string.
 #' @return A headerPanel that can be passed to \link{pageWithSidebar}
-#' 
+#'   
 #' @examples
 #' headerPanel("Hello Shiny!")
 #' @export
-headerPanel <- function(title) {    
+headerPanel <- function(title, windowTitle=title) {    
   tagList(
-    tags$head(tags$title(title)),
+    tags$head(tags$title(windowTitle)),
     div(class="span12", style="padding: 10px 0px;",
       h1(title)
     )
@@ -203,18 +211,18 @@ mainPanel <- function(...) {
 #' sidebarPanel(
 #'    selectInput(
 #'       "plotType", "Plot Type",
-#'       list(Scatter = "scatter",
-#'            Histogram = "hist")),
+#'       c(Scatter = "scatter",
+#'         Histogram = "hist")),
 #' 
 #'    # Only show this panel if the plot type is a histogram
 #'    conditionalPanel(
 #'       condition = "input.plotType == 'hist'",
 #'       selectInput(
 #'          "breaks", "Breaks",
-#'          list("Sturges", 
-#'               "Scott",
-#'               "Freedman-Diaconis",
-#'               "[Custom]" = "custom")),
+#'          c("Sturges",
+#'            "Scott",
+#'            "Freedman-Diaconis",
+#'            "[Custom]" = "custom")),
 #'               
 #'       # Only show this panel if Custom is selected
 #'       conditionalPanel(
@@ -349,9 +357,9 @@ checkboxInput <- function(inputId, label, value = FALSE) {
 #'   
 #' @examples
 #' checkboxGroupInput("variable", "Variable:",
-#'                    list("Cylinders" = "cyl", 
-#'                         "Transmission" = "am", 
-#'                         "Gears" = "gear"))
+#'                    c("Cylinders" = "cyl",
+#'                      "Transmission" = "am",
+#'                      "Gears" = "gear"))
 #'                  
 #' @export
 checkboxGroupInput <- function(inputId, label, choices, selected = NULL) {
@@ -365,7 +373,7 @@ checkboxGroupInput <- function(inputId, label, choices, selected = NULL) {
                            value = choices[[choiceName]])
     
     if (choiceName %in% selected)
-      checkbox$attribs$selected <- 'selected'
+      checkbox$attribs$checked <- 'checked'
     
     checkboxes[[length(checkboxes)+1]] <- checkbox
     checkboxes[[length(checkboxes)+1]] <- choiceName
@@ -381,22 +389,19 @@ checkboxGroupInput <- function(inputId, label, choices, selected = NULL) {
 
 #' Create a help text element
 #' 
-#' Create help text which can be added to an input form to provide
-#' additional explanation or context.
+#' Create help text which can be added to an input form to provide additional
+#' explanation or context.
 #' 
-#' @param text Help text string
-#' @param ... Additional help text strings
+#' @param ... One or more help text strings (or other inline HTML elements)
 #' @return A help text element that can be added to a UI definition.
-#' 
+#'   
 #' @examples
 #' helpText("Note: while the data view will show only",
 #'          "the specified number of observations, the",
 #'          "summary will be based on the full dataset.")
 #' @export
-helpText <- function(text, ...) {
-  text <- c(text, as.character(list(...)))
-  text <- paste(text, collapse=" ")
-  span(class="help-block", text)
+helpText <- function(...) {
+  span(class="help-block", ...)
 }
 
 controlLabel <- function(controlName, label) {
@@ -435,9 +440,9 @@ choicesWithNames <- function(choices) {
 #' 
 #' @examples
 #' selectInput("variable", "Variable:",
-#'             list("Cylinders" = "cyl", 
-#'                  "Transmission" = "am", 
-#'                  "Gears" = "gear"))
+#'             c("Cylinders" = "cyl",
+#'               "Transmission" = "am",
+#'               "Gears" = "gear"))
 #' @export
 selectInput <- function(inputId, 
                         label, 
@@ -480,10 +485,10 @@ selectInput <- function(inputId,
 #' 
 #' @examples
 #' radioButtons("dist", "Distribution type:",
-#'              list("Normal" = "norm",
-#'                   "Uniform" = "unif",
-#'                   "Log-normal" = "lnorm",
-#'                   "Exponential" = "exp"))
+#'              c("Normal" = "norm",
+#'                "Uniform" = "unif",
+#'                "Log-normal" = "lnorm",
+#'                "Exponential" = "exp"))
 #' @export
 radioButtons <- function(inputId, label, choices, selected = NULL) {
   # resolve names
@@ -584,10 +589,10 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   if (!is.character(labelText))
     stop("label not specified")
   
-  if (identical(animate, T))
+  if (identical(animate, TRUE))
     animate <- animationOptions()
   
-  if (!is.null(animate) && !identical(animate, F)) {
+  if (!is.null(animate) && !identical(animate, FALSE)) {
     if (is.null(animate$playButton))
       animate$playButton <- tags$i(class='icon-play')
     if (is.null(animate$pauseButton))
@@ -788,3 +793,52 @@ 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.
+#' 
+#' @param outputId The name of the output slot that the \code{downloadHandler}
+#'   is assigned to.
+#' @param label The label that should appear on the button.
+#' @param class Additional CSS classes to apply to the tag, if any.
+#'   
+#' @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/cache.R

@@ -0,0 +1,80 @@
+# A context object for tracking a cache that needs to be dirtied when a set of 
+# files changes on disk. Each time the cache is dirtied, the set of files is 
+# cleared. Therefore, the set of files needs to be re-built each time the cached
+# code executes. This approach allows for dynamic dependency graphs.
+CacheContext <- setRefClass(
+  'CacheContext',
+  fields = list(
+    .dirty = 'logical',
+    .tests = 'list'
+  ),
+  methods = list(
+    initialize = function() {
+      .dirty <<- TRUE
+      # List of functions that return TRUE if dirty
+      .tests <<- list()
+    },
+    addDependencyFile = function(file) {
+      if (.dirty)
+        return()
+      
+      file <- normalizePath(file)
+
+      mtime <- file.info(file)$mtime
+      .tests <<- c(.tests, function() {
+        newMtime <- try(file.info(file)$mtime, silent=TRUE)
+        if (is(newMtime, 'try-error'))
+          return(TRUE)
+        return(!identical(mtime, newMtime))
+      })
+      invisible()
+    },
+    forceDirty = function() {
+      .dirty <<- TRUE
+      .tests <<- list()
+      invisible()
+    },
+    isDirty = function() {
+      if (.dirty)
+        return(TRUE)
+      
+      for (test in .tests) {
+        if (test()) {
+          forceDirty()
+          return(TRUE)
+        }
+      }
+      
+      return(FALSE)
+    },
+    reset = function() {
+      .dirty <<- FALSE
+      .tests <<- list()
+    },
+    with = function(func) {
+      oldCC <- .currentCacheContext$cc
+      .currentCacheContext$cc <- .self
+      on.exit(.currentCacheContext$cc <- oldCC)
+      
+      return(func())
+    }
+  )
+)
+
+.currentCacheContext <- new.env()
+
+# Indicates to Shiny that the given file path is part of the dependency graph 
+# for whatever is currently executing (so far, only ui.R). By default, ui.R only
+# gets re-executed when it is detected to have changed; this function allows the
+# caller to indicate that it should also re-execute if the given file changes.
+# 
+# If NULL or NA is given as the argument, then ui.R will re-execute next time.
+dependsOnFile <- function(filepath) {
+  if (is.null(.currentCacheContext$cc))
+    stop("addFileDependency was called at an unexpected time (no cache context found)")
+  
+  if (is.null(filepath) || is.na(filepath))
+    .currentCacheContext$cc$forceDirty()
+  else
+    .currentCacheContext$cc$addDependencyFile(filepath)
+}

R/fileupload.R

@@ -41,7 +41,7 @@ FileUploadOperation <- setRefClass(
 
       filename <- file.path(.dir, as.character(length(.files)))
       row <- data.frame(name=file$name, size=file$size, type=file$type,
-                        datapath=filename, stringsAsFactors=F)
+                        datapath=filename, stringsAsFactors=FALSE)
       
       if (length(.files) == 0)
         .files <<- row
@@ -74,7 +74,7 @@ FileUploadContext <- setRefClass(
       .basedir <<- dir
     },
     createUploadOperation = function() {
-      while (T) {
+      while (TRUE) {
         id <- paste(as.raw(runif(12, min=0, max=0xFF)), collapse='')
         dir <- file.path(.basedir, id)
         if (!dir.create(dir))

R/map.R

@@ -20,30 +20,36 @@ Map <- setRefClass(
     },
     get = function(key) {
       if (.self$containsKey(key))
-        return(base::get(key, pos=.env, inherits=F))
+        return(base::get(key, pos=.env, inherits=FALSE))
       else
         return(NULL)
     },
     set = function(key, value) {
-      assign(key, value, pos=.env, inherits=F)
+      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)
-        rm(list = key, pos=.env, inherits=F)
+        rm(list = key, pos=.env, inherits=FALSE)
         return(result)
       }
       return(NULL)
     },
     containsKey = function(key) {
-      exists(key, where=.env, inherits=F)
+      exists(key, where=.env, inherits=FALSE)
     },
     keys = function() {
-      ls(envir=.env, all.names=T)
+      ls(envir=.env, all.names=TRUE)
     },
     values = function() {
-      mget(.self$keys(), envir=.env, inherits=F)
+      mget(.self$keys(), envir=.env, inherits=FALSE)
     },
     clear = function() {
       .env <<- new.env(parent=emptyenv())
@@ -67,7 +73,7 @@ Map <- setRefClass(
 as.list.Map <- function(map) {
   sapply(map$keys(),
          map$get,
-         simplify=F)
+         simplify=FALSE)
 }
 length.Map <- function(map) {
   map$size()

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/react.R

@@ -9,7 +9,7 @@ Context <- setRefClass(
   methods = list(
     initialize = function() {
       id <<- .getReactiveEnvironment()$nextId()
-      .invalidated <<- F
+      .invalidated <<- FALSE
       .callbacks <<- list()
       .hintCallbacks <<- list()
     },
@@ -32,7 +32,7 @@ Context <- setRefClass(
         invalidated until the next call to \\code{\\link{flushReact}}."
       if (.invalidated)
         return()
-      .invalidated <<- T
+      .invalidated <<- TRUE
       .getReactiveEnvironment()$addPendingInvalidate(.self)
       NULL
     },
@@ -106,11 +106,9 @@ ReactiveEnvironment <- setRefClass(
   )
 )
 
+.reactiveEnvironment <- ReactiveEnvironment$new()
 .getReactiveEnvironment <- function() {
-  if (!exists('.ReactiveEnvironment', envir=.GlobalEnv, inherits=F)) {
-    assign('.ReactiveEnvironment', ReactiveEnvironment$new(), envir=.GlobalEnv)
-  }
-  get('.ReactiveEnvironment', envir=.GlobalEnv, inherits=F)
+  .reactiveEnvironment
 }
 
 # Causes any pending invalidations to run.

R/reactives.R

@@ -52,21 +52,21 @@ Values <- setRefClass(
     get = function(key) {
       ctx <- .getReactiveEnvironment()$currentContext()
       dep.key <- paste(key, ':', ctx$id, sep='')
-      if (!exists(dep.key, where=.dependencies, inherits=F)) {
-        assign(dep.key, ctx, pos=.dependencies, inherits=F)
+      if (!exists(dep.key, where=.dependencies, inherits=FALSE)) {
+        assign(dep.key, ctx, pos=.dependencies, inherits=FALSE)
         ctx$onInvalidate(function() {
-          rm(list=dep.key, pos=.dependencies, inherits=F)
+          rm(list=dep.key, pos=.dependencies, inherits=FALSE)
         })
       }
       
-      if (!exists(key, where=.values, inherits=F))
+      if (!exists(key, where=.values, inherits=FALSE))
         NULL
       else
-        base::get(key, pos=.values, inherits=F)
+        base::get(key, pos=.values, inherits=FALSE)
     },
     set = function(key, value) {
-      if (exists(key, where=.values, inherits=F)) {
-        if (identical(base::get(key, pos=.values, inherits=F), value)) {
+      if (exists(key, where=.values, inherits=FALSE)) {
+        if (identical(base::get(key, pos=.values, inherits=FALSE), value)) {
           return(invisible())
         }
       }
@@ -75,11 +75,11 @@ Values <- setRefClass(
       }
       .allDeps$invalidate()
       
-      assign(key, value, pos=.values, inherits=F)
+      assign(key, value, pos=.values, inherits=FALSE)
       dep.keys <- objects(
         pos=.dependencies,
         pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''),
-        all.names=T
+        all.names=TRUE
       )
       lapply(
         mget(dep.keys, envir=.dependencies),
@@ -99,7 +99,7 @@ Values <- setRefClass(
     },
     names = function() {
       .namesDeps$register()
-      return(ls(.values, all.names=T))
+      return(ls(.values, all.names=TRUE))
     },
     toList = function() {
       .allDeps$register()
@@ -153,11 +153,11 @@ Observable <- setRefClass(
              "or more parameters; only functions without parameters can be ",
              "reactive.")
       .func <<- func
-      .initialized <<- F
+      .initialized <<- FALSE
     },
     getValue = function() {
       if (!.initialized) {
-        .initialized <<- T
+        .initialized <<- TRUE
         .self$.updateValue()
       }
       
@@ -178,7 +178,7 @@ Observable <- setRefClass(
         .dependencies$invalidateHint()
       })
       ctx$run(function() {
-        .value <<- try(.func(), silent=F)
+        .value <<- try(.func(), silent=FALSE)
       })
       if (!identical(old.value, .value)) {
         .dependencies$invalidate()
@@ -261,21 +261,29 @@ Observer <- setRefClass(
   )
 )
 
-# NOTE: we de-roxygenized this comment because the function isn't exported
-# Observe
-# 
-# Creates an observer from the given function. An observer is like a reactive 
-# function in that it can read reactive values and call reactive functions, 
-# and will automatically re-execute when those dependencies change. But unlike
-# reactive functions, it doesn't yield a result and can't be used as an input 
-# to other reactive functions. Thus, observers are only useful for their side 
-# effects (for example, performing I/O).
-#
-# @param func The function to observe. It must not have any parameters. Any
-# return value from this function will be ignored.
-#
+#' Create a reactive observer
+#' 
+#' Creates an observer from the given function. An observer is like a reactive 
+#' function in that it can read reactive values and call reactive functions, and
+#' will automatically re-execute when those dependencies change. But unlike 
+#' reactive functions, it doesn't yield a result and can't be used as an input 
+#' to other reactive functions. Thus, observers are only useful for their side 
+#' effects (for example, performing I/O).
+#' 
+#' Another contrast between reactive functions and observers is their execution
+#' strategy. Reactive functions use lazy evaluation; that is, when their
+#' dependencies change, they don't re-execute right away but rather wait until
+#' they are called by someone else. Indeed, if they are not called then they
+#' will never re-execute. In contrast, observers use eager evaluation; as soon
+#' as their dependencies change, they schedule themselves to re-execute.
+#' 
+#' @param func The function to observe. It must not have any parameters. Any 
+#'   return value from this function will be ignored.
+#'   
+#' @export
 observe <- function(func) {
   Observer$new(func)
+  invisible()
 }
 
 #' Timer

R/shiny.R

@@ -7,6 +7,11 @@ suppressPackageStartupMessages({
   library(RJSONIO)
 })
 
+createUniqueId <- function(bytes) {
+  # TODO: Use a method that isn't affected by the R seed
+  paste(as.character(as.raw(floor(runif(bytes, min=1, max=255)))), collapse='')
+}
+
 ShinyApp <- setRefClass(
   'ShinyApp',
   fields = list(
@@ -15,7 +20,11 @@ ShinyApp <- setRefClass(
     .invalidatedOutputErrors = 'Map',
     .progressKeys = 'character',
     .fileUploadContext = 'FileUploadContext',
-    session = 'Values'
+    session = 'Values',
+    token = 'character',  # Used to identify this instance in URLs
+    plots = 'Map',
+    downloads = 'Map',
+    allowDataUriScheme = 'logical'
   ),
   methods = list(
     initialize = function(ws) {
@@ -26,6 +35,10 @@ ShinyApp <- setRefClass(
       # TODO: Put file upload context in user/app-specific dir if possible
       .fileUploadContext <<- FileUploadContext$new()
       session <<- Values$new()
+      
+      token <<- createUniqueId(16)
+      
+      allowDataUriScheme <<- TRUE
     },
     defineOutput = function(name, func) {
       "Binds an output generating function to this name. The function can either
@@ -47,7 +60,7 @@ ShinyApp <- setRefClass(
 
         obs <- Observer$new(function() {
           
-          value <- try(func(), silent=F)
+          value <- try(func(), silent=FALSE)
           
           .invalidatedOutputErrors$remove(name)
           .invalidatedOutputValues$remove(name)
@@ -106,7 +119,7 @@ ShinyApp <- setRefClass(
     },
     dispatch = function(msg) {
       method <- paste('@', msg$method, sep='')
-      func <- try(do.call(`$`, list(.self, method)), silent=T)
+      func <- try(do.call(`$`, list(.self, method)), silent=TRUE)
       if (inherits(func, 'try-error')) {
         .sendErrorResponse(msg, paste('Unknown method', msg$method))
       }
@@ -133,9 +146,10 @@ ShinyApp <- setRefClass(
       .write(toJSON(list(response=list(tag=requestMsg$tag, error=error))))
     },
     .write = function(json) {
-      if (getOption('shiny.trace', F))
-        message('SEND ', json)
-      if (getOption('shiny.transcode.json', T))
+      if (getOption('shiny.trace', FALSE))
+        message('SEND ', 
+           gsub('(?m)base64,[a-zA-Z0-9+/=]+','[base64 data]',json,perl=TRUE))
+      if (getOption('shiny.transcode.json', TRUE))
         json <- iconv(json, to='UTF-8')
       websocket_write(json, .websocket)
     },
@@ -165,6 +179,110 @@ ShinyApp <- setRefClass(
       fileData <- .fileUploadContext$getUploadOperation(jobId)$finish()
       session$set(inputId, fileData)
       invisible()
+    },
+    # Provides a mechanism for handling direct HTTP requests that are posted
+    # to the session (rather than going through the websocket)
+    handleRequest = function(ws, header, subpath) {
+      # TODO: Turn off caching for the response
+      
+      matches <- regmatches(subpath,
+                            regexec("^/([a-z]+)/([^?]*)", 
+                                    subpath, 
+                                    ignore.case=TRUE))[[1]]
+      if (length(matches) == 0)
+        return(httpResponse(400, 'text/html', '<h1>Bad Request</h1>'))
+      
+      if (matches[2] == 'plot') {
+        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))
+        result <- try(Context$new()$run(function() { download$func(tmpdata) }))
+        if (is(result, 'try-error')) {
+          return(httpResponse(500, 'text/plain', 
+                              attr(result, 'condition')$message))
+        }
+        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, 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)))
     }
   )
 )
@@ -185,8 +303,8 @@ resolve <- function(dir, relpath) {
   abs.path <- file.path(dir, relpath)
   if (!file.exists(abs.path))
     return(NULL)
-  abs.path <- normalizePath(abs.path, winslash='/', mustWork=T)
-  dir <- normalizePath(dir, winslash='/', mustWork=T)
+  abs.path <- normalizePath(abs.path, winslash='/', mustWork=TRUE)
+  dir <- normalizePath(dir, winslash='/', mustWork=TRUE)
   if (nchar(abs.path) <= nchar(dir) + 1)
     return(NULL)
   if (substr(abs.path, 1, nchar(dir)) != dir ||
@@ -198,12 +316,24 @@ resolve <- function(dir, relpath) {
 
 httpResponse <- function(status = 200,
                          content_type = "text/html; charset=UTF-8", 
-                         content = "") {
-  resp <- list(status = status, content_type = content_type, content = content);
+                         content = "",
+                         headers = c()) {
+  resp <- list(status = status, content_type = content_type, content = content,
+               headers = headers)
   class(resp) <- 'httpResponse'
   return(resp)
 }
 
+fixupRequestPath <- function(header) {
+  # Separate the path from the query
+  pathEnd <- regexpr('?', header$RESOURCE, fixed=TRUE)
+  if (pathEnd > 0)
+    header$PATH <- substring(header$RESOURCE, 1, pathEnd - 1)
+  else
+    header$PATH <- header$RESOURCE
+  return(header)
+}
+
 httpServer <- function(handlers) {
   handler <- joinHandlers(handlers)
 
@@ -212,6 +342,8 @@ httpServer <- function(handlers) {
     filter <- function(ws, header, response) response
   
   function(ws, header) {
+    header <- fixupRequestPath(header)
+    
     response <- handler(ws, header)
     if (is.null(response))
       response <- httpResponse(404, content="<h1>Not Found</h1>")
@@ -221,7 +353,8 @@ httpServer <- function(handlers) {
     return(http_response(ws,
                          status=response$status,
                          content_type=response$content_type,
-                         content=response$content))
+                         content=response$content,
+                         headers=response$headers))
   }
 }
 
@@ -251,6 +384,25 @@ joinHandlers <- function(handlers) {
   }
 }
 
+sessionHandler <- function(ws, header) {
+  path <- header$PATH
+  if (is.null(path))
+    return(NULL)
+  
+  matches <- regmatches(path, regexec('^/session/([0-9a-f]+)(/.*)$', path))
+  if (length(matches[[1]]) == 0)
+    return(NULL)
+  
+  session <- matches[[1]][2]
+  subpath <- matches[[1]][3]
+  
+  shinyapp <- appsByToken$get(session)
+  if (is.null(shinyapp))
+    return(NULL)
+  
+  return(shinyapp$handleRequest(ws, header, subpath))
+}
+
 dynamicHandler <- function(filePath, dependencyFiles=filePath) {
   lastKnownTimestamps <- NA
   metaHandler <- function(ws, header) NULL
@@ -258,15 +410,21 @@ dynamicHandler <- function(filePath, dependencyFiles=filePath) {
   if (!file.exists(filePath))
     return(metaHandler)
   
+  cacheContext <- CacheContext$new()
+  
   return (function(ws, header) {
     # Check if we need to rebuild
-    mtime <- file.info(dependencyFiles)$mtime
-    if (!identical(lastKnownTimestamps, mtime)) {
-      lastKnownTimestamps <<- mtime
+    if (cacheContext$isDirty()) {
+      cacheContext$reset()
+      for (dep in dependencyFiles)
+        cacheContext$addDependencyFile(dep)
+
       clearClients()
       if (file.exists(filePath)) {
         local({
-          source(filePath, local=T)
+          cacheContext$with(function() {
+            source(filePath, local=new.env(parent=.GlobalEnv))
+          })
         })
       }
       metaHandler <<- joinHandlers(.globals$clients)
@@ -279,7 +437,7 @@ dynamicHandler <- function(filePath, dependencyFiles=filePath) {
 
 staticHandler <- function(root) {
   return(function(ws, header) {
-    path <- header$RESOURCE
+    path <- header$PATH
     
     if (is.null(path))
       return(httpResponse(400, content="<h1>Bad Request</h1>"))
@@ -292,22 +450,14 @@ 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',
-                           '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))
   })
 }
 
 apps <- Map$new()
+appsByToken <- Map$new()
 
 # Provide a character representation of the WS that can be used
 # as a key in a Map.
@@ -358,7 +508,7 @@ registerClient <- function(client) {
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
   prefix <- prefix[1]
-  if (!grepl('^[a-z][a-z0-9\\-_]*$', prefix, ignore.case=T, perl=T)) {
+  if (!grepl('^[a-z][a-z0-9\\-_]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
     stop("addResourcePath called with invalid prefix; please see documentation")
   }
   
@@ -367,7 +517,7 @@ addResourcePath <- function(prefix, directoryPath) {
          "please use a different prefix")
   }
   
-  directoryPath <- normalizePath(directoryPath, mustWork=T)
+  directoryPath <- normalizePath(directoryPath, mustWork=TRUE)
   
   existing <- .globals$resources[[prefix]]
   
@@ -387,7 +537,7 @@ addResourcePath <- function(prefix, directoryPath) {
 resourcePathHandler <- function(ws, header) {
   path <- header$RESOURCE
   
-  match <- regexpr('^/([^/]+)/', path, perl=T)
+  match <- regexpr('^/([^/]+)/', path, perl=TRUE)
   if (match == -1)
     return(NULL)
   len <- attr(match, 'capture.length')
@@ -400,6 +550,7 @@ resourcePathHandler <- function(ws, header) {
   suffix <- substr(path, 2 + len, nchar(path))
   
   header$RESOURCE <- suffix
+  header <- fixupRequestPath(header)
   
   return(resInfo$func(ws, header))
 }
@@ -448,7 +599,7 @@ decodeMessage <- function(data) {
   }
   
   if (readInt(1) != 0x01020202L)
-    return(fromJSON(rawToChar(data), asText=T, simplify=F))
+    return(fromJSON(rawToChar(data), asText=TRUE, simplify=FALSE))
   
   i <- 5
   parts <- list()
@@ -514,13 +665,13 @@ startApp <- function(port=8101L) {
     stop(paste("server.R file was not found in", getwd()))
   
   if (file.exists(globalR))
-    source(globalR, local=F)
+    source(globalR, local=FALSE)
   
   shinyServer(NULL)
   serverFileTimestamp <- NULL
   local({
     serverFileTimestamp <<- file.info(serverR)$mtime
-    source(serverR, local=T)
+    source(serverR, local=new.env(parent=.GlobalEnv))
     if (is.null(.globals$server))
       stop("No server was defined in server.R")
   })
@@ -528,7 +679,8 @@ startApp <- function(port=8101L) {
   
   ws_env <- create_server(
     port=port,
-    webpage=httpServer(c(dynamicHandler(uiR),
+    webpage=httpServer(c(sessionHandler,
+                         dynamicHandler(uiR),
                          wwwDir,
                          sys.www.root,
                          resourcePathHandler)))
@@ -536,14 +688,18 @@ startApp <- function(port=8101L) {
   set_callback('established', function(WS, ...) {
     shinyapp <- ShinyApp$new(WS)
     apps$set(wsToKey(WS), shinyapp)
+    appsByToken$set(shinyapp$token, shinyapp)
   }, ws_env)
   
   set_callback('closed', function(WS, ...) {
+    shinyapp <- apps$get(wsToKey(WS))
+    if (!is.null(shinyapp))
+      appsByToken$remove(shinyapp$token)
     apps$remove(wsToKey(WS))
   }, ws_env)
   
   set_callback('receive', function(DATA, WS, ...) {
-    if (getOption('shiny.trace', F)) {
+    if (getOption('shiny.trace', FALSE)) {
       if (as.raw(0) %in% DATA)
         message("RECV ", '$$binary data$$')
       else
@@ -575,7 +731,7 @@ startApp <- function(port=8101L) {
           )
         }
         else if (is.list(val) && is.null(names(val)))
-          msg$data[[name]] <- unlist(val, recursive=F)
+          msg$data[[name]] <- unlist(val, recursive=FALSE)
       }
     }
     
@@ -589,13 +745,15 @@ startApp <- function(port=8101L) {
           shinyServer(NULL)
           local({
             serverFileTimestamp <<- mtime
-            source(serverR, local=T)
+            source(serverR, local=new.env(parent=.GlobalEnv))
             if (is.null(.globals$server))
               stop("No server was defined in server.R")
           })
           serverFunc <<- .globals$server
         }
         
+        shinyapp$allowDataUriScheme <- msg$data[['__allowDataUriScheme']]
+        msg$data[['__allowDataUriScheme']] <- NULL
         shinyapp$session$mset(msg$data)
         flushReact()
         local({
@@ -619,7 +777,7 @@ startApp <- function(port=8101L) {
 
 # NOTE: we de-roxygenized this comment because the function isn't exported
 # Run an application that was created by \code{\link{startApp}}. This
-# function should normally be called in a \code{while(T)} loop.
+# function should normally be called in a \code{while(TRUE)} loop.
 # 
 # @param ws_env The return value from \code{\link{startApp}}.
 serviceApp <- function(ws_env) {
@@ -667,6 +825,8 @@ runApp <- function(appDir=getwd(),
   setwd(appDir)
   on.exit(setwd(orig.wd))
   
+  require(shiny)
+  
   ws_env <- startApp(port=port)
   
   if (launch.browser) {
@@ -675,10 +835,11 @@ runApp <- function(appDir=getwd(),
   }
   
   tryCatch(
-    while (T) {
+    while (TRUE) {
       serviceApp(ws_env)
     },
     finally = {
+      timerCallbacks$clear()
       websocket_close(ws_env)
     }
   )
@@ -742,18 +903,27 @@ download <- function(url, ...) {
       mySI2(TRUE)
       download.file(url, ...)
       
+    } else {
       # If non-Windows, check for curl/wget/lynx, then call download.file with
       # appropriate method.
-    } else {
       
-      if (system("wget --help > /dev/null") == 0L) 
+      if (nzchar(Sys.which("wget")[1])) {
         method <- "wget"
-      else if (system("curl --help > /dev/null") == 0L) 
+      } else if (nzchar(Sys.which("curl")[1])) {
         method <- "curl"
-      else if (system("lynx -help > /dev/null") == 0L) 
+        
+        # curl needs to add a -L option to follow redirects.
+        # Save the original options and restore when we exit.
+        orig_extra_options <- getOption("download.file.extra")
+        on.exit(options(download.file.extra = orig_extra_options))
+        
+        options(download.file.extra = paste("-L", orig_extra_options))
+        
+      } else if (nzchar(Sys.which("lynx")[1])) {
         method <- "lynx"
-      else
+      } else {
         stop("no download method found")
+      }
       
       download.file(url, method = method, ...)
     }
@@ -783,13 +953,9 @@ runGist <- function(gist,
                                              interactive())) {
 
   gistUrl <- if (is.numeric(gist) || grepl('^[0-9a-f]+$', gist)) {
-    sprintf('https://gist.github.com/gists/%s/download', gist)
+    sprintf('https://gist.github.com/%s/download', gist)
   } else if(grepl('^https://gist.github.com/([0-9a-f]+)$', gist)) {
-    paste(sub('https://gist.github.com/',
-              'https://gist.github.com/gists/',
-              gist),
-          '/download',
-          sep='')
+    paste(gist, '/download', sep='')
   } else {
     stop('Unrecognized gist identifier format')
   }
@@ -797,12 +963,18 @@ runGist <- function(gist,
   if (download(gistUrl, filePath, mode = "wb", quiet = TRUE) != 0)
     stop("Failed to download URL ", gistUrl)
   on.exit(unlink(filePath))
-  
-  dirname <- untar(filePath, list=TRUE)[1]
-  untar(filePath, exdir=dirname(filePath))
+
+  # Regular untar commonly causes two problems on Windows with github tarballs:
+  #   1) If RTools' tar.exe is in the path, you get cygwin path warnings which
+  #      throw list=TRUE off;
+  #   2) If the internal untar implementation is used, it chokes on the 'g'
+  #      type flag that github uses (to stash their commit hash info).
+  # By using our own forked/modified untar2 we sidestep both issues.
+  dirname <- untar2(filePath, list=TRUE)[1]
+  untar2(filePath, exdir = dirname(filePath))
   
   appdir <- file.path(dirname(filePath), dirname)
   on.exit(unlink(appdir, recursive = TRUE))
   
-  shiny::runApp(appdir, port=port, launch.browser=launch.browser)
+  runApp(appdir, port=port, launch.browser=launch.browser)
 }

R/shinyui.R

@@ -47,6 +47,31 @@ strong <- function(...) tags$strong(...)
 #' @export
 em <- function(...) tags$em(...)
 
+#' @export
+includeHTML <- function(path) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  return(HTML(paste(lines, collapse='\r\n')))
+}
+
+#' @export
+includeText <- function(path) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  return(HTML(paste(lines, collapse='\r\n')))
+}
+
+#' @export
+includeMarkdown <- function(path) {
+  if (!require(markdown))
+    stop("Markdown package is not installed")
+  
+  dependsOnFile(path)
+  html <- markdown::markdownToHTML(path, fragment.only=TRUE)
+  Encoding(html) <- 'UTF-8'
+  return(HTML(html))
+}
+
 
 #' Include Content Only Once
 #' 
@@ -159,10 +184,13 @@ renderPage <- function(ui, connection) {
 #' @export
 shinyUI <- function(ui, path='/') {
   
+  force(ui)
+  
   registerClient({
     
     function(ws, header) {
-      if (header$RESOURCE != path)
+
+      if (header$PATH != path)
         return(NULL)
       
       textConn <- textConnection(NULL, "w") 

R/shinywrappers.R

@@ -10,12 +10,24 @@ suppressPackageStartupMessages({
 #' 
 #' The corresponding HTML output tag should be \code{div} or \code{img} and have
 #' the CSS class name \code{shiny-plot-output}.
+#'
+#' For output, it will try to use the following devices, in this order:
+#' quartz (via \code{\link[grDevices]{png}}), then \code{\link[Cairo]{CairoPNG}},
+#' and finally \code{\link[grDevices]{png}}. This is in order of quality of
+#' output. Notably, plain \code{png} output on Linux and Windows may not
+#' antialias some point shapes, resulting in poor quality output.
 #' 
 #' @param func A function that generates a plot.
-#' @param 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.
-#' @param 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.
+#' @param 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. 
+#'   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.
+#' @param 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.
+#'   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.
 #' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}. 
 #'   These can be used to set the width, height, background color, etc.
 #'   
@@ -23,9 +35,19 @@ suppressPackageStartupMessages({
 reactivePlot <- function(func, width='auto', height='auto', ...) {
   args <- list(...)
   
+  if (is.function(width))
+    width <- reactive(width)
+  if (is.function(height))
+    height <- reactive(height)
+
   return(function(shinyapp, name, ...) {
     png.file <- tempfile(fileext='.png')
     
+    if (is.function(width))
+      width <- width()
+    if (is.function(height))
+      height <- height()
+    
     # Note that these are reactive calls. A change to the width and height
     # will inherently cause a reactive plot to redraw (unless width and 
     # height were explicitly specified).
@@ -37,8 +59,21 @@ reactivePlot <- function(func, width='auto', height='auto', ...) {
     
     if (width <= 0 || height <= 0)
       return(NULL)
-    
-    do.call(png, c(args, filename=png.file, width=width, height=height))
+
+    # If quartz is available, use png() (which will default to quartz).
+    # Otherwise, if the Cairo package is installed, use CairoPNG().
+    # Finally, if neither quartz nor Cairo, use png().
+    if (capabilities("aqua")) {
+      pngfun <- png
+    } else if (nchar(system.file(package = "Cairo"))) {
+      require(Cairo)
+      pngfun <- CairoPNG
+    } else {
+      pngfun <- png
+    }
+
+    do.call(pngfun, c(args, filename=png.file, width=width, height=height))
+    on.exit(unlink(png.file))
     tryCatch(
       func(),
       finally=dev.off())
@@ -47,8 +82,15 @@ reactivePlot <- function(func, width='auto', height='auto', ...) {
     if (is.na(bytes))
       return(NULL)
     
-    b64 <- base64encode(readBin(png.file, 'raw', n=bytes))
-    return(paste("data:image/png;base64,", b64, sep=''))
+    pngData <- readBin(png.file, 'raw', n=bytes)
+    if (shinyapp$allowDataUriScheme) {
+      b64 <- base64encode(pngData)
+      return(paste("data:image/png;base64,", b64, sep=''))
+    }
+    else {
+      imageUrl <- shinyapp$savePlot(name, pngData, 'image/png')
+      return(imageUrl)
+    }
   })
 }
 
@@ -62,7 +104,8 @@ reactivePlot <- function(func, width='auto', height='auto', ...) {
 #' 
 #' @param func A function that returns an R object that can be used with 
 #'   \code{\link[xtable]{xtable}}.
-#' @param ... Arguments to be passed through to \code{\link[xtable]{xtable}}.
+#' @param ... Arguments to be passed through to \code{\link[xtable]{xtable}} and
+#'   \code{\link[xtable]{print.xtable}}.
 #'   
 #' @export
 reactiveTable <- function(func, ...) {
@@ -78,9 +121,9 @@ reactiveTable <- function(func, ...) {
         print(xtable(data, ...), 
               type='html', 
               html.table.attributes=paste('class="',
-                                          htmlEscape(classNames, T),
+                                          htmlEscape(classNames, TRUE),
                                           '"',
-                                          sep=''))),
+                                          sep=''), ...)),
       collapse="\n"))
   })
 }
@@ -157,6 +200,54 @@ reactiveUI <- function(func) {
     result <- func()
     if (is.null(result) || length(result) == 0)
       return(NULL)
-    return(as.character(result))
+    # Wrap result in tagList in case it is an ordinary list
+    return(as.character(tagList(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{file} that is a 
+#'   file path (string) of a nonexistent temp file, and writes the content to
+#'   that file path. (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(file) {
+#'     write.csv(data, file)
+#'   }
+#' )
+#' 
+#' # In ui.R:
+#' downloadLink('downloadData', 'Download')
+#' }
+#' 
+#' @export
+downloadHandler <- function(filename, content, contentType=NA) {
+  return(function(shinyapp, name, ...) {
+    shinyapp$registerDownload(name, filename, contentType, content)
+  })
+}

R/slider.R

@@ -70,7 +70,7 @@ slider <- function(inputId, min, max, value, step = NULL, ...,
   }
   
   # Default state is to not have ticks
-  if (identical(ticks, T)) {
+  if (identical(ticks, TRUE)) {
     # Automatic ticks
     tickCount <- (range / step) + 1
     if (tickCount <= 26)
@@ -101,28 +101,18 @@ slider <- function(inputId, min, max, value, step = NULL, ...,
   }
   
   # build slider
-  sliderFragment <- list(
-    singleton(
-      tags$head(
-        tags$link(rel="stylesheet", 
-                  type="text/css", 
-                  href="shared/slider/css/jquery.slider.min.css"),
-        
-        tags$script(src="shared/slider/js/jquery.slider.min.js")
-      )
-    ),
-    tags$input(id=inputId, type="slider", 
-               name=inputId, value=paste(value, collapse=';'), class="jslider",
-               'data-from'=min, 'data-to'=max, 'data-step'=step,
-               'data-skin'='plastic', 'data-round'=round, 'data-locale'=locale,
-               'data-format'=format, 'data-scale'=ticks,
-               'data-smooth'=FALSE)
-  )
-  
-  if (identical(animate, T))
+  sliderFragment <- list(tags$input(
+    id=inputId, type="slider", 
+    name=inputId, value=paste(value, collapse=';'), class="jslider",
+    'data-from'=min, 'data-to'=max, 'data-step'=step,
+    'data-skin'='plastic', 'data-round'=round, 'data-locale'=locale,
+    'data-format'=format, 'data-scale'=ticks,
+    'data-smooth'=FALSE))
+
+  if (identical(animate, TRUE))
     animate <- animationOptions()
   
-  if (!is.null(animate) && !identical(animate, F)) {
+  if (!is.null(animate) && !identical(animate, FALSE)) {
     if (is.null(animate$playButton))
       animate$playButton <- 'Play'
     if (is.null(animate$pauseButton))

R/tags.R

@@ -16,7 +16,7 @@ htmlEscape <- local({
   )
   .htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse='|')
   
-  function(text, attribute=T) {
+  function(text, attribute=TRUE) {
     pattern <- if(attribute)
       .htmlSpecialsPatternAttrib 
     else
@@ -32,7 +32,7 @@ htmlEscape <- local({
       .htmlSpecials
     
     for (chr in names(specials)) {
-      text <- gsub(chr, specials[[chr]], text, fixed=T)
+      text <- gsub(chr, specials[[chr]], text, fixed=TRUE)
     }
     
     return(text)

R/tar.R

@@ -0,0 +1,191 @@
+# This file was pulled from the R code base as of
+# Thursday, November 22, 2012 at 6:24:55 AM UTC
+# and edited to remove everything but the copyright
+# header and untar2, and to make untar2 more tolerant
+# of the 'x' and 'g' extended block indicators, the
+# latter of which is used in tar files generated by
+# GitHub.
+
+
+#  File src/library/utils/R/tar.R
+#  Part of the R package, http://www.R-project.org
+#
+#  Copyright (C) 1995-2012 The R Core Team
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+#
+#  A copy of the GNU General Public License is available at
+#  http://www.r-project.org/Licenses/
+
+untar2 <- function(tarfile, files = NULL, list = FALSE, exdir = ".")
+{
+    getOct <- function(x, offset, len)
+    {
+        x <- 0L
+        for(i in offset + seq_len(len)) {
+            z <- block[i]
+            if(!as.integer(z)) break; # terminate on nul
+            switch(rawToChar(z),
+                   " " = {},
+                   "0"=,"1"=,"2"=,"3"=,"4"=,"5"=,"6"=,"7"=
+                   {x <- 8*x + (as.integer(z)-48)},
+                   stop("invalid octal digit")
+                   )
+        }
+        x
+    }
+
+    mydir.create <- function(path, ...) {
+        ## for Windows' sake
+        path <- sub("[\\/]$", "", path)
+        if(file_test("-d", path)) return()
+        if(!dir.create(path, showWarnings = TRUE, recursive = TRUE, ...))
+           stop(gettextf("failed to create directory %s", sQuote(path)),
+                domain = NA)
+    }
+
+    warn1 <- character()
+
+    ## A tar file is a set of 512 byte records,
+    ## a header record followed by file contents (zero-padded).
+    ## See http://en.wikipedia.org/wiki/Tar_%28file_format%29
+    if(is.character(tarfile) && length(tarfile) == 1L) {
+        con <- gzfile(path.expand(tarfile), "rb") # reads compressed formats
+        on.exit(close(con))
+    } else if(inherits(tarfile, "connection")) con <- tarfile
+    else stop("'tarfile' must be a character string or a connection")
+    if (!missing(exdir)) {
+        mydir.create(exdir)
+        od <- setwd(exdir)
+        on.exit(setwd(od), add = TRUE)
+    }
+    contents <- character()
+    llink <- lname <- NULL
+    repeat{
+        block <- readBin(con, "raw", n = 512L)
+        if(!length(block)) break
+        if(length(block) < 512L) stop("incomplete block on file")
+        if(all(block == 0)) break
+        ns <- max(which(block[1:100] > 0))
+        name <- rawToChar(block[seq_len(ns)])
+        magic <- rawToChar(block[258:262])
+        if ((magic == "ustar") && block[346] > 0) {
+            ns <- max(which(block[346:500] > 0))
+            prefix <- rawToChar(block[345+seq_len(ns)])
+            name <- file.path(prefix, name)
+        }
+        ## mode zero-padded 8 bytes (including nul) at 101
+        ## Aargh: bsdtar has this one incorrectly with 6 bytes+space
+        mode <- as.octmode(getOct(block, 100, 8))
+        size <- getOct(block, 124, 12)
+        ts <- getOct(block, 136, 12)
+        ft <- as.POSIXct(as.numeric(ts), origin="1970-01-01", tz="UTC")
+        csum <- getOct(block, 148, 8)
+        block[149:156] <- charToRaw(" ")
+        xx <- as.integer(block)
+        checksum <- sum(xx) %% 2^24 # 6 bytes
+        if(csum != checksum) {
+            ## try it with signed bytes.
+            checksum <- sum(ifelse(xx > 127, xx - 128, xx)) %% 2^24 # 6 bytes
+            if(csum != checksum)
+                warning(gettextf("checksum error for entry '%s'", name),
+                        domain = NA)
+        }
+        type <- block[157L]
+        ctype <- rawToChar(type)
+        if(type == 0L || ctype == "0") {
+            if(!is.null(lname)) {name <- lname; lname <- NULL}
+            contents <- c(contents, name)
+            remain <- size
+            dothis <- !list
+            if(dothis && length(files)) dothis <- name %in% files
+            if(dothis) {
+                mydir.create(dirname(name))
+                out <- file(name, "wb")
+            }
+            for(i in seq_len(ceiling(size/512L))) {
+                block <- readBin(con, "raw", n = 512L)
+                if(length(block) < 512L)
+                    stop("incomplete block on file")
+                if (dothis) {
+                    writeBin(block[seq_len(min(512L, remain))], out)
+                    remain <- remain - 512L
+                }
+            }
+            if(dothis) {
+                close(out)
+                Sys.chmod(name, mode, FALSE) # override umask
+                Sys.setFileTime(name, ft)
+            }
+        } else if(ctype %in% c("1", "2")) { # hard and symbolic links
+            contents <- c(contents, name)
+            ns <- max(which(block[158:257] > 0))
+            name2 <- rawToChar(block[157L + seq_len(ns)])
+            if(!is.null(lname)) {name <- lname; lname <- NULL}
+            if(!is.null(llink)) {name2 <- llink; llink <- NULL}
+            if(!list) {
+                if(ctype == "1") {
+                    if (!file.link(name2, name)) { # will give a warning
+                        ## link failed, so try a file copy
+                        if(file.copy(name2, name))
+                             warn1 <- c(warn1, "restoring hard link as a file copy")
+                        else
+                            warning(gettextf("failed to copy %s to %s", sQuote(name2), sQuote(name)), domain = NA)
+                    }
+                } else {
+                    if(.Platform$OS.type == "windows") {
+                        ## this will not work for links to dirs
+                        from <- file.path(dirname(name), name2)
+                        if (!file.copy(from, name))
+                            warning(gettextf("failed to copy %s to %s", sQuote(from), sQuote(name)), domain = NA)
+                        else
+                            warn1 <- c(warn1, "restoring symbolic link as a file copy")
+                   } else {
+                       if(!file.symlink(name2, name)) { # will give a warning
+                        ## so try a file copy: will not work for links to dirs
+                        from <- file.path(dirname(name), name2)
+                        if (file.copy(from, name))
+                            warn1 <- c(warn1, "restoring symbolic link as a file copy")
+                           else
+                               warning(gettextf("failed to copy %s to %s", sQuote(from), sQuote(name)), domain = NA)
+                       }
+                   }
+                }
+            }
+        } else if(ctype == "5") {
+            contents <- c(contents, name)
+            if(!list) {
+                mydir.create(name)
+                Sys.chmod(name, mode, TRUE) # FIXME: check result
+                ## no point is setting time, as dir will be populated later.
+            }
+        } else if(ctype %in% c("L", "K")) {
+            ## This is a GNU extension that should no longer be
+            ## in use, but it is.
+            name_size <- 512L * ceiling(size/512L)
+            block <- readBin(con, "raw", n = name_size)
+            if(length(block) < name_size)
+                stop("incomplete block on file")
+            ns <- max(which(block > 0)) # size on file may or may not include final nul
+            if(ctype == "L")
+                lname <- rawToChar(block[seq_len(ns)])
+            else
+                llink <- rawToChar(block[seq_len(ns)])
+        } else if(ctype %in% c("x", "g")) {
+            readBin(con, "raw", n = 512L*ceiling(size/512L))
+        } else stop("unsupported entry type ", sQuote(ctype))
+    }
+    if(length(warn1)) {
+        warn1 <- unique(warn1)
+        for (w in warn1) warning(w, domain = NA)
+    }
+    if(list) contents else invisible(0L)
+}

R/timer.R

@@ -15,6 +15,11 @@ TimerCallbacks <- setRefClass(
     initialize = function() {
       .nextId <<- 0L
     },
+    clear = function() {
+      .nextId <<- 0L
+      .funcs$clear()
+      .times <<- data.frame()
+    },
     schedule = function(millis, func) {
       id <- .nextId
       .nextId <<- .nextId + 1L
@@ -51,7 +56,7 @@ TimerCallbacks <- setRefClass(
     executeElapsed = function() {
       elapsed <- takeElapsed()
       if (length(elapsed) == 0)
-        return(F)
+        return(FALSE)
       
       for (id in elapsed$id) {
         thisFunc <- .funcs$remove(as.character(id))
@@ -59,7 +64,7 @@ TimerCallbacks <- setRefClass(
         # TODO: Detect NULL, and...?
         thisFunc()
       }
-      return(T)
+      return(TRUE)
     }
   )
 )

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
+}

README.md

@@ -2,6 +2,8 @@
 
 Shiny is a new package from RStudio that makes it incredibly easy to build interactive web applications with R.
 
+For an introduction and examples, visit the [Shiny homepage](http://www.rstudio.com/shiny/).
+
 ## Features
 
 * Build useful web applications with only a few lines of code—no JavaScript required.

inst/examples/04_mpg/ui.R

@@ -10,10 +10,10 @@ shinyUI(pageWithSidebar(
   # and to specify whether outliers should be included
   sidebarPanel(
     selectInput("variable", "Variable:",
-                list("Cylinders" = "cyl", 
-                     "Transmission" = "am", 
-                     "Gears" = "gear")),
-    
+                c("Cylinders" = "cyl",
+                  "Transmission" = "am",
+                  "Gears" = "gear")),
+
     checkboxInput("outliers", "Show outliers", FALSE)
   ),
   

inst/examples/05_sliders/ui.R

@@ -27,7 +27,7 @@ shinyUI(pageWithSidebar(
     
     # Animation with custom interval (in ms) to control speed, plus looping
     sliderInput("animation", "Looping Animation:", 1, 2000, 1, step = 10, 
-                animate=animationOptions(interval=300, loop=T))
+                animate=animationOptions(interval=300, loop=TRUE))
   ),
   
   # Show a table summarizing the values entered

inst/examples/06_tabsets/ui.R

@@ -11,10 +11,10 @@ shinyUI(pageWithSidebar(
   # element to introduce extra vertical spacing
   sidebarPanel(
     radioButtons("dist", "Distribution type:",
-                 list("Normal" = "norm",
-                      "Uniform" = "unif",
-                      "Log-normal" = "lnorm",
-                      "Exponential" = "exp")),
+                 c("Normal" = "norm",
+                   "Uniform" = "unif",
+                   "Log-normal" = "lnorm",
+                   "Exponential" = "exp")),
     br(),
     
     sliderInput("n", 

inst/examples/09_upload/ui.R

@@ -8,14 +8,14 @@ shinyUI(pageWithSidebar(
     tags$hr(),
     checkboxInput('header', 'Header', TRUE),
     radioButtons('sep', 'Separator',
-                 list(Comma=',',
-                      Semicolon=';',
-                      Tab='\t'),
+                 c(Comma=',',
+                   Semicolon=';',
+                   Tab='\t'),
                  'Comma'),
     radioButtons('quote', 'Quote',
-                 list(None='',
-                      'Double Quote'='"',
-                      'Single Quote'="'"),
+                 c(None='',
+                   'Double Quote'='"',
+                   'Single Quote'="'"),
                  'Double Quote')
   ),
   mainPanel(

inst/examples/10_download/server.R

@@ -0,0 +1,19 @@
+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(file) {
+      write.csv(datasetInput(), file)
+    }
+  )
+})

inst/examples/10_download/ui.R

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

inst/www/shared/shiny.css

@@ -14,6 +14,10 @@ table.data td[align=right] {
 .shiny-output-error {
   color: red;
 }
+.shiny-output-error:before {
+  content: 'Error: ';
+  font-weight: bold;
+}
 
 .jslider {
   /* Fix jslider running into the control above it */

inst/www/shared/shiny.js

@@ -350,12 +350,12 @@
     }
 
     // Don't mutate list argument
-    list = slice(list, 0);
+    list = list.slice(0);
 
     for (var chunkSize = 1; chunkSize < list.length; chunkSize *= 2) {
       for (var i = 0; i < list.length; i += chunkSize * 2) {
-        var listA = slice(list, i, i + chunkSize);
-        var listB = slice(list, i + chunkSize, i + chunkSize * 2);
+        var listA = list.slice(i, i + chunkSize);
+        var listB = list.slice(i + chunkSize, i + chunkSize * 2);
         var merged = merge(sortfunc, listA, listB);
         var args = [i, merged.length];
         Array.prototype.push.apply(args, merged);
@@ -394,6 +394,11 @@
       if (this.$socket)
         throw "Connect was already called on this application object";
 
+      $.extend(initialInput, {
+        // IE8 and IE9 have some limitations with data URIs
+        "__allowDataUriScheme": typeof WebSocket !== 'undefined'
+      });
+
       this.$socket = this.createSocket();
       this.$initialInput = initialInput;
       $.extend(this.$inputValues, initialInput);
@@ -563,6 +568,7 @@
         exports.oncustommessage(msgObj.custom);
       }
       if (msgObj.values) {
+        $(document.documentElement).removeClass('shiny-busy');
         for (name in this.$bindings)
           this.$bindings[name].showProgress(false);
       }
@@ -578,6 +584,7 @@
         }
       }
       if (msgObj.progress) {
+        $(document.documentElement).addClass('shiny-busy');
         for (var i = 0; i < msgObj.progress.length; i++) {
           var key = msgObj.progress[i];
           var binding = this.$bindings[key];
@@ -847,7 +854,7 @@
       this.renderError(el, err);
     };
     this.renderError = function(el, err) {
-      $(el).addClass('shiny-output-error').text('ERROR: ' + err.message);
+      $(el).addClass('shiny-output-error').text(err.message);
     };
     this.clearError = function(el) {
       $(el).removeClass('shiny-output-error');
@@ -879,12 +886,16 @@
       return $(scope).find('.shiny-plot-output');
     },
     renderValue: function(el, data) {
+      // Load the image before emptying, to minimize flicker
+      var img = null;
+      if (data) {
+        img = document.createElement('img');
+        img.src = data;
+      }
+
       $(el).empty();
-      if (!data)
-        return;
-      var img = document.createElement('img');
-      img.src = data;
-      $(el).append(img);
+      if (img)
+        $(el).append(img);
     }
   });
   outputBindings.register(plotOutputBinding, 'shiny.plotOutput');
@@ -901,6 +912,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/checkboxGroupInput.Rd

@@ -29,9 +29,9 @@
 }
 \examples{
 checkboxGroupInput("variable", "Variable:",
-                   list("Cylinders" = "cyl",
-                        "Transmission" = "am",
-                        "Gears" = "gear"))
+                   c("Cylinders" = "cyl",
+                     "Transmission" = "am",
+                     "Gears" = "gear"))
 }
 \seealso{
   \code{\link{checkboxInput}}

man/conditionalPanel.Rd

@@ -30,18 +30,18 @@
 sidebarPanel(
    selectInput(
       "plotType", "Plot Type",
-      list(Scatter = "scatter",
-           Histogram = "hist")),
+      c(Scatter = "scatter",
+        Histogram = "hist")),
 
    # Only show this panel if the plot type is a histogram
    conditionalPanel(
       condition = "input.plotType == 'hist'",
       selectInput(
          "breaks", "Breaks",
-         list("Sturges",
-              "Scott",
-              "Freedman-Diaconis",
-              "[Custom]" = "custom")),
+         c("Sturges",
+           "Scott",
+           "Freedman-Diaconis",
+           "[Custom]" = "custom")),
 
       # Only show this panel if Custom is selected
       conditionalPanel(

man/downloadButton.Rd

@@ -0,0 +1,46 @@
+\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)
+}
+\arguments{
+  \item{outputId}{The name of the output slot that the
+  \code{downloadHandler} is assigned to.}
+
+  \item{label}{The label that should appear on the button.}
+
+  \item{class}{Additional CSS classes to apply to the tag,
+  if any.}
+}
+\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{file} that is a file path (string) of a nonexistent
+  temp file, and writes the content to that file path.
+  (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(file) {
+    write.csv(data, file)
+  }
+)
+
+# In ui.R:
+downloadLink('downloadData', 'Download')
+}
+}
+

man/headerPanel.Rd

@@ -2,10 +2,14 @@
 \alias{headerPanel}
 \title{Create a header panel}
 \usage{
-  headerPanel(title)
+  headerPanel(title, windowTitle = title)
 }
 \arguments{
   \item{title}{An application title to display}
+
+  \item{windowTitle}{The title that should be displayed by
+  the browser window.  Useful if \code{title} is not a
+  string.}
 }
 \value{
   A headerPanel that can be passed to

man/helpText.Rd

@@ -2,12 +2,11 @@
 \alias{helpText}
 \title{Create a help text element}
 \usage{
-  helpText(text, ...)
+  helpText(...)
 }
 \arguments{
-  \item{text}{Help text string}
-
-  \item{...}{Additional help text strings}
+  \item{...}{One or more help text strings (or other inline
+  HTML elements)}
 }
 \value{
   A help text element that can be added to a UI definition.

man/include.Rd

@@ -0,0 +1,54 @@
+\name{includeHTML}
+\alias{includeHTML}
+\alias{includeText}
+\alias{includeMarkdown}
+
+\usage{
+  includeHTML(path)
+  includeText(path)
+  includeMarkdown(path)
+}
+
+\title{Include Content From a File}
+
+\arguments{
+  \item{path}{
+    The path of the file to be included. It is highly recommended to
+    use a relative path (the base path being the Shiny application
+    directory), not an absolute path.
+  }
+}
+\description{
+  Include HTML, text, or rendered Markdown into a \link[=shinyUI]{Shiny UI}.
+}
+\details{
+  These functions provide a convenient way to include an extensive amount
+  of HTML, textual, or Markdown content, rather than using a large literal R
+  string.
+}
+\note{
+  \code{includeText} escapes its contents, but does no other processing. This
+  means that hard breaks and multiple spaces will be rendered as they usually
+  are in HTML: as a single space character. If you are looking for
+  preformatted text, wrap the call with \code{\link{pre}}, or consider using
+  \code{includeMarkdown} instead.
+}
+\note{
+  The \code{includeMarkdown} function requires the \code{markdown} package.
+}
+\examples{
+doc <- tags$html(
+  tags$head(
+    tags$title('My first page')
+  ),
+  tags$body(
+    h1('My first heading'),
+    p('My first paragraph, with some ',
+      strong('bold'),
+      ' text.'),
+    div(id='myDiv', class='simpleDiv',
+        'Here is a div with some attributes.')
+  )
+)
+cat(as.character(doc))
+}

man/observe.Rd

@@ -0,0 +1,33 @@
+\name{observe}
+\alias{observe}
+\title{Create a reactive observer}
+\usage{
+  observe(func)
+}
+\arguments{
+  \item{func}{The function to observe. It must not have any
+  parameters. Any return value from this function will be
+  ignored.}
+}
+\description{
+  Creates an observer from the given function. An observer
+  is like a reactive function in that it can read reactive
+  values and call reactive functions, and will
+  automatically re-execute when those dependencies change.
+  But unlike reactive functions, it doesn't yield a result
+  and can't be used as an input to other reactive
+  functions. Thus, observers are only useful for their side
+  effects (for example, performing I/O).
+}
+\details{
+  Another contrast between reactive functions and observers
+  is their execution strategy. Reactive functions use lazy
+  evaluation; that is, when their dependencies change, they
+  don't re-execute right away but rather wait until they
+  are called by someone else. Indeed, if they are not
+  called then they will never re-execute. In contrast,
+  observers use eager evaluation; as soon as their
+  dependencies change, they schedule themselves to
+  re-execute.
+}
+

man/radioButtons.Rd

@@ -27,9 +27,9 @@
 }
 \examples{
 radioButtons("dist", "Distribution type:",
-             list("Normal" = "norm",
-                  "Uniform" = "unif",
-                  "Log-normal" = "lnorm",
-                  "Exponential" = "exp"))
+             c("Normal" = "norm",
+               "Uniform" = "unif",
+               "Log-normal" = "lnorm",
+               "Exponential" = "exp"))
 }
 

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
@@ -27,5 +33,13 @@
   The corresponding HTML output tag should be \code{div} or
   \code{img} and have the CSS class name
   \code{shiny-plot-output}.
+
+  For output, it will try to use the following devices, in
+  this order: quartz (via \code{\link[grDevices]{png}}),
+  then \code{\link[Cairo]{CairoPNG}}, and finally
+  \code{\link[grDevices]{png}}. This is in order of quality
+  of output. Notably, plain \code{png} output on Linux and
+  Windows may not antialias some point shapes, resulting in
+  poor quality output.
 }
 

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

man/selectInput.Rd

@@ -33,8 +33,8 @@
 }
 \examples{
 selectInput("variable", "Variable:",
-            list("Cylinders" = "cyl",
-                 "Transmission" = "am",
-                 "Gears" = "gear"))
+            c("Cylinders" = "cyl",
+              "Transmission" = "am",
+              "Gears" = "gear"))
 }