Update version metadata

Very simple tweak to R's untar2 code was all that was
required to fix the built-in untar's problems with
gists. Seemed best to just fork it and start using
the forked version directly, regardless of what is
installed on your machine.

DESCRIPTION

@@ -1,25 +1,42 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.1.2
-Date: 2012-08-02
+Version: 0.1.13
+Date: 2012-11-23
 Author: RStudio, Inc.
 Maintainer: Joe Cheng <joe@rstudio.org>
-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 
+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), methods, websockets (>= 1.1.4), caTools, RJSONIO, xtable
-Imports: stats, tools, utils, datasets
+Depends:
+    R (>= 2.14.1)
+Imports:
+    stats,
+    tools,
+    utils,
+    datasets,
+    methods,
+    websockets (>= 1.1.6),
+    caTools,
+    RJSONIO,
+    xtable,
+    digest
+Suggests:
+    markdown
 URL: https://github.com/rstudio/shiny, http://rstudio.github.com/shiny/tutorial
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
     'map.R'
+    'utils.R'
+    'tar.R'
     'timer.R'
     'tags.R'
+    'cache.R'
     'react.R'
     'reactives.R'
+    'fileupload.R'
     'shiny.R'
     'shinywrappers.R'
     'shinyui.R'

NAMESPACE

@@ -1,10 +1,18 @@
 export(a)
+export(addResourcePath)
 export(animationOptions)
+export(bootstrapPage)
 export(br)
+export(checkboxGroupInput)
 export(checkboxInput)
 export(code)
+export(conditionalPanel)
 export(div)
+export(downloadButton)
+export(downloadHandler)
+export(downloadLink)
 export(em)
+export(fileInput)
 export(h1)
 export(h2)
 export(h3)
@@ -16,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)
@@ -30,12 +42,16 @@ export(reactivePrint)
 export(reactiveTable)
 export(reactiveText)
 export(reactiveTimer)
+export(reactiveUI)
+export(repeatable)
 export(runApp)
 export(runExample)
+export(runGist)
 export(selectInput)
 export(shinyServer)
 export(shinyUI)
 export(sidebarPanel)
+export(singleton)
 export(sliderInput)
 export(span)
 export(strong)
@@ -45,13 +61,26 @@ export(tabPanel)
 export(tabsetPanel)
 export(tag)
 export(tagAppendChild)
+export(tagList)
 export(tags)
 export(textInput)
 export(textOutput)
+export(uiOutput)
 export(verbatimTextOutput)
+export(wellPanel)
+import(caTools)
+import(digest)
+import(RJSONIO)
+import(websockets)
+import(xtable)
 S3method(as.character,shiny.tag)
+S3method(as.character,shiny.tag.list)
+S3method(as.list,reactvaluesreader)
 S3method(format,shiny.tag)
+S3method(format,shiny.tag.list)
+S3method(names,reactvaluesreader)
 S3method(print,shiny.tag)
+S3method(print,shiny.tag.list)
 S3method(reactive,default)
 S3method(reactive,"function")
 S3method("$",reactvaluesreader)

NEWS

@@ -0,0 +1,120 @@
+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
+--------------------------------------------------------------------------------
+
+* Add `runGist` function for conveniently running a Shiny app that is published
+  on gist.github.com.
+* Fix issue #27: Warnings cause reactive functions to stop executing.
+* The server.R and ui.R filenames are now case insensitive.
+* Add `wellPanel` function for creating inset areas on the page.
+* Add `bootstrapPage` function for creating new Twitter Bootstrap based
+  layouts from scratch.
+
+
+shiny 0.1.7
+--------------------------------------------------------------------------------
+
+* Fix issue #26: Shiny.OutputBindings not correctly exported.
+* Add `repeatable` function for making easily repeatable versions of random
+  number generating functions.
+* Transcode JSON into UTF-8 (prevents non-ASCII reactivePrint values from
+  causing errors on Windows).
+
+
+shiny 0.1.6
+--------------------------------------------------------------------------------
+
+* Import package dependencies, instead of attaching them (with the exception of
+  websockets, which doesn't currently work unless attached).
+* conditionalPanel was animated, now it is not.
+* bindAll was not correctly sending initial values to the server; fixed.
+
+
+shiny 0.1.5
+--------------------------------------------------------------------------------
+
+* BREAKING CHANGE: JS APIs Shiny.bindInput and Shiny.bindOutput removed and
+  replaced with Shiny.bindAll; Shiny.unbindInput and Shiny.unbindOutput removed
+  and replaced with Shiny.unbindAll.
+* Add file upload support (currently only works with Chrome and Firefox). Use
+  a normal HTML file input, or call the `fileInput` UI function.
+* Shiny.unbindOutputs did not work, now it does.
+* Generally improved robustness of dynamic input/output bindings.
+* Add conditionalPanel UI function to allow showing/hiding UI based on a JS
+  expression; for example, whether an input is a particular value. Also works in
+  raw HTML (add the `data-display-if` attribute to the element that should be
+  shown/hidden).
+* htmlOutput (CSS class `shiny-html-output`) can contain inputs and outputs.
+
+
+shiny 0.1.4
+--------------------------------------------------------------------------------
+
+* Allow Bootstrap tabsets to act as reactive inputs; their value indicates which
+  tab is active
+* Upgrade to Bootstrap 2.1
+* Add `checkboxGroupInput` control, which presents a list of checkboxes and
+  returns a vector of the selected values
+* Add `addResourcePath`, intended for reusable component authors to access CSS,
+  JavaScript, image files, etc. from their package directories
+* Add Shiny.bindInputs(scope), .unbindInputs(scope), .bindOutputs(scope), and
+  .unbindOutputs(scope) JS API calls to allow dynamic binding/unbinding of HTML
+  elements
+
+
+shiny 0.1.3
+--------------------------------------------------------------------------------
+
+* Introduce Shiny.inputBindings.register JS API and InputBinding class, for
+  creating custom input controls
+* Add `step` parameter to numericInput
+* Read names of input using `names(input)`
+* Access snapshot of input as a list using `as.list(input)` 
+* Fix issue #10: Plots in tabsets not rendered
+
+
+shiny 0.1.2
+--------------------------------------------------------------------------------
+
+Initial private beta release!

R/bootstrap.R

@@ -1,3 +1,63 @@
+#' Create a Twitter Bootstrap page
+#' 
+#' Create a Shiny UI page that loads the CSS and JavaScript for
+#' \href{http://getbootstrap.com}{Twitter Bootstrap}, and has no content in the
+#' page body (other than what you provide).
+#' 
+#' This function is primarily intended for users who are proficient in HTML/CSS,
+#' and know how to lay out pages in Bootstrap. Most users should use template
+#' functions like \code{\link{pageWithSidebar}}.
+#' 
+#' @param ... The contents of the document body.
+#' @return A UI defintion that can be passed to the \link{shinyUI} function.
+#' 
+#' @export
+bootstrapPage <- function(...) {
+  # required head tags for boostrap
+  importBootstrap <- function(min = TRUE, responsive = TRUE) {
+    
+    ext <- function(ext) {
+      ifelse(min, paste(".min", ext, sep=""), ext)
+    }
+    cssExt <- ext(".css")
+    jsExt = ext(".js")
+    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="")),
+      
+      tags$script(src=paste(bs, "js/bootstrap", jsExt, sep=""))
+    )
+    
+    if (responsive) {
+      result <- tagAppendChild(
+        result, 
+        tags$meta(name="viewport", 
+                  content="width=device-width, initial-scale=1.0"))
+      result <- tagAppendChild(
+        result,
+        tags$link(rel="stylesheet", 
+                  type="text/css", 
+                  href=paste(bs, "css/bootstrap-responsive", cssExt, sep="")))
+    }
+    
+    result
+  }
+  
+  tagList(
+    # inject bootstrap requirements into head
+    importBootstrap(),
+    list(...)
+  )
+}
 
 #' Create a page with a sidebar
 #' 
@@ -34,43 +94,16 @@
 #' @export
 pageWithSidebar <- function(headerPanel, sidebarPanel, mainPanel) {
   
-  # required head tags for boostrap
-  importBootstrap <- function(min = TRUE) {
-    
-    ext <- function(ext) {
-      ifelse(min, paste(".min", ext, sep=""), ext)
-    }
-    cssExt <- ext(".css")
-    jsExt = ext(".js")
-    bs <- "shared/bootstrap/"
-    
-    tags$head(
-      tags$meta(name="viewport", 
-                content="width=device-width, initial-scale=1.0"),
-      tags$link(rel="stylesheet", 
-                type="text/css", 
-                href=paste(bs, "css/bootstrap", cssExt, sep="")),
-      
-      tags$link(rel="stylesheet", 
-                type="text/css", 
-                href=paste(bs, "css/bootstrap-responsive", cssExt, sep="")),
-      
-      tags$script(src=paste(bs, "js/bootstrap", jsExt, sep=""))
-    )
-  }
-  
-  list(
-    # inject bootstrap requirements into head
-    importBootstrap(),
-    
+  bootstrapPage(
     # basic application container divs
-    div(class="container-fluid", 
+    div(
+      class="container-fluid", 
       div(class="row-fluid", 
-        headerPanel
+          headerPanel
       ),
       div(class="row-fluid", 
-        sidebarPanel, 
-        mainPanel
+          sidebarPanel, 
+          mainPanel
       )
     )
   )
@@ -82,20 +115,35 @@ 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) {    
-  list(
-    tags$head(tags$title(title)),
+headerPanel <- function(title, windowTitle=title) {    
+  tagList(
+    tags$head(tags$title(windowTitle)),
     div(class="span12", style="padding: 10px 0px;",
       h1(title)
     )
   )
 }
 
+#' Create a well panel
+#' 
+#' Creates a panel with a slightly inset border and grey background. Equivalent
+#' to Twitter Bootstrap's \code{well} CSS class.
+#' 
+#' @param ... UI elements to include inside the panel.
+#' @return The newly created panel.
+#' 
+#' @export
+wellPanel <- function(...) {
+  div(class="well", ...)
+}
+
 #' Create a sidebar panel
 #' 
 #' Create a sidebar panel containing input controls that can in turn be 
@@ -143,6 +191,52 @@ mainPanel <- function(...) {
   )
 }
 
+#' Conditional Panel
+#' 
+#' Creates a panel that is visible or not, depending on the value of a 
+#' JavaScript expression. The JS expression is evaluated once at startup and 
+#' whenever Shiny detects a relevant change in input/output.
+#' 
+#' In the JS expression, you can refer to \code{input} and \code{output} 
+#' JavaScript objects that contain the current values of input and output. For
+#' example, if you have an input with an id of \code{foo}, then you can use
+#' \code{input.foo} to read its value. (Be sure not to modify the input/output
+#' objects, as this may cause unpredictable behavior.)
+#' 
+#' @param condition A JavaScript expression that will be evaluated repeatedly to
+#'   determine whether the panel should be displayed.
+#' @param ... Elements to include in the panel.
+#' 
+#' @examples
+#' sidebarPanel(
+#'    selectInput(
+#'       "plotType", "Plot Type",
+#'       c(Scatter = "scatter",
+#'         Histogram = "hist")),
+#' 
+#'    # Only show this panel if the plot type is a histogram
+#'    conditionalPanel(
+#'       condition = "input.plotType == 'hist'",
+#'       selectInput(
+#'          "breaks", "Breaks",
+#'          c("Sturges",
+#'            "Scott",
+#'            "Freedman-Diaconis",
+#'            "[Custom]" = "custom")),
+#'               
+#'       # Only show this panel if Custom is selected
+#'       conditionalPanel(
+#'          condition = "input.breaks == 'custom'",
+#'          sliderInput("breakCount", "Break Count", min=1, max=1000, value=10)
+#'       )
+#'    )
+#' )
+#'   
+#' @export
+conditionalPanel <- function(condition, ...) {
+  div('data-display-if'=condition, ...)
+}
+
 #' Create a text input control
 #' 
 #' Create an input control for entry of unstructured text values
@@ -156,7 +250,7 @@ mainPanel <- function(...) {
 #' textInput("caption", "Caption:", "Data Summary")
 #' @export
 textInput <- function(inputId, label, value = "") {
-  list(
+  tagList(
     tags$label(label),
     tags$input(id = inputId, type="text", value=value)
   )
@@ -171,13 +265,14 @@ textInput <- function(inputId, label, value = "") {
 #' @param value Initial value
 #' @param min Minimum allowed value
 #' @param max Maximum allowed value
+#' @param step Interval to use when stepping between min and max
 #' @return A numeric input control that can be added to a UI definition.
 #' 
 #' @examples
 #' numericInput("obs", "Observations:", 10, 
 #'              min = 1, max = 100)
 #' @export
-numericInput <- function(inputId, label, value, min = NA, max = NA) {
+numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA) {
   
   # build input tag
   inputTag <- tags$input(id = inputId, type = "number", value = value)
@@ -185,52 +280,128 @@ numericInput <- function(inputId, label, value, min = NA, max = NA) {
     inputTag$attribs$min = min
   if (!is.na(max))
     inputTag$attribs$max = max
+  if (!is.na(step))
+    inputTag$attribs$step = step
   
-  list(
+  tagList(
     tags$label(label),
     inputTag
   )
 }
 
 
-#' Create a checkbox input control
+#' File Upload Control
 #' 
-#' Create a checkbox that can be used to specify logical values
+#' Create a file upload control that can be used to upload one or more files. 
+#' \bold{Experimental feature. Only works in some browsers (primarily tested on
+#' Chrome and Firefox).}
 #' 
-#' @param inputId Input variable to assign the control's value to
-#' @param label Display label for the control
-#' @param value Initial value
+#' @param inputId Input variable to assign the control's value to.
+#' @param label Display label for the control.
+#' @param multiple Whether the user should be allowed to select and upload 
+#'   multiple files at once.
+#' @param accept A character vector of MIME types; gives the browser a hint of 
+#'   what kind of files the server is expecting.
+#'   
+#' @export
+fileInput <- function(inputId, label, multiple = FALSE, accept = NULL) {
+  inputTag <- tags$input(id = inputId, type = "file")
+  if (multiple)
+    inputTag$attribs$multiple <- "multiple"
+  if (length(accept) > 0)
+    inputTag$attribs$accept <- paste(accept, collapse=',')
+  
+  tagList(
+    tags$label(label),
+    inputTag
+  )
+}
+
+
+#' Checkbox Input Control
+#' 
+#' Create a checkbox that can be used to specify logical values.
+#' 
+#' @param inputId Input variable to assign the control's value to.
+#' @param label Display label for the control.
+#' @param value Initial value (\code{TRUE} or \code{FALSE}).
 #' @return A checkbox control that can be added to a UI definition.
 #' 
+#' @seealso \code{\link{checkboxGroupInput}}
+#' 
 #' @examples
 #' checkboxInput("outliers", "Show outliers", FALSE)
 #' @export
 checkboxInput <- function(inputId, label, value = FALSE) {
   inputTag <- tags$input(id = inputId, type="checkbox")
-  if (value)
+  if (!is.null(value) && value)
     inputTag$attribs$checked <- "checked"
   tags$label(class = "checkbox", inputTag, label)
 }
 
 
+#' Checkbox Group Input Control
+#' 
+#' Create a group of checkboxes that can be used to toggle multiple choices 
+#' independently. The server will receive the input as a character vector of the
+#' selected values.
+#' 
+#' @param inputId Input variable to assign the control's value to.
+#' @param label Display label for the control.
+#' @param choices List of values to show checkboxes for. If elements of the list
+#'   are named then that name rather than the value is displayed to the user.
+#' @param selected Names of items that should be initially selected, if any.
+#' @return A list of HTML elements that can be added to a UI definition.
+#'   
+#' @seealso \code{\link{checkboxInput}}
+#'   
+#' @examples
+#' checkboxGroupInput("variable", "Variable:",
+#'                    c("Cylinders" = "cyl",
+#'                      "Transmission" = "am",
+#'                      "Gears" = "gear"))
+#'                  
+#' @export
+checkboxGroupInput <- function(inputId, label, choices, selected = NULL) {
+  # resolve names
+  choices <- choicesWithNames(choices)
+  
+  checkboxes <- list()
+  for (choiceName in names(choices)) {
+    
+    checkbox <- tags$input(name = inputId, type="checkbox",
+                           value = choices[[choiceName]])
+    
+    if (choiceName %in% selected)
+      checkbox$attribs$checked <- 'checked'
+    
+    checkboxes[[length(checkboxes)+1]] <- checkbox
+    checkboxes[[length(checkboxes)+1]] <- choiceName
+    checkboxes[[length(checkboxes)+1]] <- tags$br()
+  } 
+  
+  # return label and select tag
+  tags$div(class='control-group',
+           controlLabel(inputId, label),
+           checkboxes)
+}
+
+
 #' 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) {
@@ -269,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, 
@@ -297,7 +468,7 @@ selectInput <- function(inputId,
   } 
   
   # return label and select tag
-  list(controlLabel(inputId, label), selectTag)
+  tagList(controlLabel(inputId, label), selectTag)
 }
 
 #' Create radio buttons
@@ -314,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
@@ -346,8 +517,8 @@ radioButtons <- function(inputId, label, choices, selected = NULL) {
     inputTags[[length(inputTags) + 1]] <- labelTag
   }
   
-  list(tags$label(class = "control-label", label),
-       inputTags)
+  tagList(tags$label(class = "control-label", label),
+          inputTags)
 }
 
 #' Create a submit button
@@ -418,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))
@@ -429,7 +600,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   }
   
   # build slider
-  list(
+  tagList(
     controlLabel(inputId, labelText),  
     slider(inputId, min=min, max=max, value=value, step=step, round=round,
            locale=locale, format=format, ticks=ticks,
@@ -440,12 +611,15 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
 
 #' Create a tab panel
 #' 
-#' Create a tab panel that can be inluded within a \link{tabsetPanel}. 
+#' Create a tab panel that can be included within a \code{\link{tabsetPanel}}.
 #' 
 #' @param title Display title for tab
 #' @param ... UI elements to include within the tab
-#' @return A tab that can be passed to \link{tabsetPanel}
-#' 
+#' @param value The value that should be sent when \code{tabsetPanel} reports 
+#'   that this tab is selected. If omitted and \code{tabsetPanel} has an 
+#'   \code{id}, then the title will be used.
+#' @return A tab that can be passed to \code{\link{tabsetPanel}}
+#'   
 #' @examples
 #' # Show a tabset that includes a plot, summary, and
 #' # table view of the generated distribution
@@ -457,19 +631,22 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
 #'   )
 #' )
 #' @export
-tabPanel <- function(title, ...) {
-  div(class="tab-pane", title=title, ...)
+tabPanel <- function(title, ..., value = NULL) {
+  div(class="tab-pane", title=title, `data-value`=value, ...)
 }
 
 #' Create a tabset panel
 #' 
-#' Create a tabset that contains \link{tabPanel} elements. Tabsets
-#' are useful for dividing output into multiple independently viewable
-#' sections.
-#' 
-#' @param ... \link{tabPanel} elements to include in the tabset
-#' @return A tabset that can be passed to \link{mainPanel}
+#' Create a tabset that contains \code{\link{tabPanel}} elements. Tabsets are
+#' useful for dividing output into multiple independently viewable sections.
 #' 
+#' @param ... \code{\link{tabPanel}} elements to include in the tabset
+#' @param id If provided, you can use \code{input$}\emph{\code{id}} in your server 
+#'   logic to determine which of the current tabs is active. The value will 
+#'   correspond to the \code{value} argument that is passed to 
+#'   \code{\link{tabPanel}}.
+#' @return A tabset that can be passed to \code{\link{mainPanel}}
+#'   
 #' @examples
 #' # Show a tabset that includes a plot, summary, and
 #' # table view of the generated distribution
@@ -481,24 +658,31 @@ tabPanel <- function(title, ...) {
 #'   )
 #' )
 #' @export
-tabsetPanel <- function(...) {
+tabsetPanel <- function(..., id = NULL) {
   
   # build tab-nav and tab-content divs
   tabs <- list(...)
-  tabNavList <- tags$ul(class = "nav nav-tabs")
+  tabNavList <- tags$ul(class = "nav nav-tabs", id = id)
   tabContent <- tags$div(class = "tab-content")
   firstTab <- TRUE
   tabsetId <- as.integer(stats::runif(1, 1, 10000))
   tabId <- 1
   for (divTag in tabs) {
     # compute id and assign it to the div
-    id <- paste("tab", tabsetId, tabId, sep="-")
-    divTag$attribs$id <- id
+    thisId <- paste("tab", tabsetId, tabId, sep="-")
+    divTag$attribs$id <- thisId
     tabId <- tabId + 1
     
+    tabValue <- divTag$attribs$`data-value`
+    if (!is.null(tabValue) && is.null(id)) {
+      stop("tabsetPanel doesn't have an id assigned, but one of its tabPanels ",
+           "has a value. The value won't be sent without an id.")
+    }
+
     # create the li tag
-    liTag <- tags$li(tags$a(href=paste("#", id, sep=""),
+    liTag <- tags$li(tags$a(href=paste("#", thisId, sep=""),
                             `data-toggle` = "tab", 
+                            `data-value` = tabValue,
                             divTag$attribs$title))
     
     # set the first tab as active
@@ -591,6 +775,10 @@ tableOutput <- function(outputId) {
 #' Render a reactive output variable as HTML within an application page. The 
 #' text will be included within an HTML \code{div} tag, and is presumed to 
 #' contain HTML content which should not be escaped.
+#' 
+#' \code{uiOutput} is intended to be used with \code{reactiveUI} on the
+#' server side. It is currently just an alias for \code{htmlOutput}.
+#'   
 #' @param outputId output variable to read the value from
 #' @return An HTML output element that can be included in a panel
 #' @examples
@@ -599,3 +787,58 @@ tableOutput <- function(outputId) {
 htmlOutput <- function(outputId) {
   div(id = outputId, class="shiny-html-output")
 }
+
+#' @rdname htmlOutput
+#' @export
+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

@@ -0,0 +1,95 @@
+# For HTML5-capable browsers, file uploads happen through a series of requests.
+# 
+# 1. Client tells server that one or more files are about to be uploaded; the
+#    server responds with a "job ID" that the client should use for the rest of
+#    the upload.
+#    
+# 2. For each file (sequentially):
+#    a. Client tells server the name, size, and type of the file.
+#    b. Client sends server a small-ish blob of data.
+#    c. Repeat 2b until the entire file has been uploaded.
+#    d. Client tells server that the current file is done.
+#    
+# 3. Repeat 2 until all files have been uploaded.
+# 
+# 4. Client tells server that all files have been uploaded, along with the
+#    input ID that this data should be associated with.
+# 
+# Unfortunately this approach will not work for browsers that don't support
+# HTML5 File API, but the fallback approach we would like to use (multipart
+# form upload, i.e. traditional HTTP POST-based file upload) doesn't work with
+# the websockets package's HTTP server at the moment.
+
+FileUploadOperation <- setRefClass(
+  'FileUploadOperation',
+  fields = list(
+    .parent = 'ANY',
+    .id = 'character',
+    .files = 'data.frame',
+    .dir = 'character',
+    .currentFileInfo = 'list',
+    .currentFileData = 'ANY'
+  ),
+  methods = list(
+    initialize = function(parent, id, dir) {
+      .parent <<- parent
+      .id <<- id
+      .dir <<- dir
+    },
+    fileBegin = function(file) {
+      .currentFileInfo <<- file
+
+      filename <- file.path(.dir, as.character(length(.files)))
+      row <- data.frame(name=file$name, size=file$size, type=file$type,
+                        datapath=filename, stringsAsFactors=FALSE)
+      
+      if (length(.files) == 0)
+        .files <<- row
+      else
+        .files <<- rbind(.files, row)
+      
+      .currentFileData <<- file(filename, open='wb')
+    },
+    fileChunk = function(rawdata) {
+      writeBin(rawdata, .currentFileData)
+    },
+    fileEnd = function() {
+      close(.currentFileData)
+    },
+    finish = function() {
+      .parent$onJobFinished(.id)
+      return(.files)
+    }
+  )
+)
+
+FileUploadContext <- setRefClass(
+  'FileUploadContext',
+  fields = list(
+    .basedir = 'character',
+    .operations = 'Map'
+  ),
+  methods = list(
+    initialize = function(dir=tempdir()) {
+      .basedir <<- dir
+    },
+    createUploadOperation = function() {
+      while (TRUE) {
+        id <- paste(as.raw(runif(12, min=0, max=0xFF)), collapse='')
+        dir <- file.path(.basedir, id)
+        if (!dir.create(dir))
+          next
+        
+        op <- FileUploadOperation$new(.self, id, dir)
+        .operations$set(id, op)
+        return(id)
+      }
+    },
+    getUploadOperation = function(jobId) {
+      .operations$get(jobId)
+    },
+    onJobFinished = function(jobId) {
+      .operations$remove(jobId)
+    }
+  )
+)

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/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
     },
@@ -52,14 +52,12 @@ Context <- setRefClass(
     executeCallbacks = function() {
       "For internal use only."
       lapply(.callbacks, function(func) {
-        tryCatch({
+        withCallingHandlers({
           func()
         }, warning = function(e) {
           # TODO: Callbacks in app
-          print(e)
         }, error = function(e) {
           # TODO: Callbacks in app
-          print(e)
         })
       })
     }
@@ -109,10 +107,10 @@ ReactiveEnvironment <- setRefClass(
 )
 
 .getReactiveEnvironment <- function() {
-  if (!exists('.ReactiveEnvironment', envir=.GlobalEnv, inherits=F)) {
+  if (!exists('.ReactiveEnvironment', envir=.GlobalEnv, inherits=FALSE)) {
     assign('.ReactiveEnvironment', ReactiveEnvironment$new(), envir=.GlobalEnv)
   }
-  get('.ReactiveEnvironment', envir=.GlobalEnv, inherits=F)
+  get('.ReactiveEnvironment', envir=.GlobalEnv, inherits=FALSE)
 }
 
 # Causes any pending invalidations to run.

R/reactives.R

@@ -1,8 +1,48 @@
+Dependencies <- setRefClass(
+  'Dependencies',
+  fields = list(
+    .dependencies = 'Map'
+  ),
+  methods = list(
+    register = function() {
+      ctx <- .getReactiveEnvironment()$currentContext()
+      if (!.dependencies$containsKey(ctx$id)) {
+        .dependencies$set(ctx$id, ctx)
+        ctx$onInvalidate(function() {
+          .dependencies$remove(ctx$id)
+        })
+      }
+    },
+    invalidate = function() {
+      lapply(
+        .dependencies$values(),
+        function(ctx) {
+          ctx$invalidateHint()
+          ctx$invalidate()
+          NULL
+        }
+      )
+    },
+    invalidateHint = function() {
+      lapply(
+        .dependencies$values(),
+        function(dep.ctx) {
+          dep.ctx$invalidateHint()
+          NULL
+        })
+    }
+  )
+)
+
 Values <- setRefClass(
   'Values',
   fields = list(
     .values = 'environment',
-    .dependencies = 'environment'
+    .dependencies = 'environment',
+    # Dependencies for the list of names
+    .namesDeps = 'Dependencies',
+    # Dependencies for all values
+    .allDeps = 'Dependencies'
   ),
   methods = list(
     initialize = function() {
@@ -12,30 +52,34 @@ 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())
         }
       }
+      else {
+        .namesDeps$invalidate()
+      }
+      .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),
@@ -48,10 +92,18 @@ Values <- setRefClass(
       invisible()
     },
     mset = function(lst) {
-      lapply(names(lst),
+      lapply(base::names(lst),
              function(name) {
                .self$set(name, lst[[name]])
              })
+    },
+    names = function() {
+      .namesDeps$register()
+      return(ls(.values, all.names=TRUE))
+    },
+    toList = function() {
+      .allDeps$register()
+      return(as.list(.values))
     }
   )
 )
@@ -76,11 +128,21 @@ Values <- setRefClass(
   x[['impl']]$get(name)
 }
 
+#' @S3method names reactvaluesreader
+names.reactvaluesreader <- function(x) {
+  x[['impl']]$names()
+}
+
+#' @S3method as.list reactvaluesreader
+as.list.reactvaluesreader <- function(x, ...) {
+  x[['impl']]$toList()
+}
+
 Observable <- setRefClass(
   'Observable',
   fields = list(
     .func = 'function',
-    .dependencies = 'Map',
+    .dependencies = 'Dependencies',
     .initialized = 'logical',
     .value = 'ANY'
   ),
@@ -91,22 +153,15 @@ Observable <- setRefClass(
              "or more parameters; only functions without parameters can be ",
              "reactive.")
       .func <<- func
-      .dependencies <<- Map$new()
-      .initialized <<- F
+      .initialized <<- FALSE
     },
     getValue = function() {
       if (!.initialized) {
-        .initialized <<- T
+        .initialized <<- TRUE
         .self$.updateValue()
       }
       
-      ctx <- .getReactiveEnvironment()$currentContext()
-      if (!.dependencies$containsKey(ctx$id)) {
-        .dependencies$set(ctx$id, ctx)
-        ctx$onInvalidate(function() {
-          .dependencies$remove(ctx$id)
-        })
-      }
+      .dependencies$register()
       
       if (identical(class(.value), 'try-error'))
         stop(attr(.value, 'condition'))
@@ -120,24 +175,13 @@ Observable <- setRefClass(
         .self$.updateValue()
       })
       ctx$onInvalidateHint(function() {
-        lapply(
-          .dependencies$values(),
-          function(dep.ctx) {
-            dep.ctx$invalidateHint()
-            NULL
-          })
+        .dependencies$invalidateHint()
       })
       ctx$run(function() {
-        .value <<- try(.func(), silent=F)
+        .value <<- try(.func(), silent=FALSE)
       })
       if (!identical(old.value, .value)) {
-        lapply(
-          .dependencies$values(),
-          function(dep.ctx) {
-            dep.ctx$invalidate()
-            NULL
-          }
-        )
+        .dependencies$invalidate()
       }
     }
   )
@@ -217,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

@@ -1,8 +1,17 @@
+#' @docType package
+#' @import websockets caTools RJSONIO xtable digest
+NULL
+
 suppressPackageStartupMessages({
   library(websockets)
   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(
@@ -10,7 +19,12 @@ ShinyApp <- setRefClass(
     .invalidatedOutputValues = 'Map',
     .invalidatedOutputErrors = 'Map',
     .progressKeys = 'character',
-    session = 'Values'
+    .fileUploadContext = 'FileUploadContext',
+    session = 'Values',
+    token = 'character',  # Used to identify this instance in URLs
+    plots = 'Map',
+    downloads = 'Map',
+    allowDataUriScheme = 'logical'
   ),
   methods = list(
     initialize = function(ws) {
@@ -18,13 +32,24 @@ ShinyApp <- setRefClass(
       .invalidatedOutputValues <<- Map$new()
       .invalidatedOutputErrors <<- Map$new()
       .progressKeys <<- character(0)
+      # 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
       take no parameters, or have named parameters for \\code{name} and
       \\code{shinyapp} (in the future this list may expand, so it is a good idea
       to also include \\code{...} in your function signature)."
+      
+      # jcheng 08/31/2012: User submitted an example of a dynamically calculated
+      # name not working unless name was eagerly evaluated. Yikes!
+      force(name)
+      
       if (is.function(func)) {
         if (length(formals(func)) != 0) {
           orig <- func
@@ -35,12 +60,12 @@ ShinyApp <- setRefClass(
 
         obs <- Observer$new(function() {
           
-          value <- try(func(), silent=F)
+          value <- try(func(), silent=FALSE)
           
           .invalidatedOutputErrors$remove(name)
           .invalidatedOutputValues$remove(name)
           
-          if (identical(class(value), 'try-error')) {
+          if (inherits(value, 'try-error')) {
             cond <- attr(value, 'condition')
             .invalidatedOutputErrors$set(
               name, 
@@ -76,10 +101,7 @@ ShinyApp <- setRefClass(
       json <- toJSON(list(errors=as.list(errors),
                           values=as.list(values)))
 
-      if (getOption('shiny.trace', F))
-        message("SEND ", json)
-
-      websocket_write(json, .websocket)
+      .write(json)
     },
     showProgress = function(id) {
       'Send a message to the client that recalculation of the output identified
@@ -93,10 +115,175 @@ ShinyApp <- setRefClass(
       
       json <- toJSON(list(progress=list(id)))
       
-      if (getOption('shiny.trace', F))
-        message("SEND ", json)
+      .write(json)
+    },
+    dispatch = function(msg) {
+      method <- paste('@', msg$method, sep='')
+      func <- try(do.call(`$`, list(.self, method)), silent=TRUE)
+      if (inherits(func, 'try-error')) {
+        .sendErrorResponse(msg, paste('Unknown method', msg$method))
+      }
       
+      value <- try(do.call(func, as.list(append(msg$args, msg$blobs))))
+      if (inherits(value, 'try-error')) {
+        .sendErrorResponse(msg, paste('Error:', as.character(value)))
+      }
+      else {
+        .sendResponse(msg, value)
+      }
+    },
+    .sendResponse = function(requestMsg, value) {
+      if (is.null(requestMsg$tag)) {
+        warning("Tried to send response for untagged message; method: ",
+                requestMsg$method)
+        return()
+      }
+      .write(toJSON(list(response=list(tag=requestMsg$tag, value=value))))
+    },
+    .sendErrorResponse = function(requestMsg, error) {
+      if (is.null(requestMsg$tag))
+        return()
+      .write(toJSON(list(response=list(tag=requestMsg$tag, error=error))))
+    },
+    .write = function(json) {
+      if (getOption('shiny.trace', FALSE))
+        message('SEND ', json)
+      if (getOption('shiny.transcode.json', TRUE))
+        json <- iconv(json, to='UTF-8')
       websocket_write(json, .websocket)
+    },
+    
+    # Public RPC methods
+    `@uploadInit` = function() {
+      return(list(jobId=.fileUploadContext$createUploadOperation()))
+    },
+    `@uploadFileBegin` = function(jobId, fileName, fileType, fileSize) {
+      .fileUploadContext$getUploadOperation(jobId)$fileBegin(list(
+        name=fileName, type=fileType, size=fileSize
+      ))
+      invisible()
+    },
+    `@uploadFileChunk` = function(jobId, ...) {
+      args <- list(...)
+      if (length(args) != 1)
+        stop("Bad file chunk request")
+      .fileUploadContext$getUploadOperation(jobId)$fileChunk(args[[1]])
+      invisible()
+    },
+    `@uploadFileEnd` = function(jobId) {
+      .fileUploadContext$getUploadOperation(jobId)$fileEnd()
+      invisible()
+    },
+    `@uploadEnd` = function(jobId, inputId) {
+      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))
+        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, 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)))
     }
   )
 )
@@ -117,8 +304,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 ||
@@ -128,14 +315,35 @@ resolve <- function(dir, relpath) {
   return(abs.path)
 }
 
+httpResponse <- function(status = 200,
+                         content_type = "text/html; charset=UTF-8", 
+                         content = "",
+                         headers = c()) {
+  resp <- list(status = status, content_type = content_type, content = content,
+               headers = headers)
+  class(resp) <- 'httpResponse'
+  return(resp)
+}
+
 httpServer <- function(handlers) {
   handler <- joinHandlers(handlers)
+
+  filter <- getOption('shiny.http.response.filter', NULL)
+  if (is.null(filter))
+    filter <- function(ws, header, response) response
+  
   function(ws, header) {
     response <- handler(ws, header)
-    if (!is.null(response))
-      return(response)
-    else
-      return(http_response(ws, 404, content="<h1>Not Found</h1>"))
+    if (is.null(response))
+      response <- httpResponse(404, content="<h1>Not Found</h1>")
+    
+    response <- filter(ws, header, response)
+    
+    return(http_response(ws,
+                         status=response$status,
+                         content_type=response$content_type,
+                         content=response$content,
+                         headers=response$headers))
   }
 }
 
@@ -165,6 +373,25 @@ joinHandlers <- function(handlers) {
   }
 }
 
+sessionHandler <- function(ws, header) {
+  path <- header$RESOURCE
+  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
@@ -172,15 +399,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=TRUE)
+          })
         })
       }
       metaHandler <<- joinHandlers(.globals$clients)
@@ -196,7 +429,7 @@ staticHandler <- function(root) {
     path <- header$RESOURCE
     
     if (is.null(path))
-      return(http_response(ws, 400, content="<h1>Bad Request</h1>"))
+      return(httpResponse(400, content="<h1>Bad Request</h1>"))
     
     if (path == '/')
       path <- '/index.html'
@@ -206,22 +439,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(http_response(ws, 200, content.type, response.content))
+    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.
@@ -243,6 +468,81 @@ registerClient <- function(client) {
   .globals$clients <- append(.globals$clients, client)
 }
 
+
+.globals$resources <- list()
+
+#' Resource Publishing
+#' 
+#' Adds a directory of static resources to Shiny's web server, with the given 
+#' path prefix. Primarily intended for package authors to make supporting 
+#' JavaScript/CSS files available to their components.
+#' 
+#' @param prefix The URL prefix (without slashes). Valid characters are a-z, 
+#'   A-Z, 0-9, hyphen, and underscore; and must begin with a-z or A-Z. For 
+#'   example, a value of 'foo' means that any request paths that begin with 
+#'   '/foo' will be mapped to the given directory.
+#' @param directoryPath The directory that contains the static resources to be 
+#'   served.
+#'   
+#' @details You can call \code{addResourcePath} multiple times for a given 
+#'   \code{prefix}; only the most recent value will be retained. If the 
+#'   normalized \code{directoryPath} is different than the directory that's 
+#'   currently mapped to the \code{prefix}, a warning will be issued.
+#'   
+#' @seealso \code{\link{singleton}}
+#' 
+#' @examples
+#' addResourcePath('datasets', system.file('data', package='datasets'))
+#'   
+#' @export
+addResourcePath <- function(prefix, directoryPath) {
+  prefix <- prefix[1]
+  if (!grepl('^[a-z][a-z0-9\\-_]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
+    stop("addResourcePath called with invalid prefix; please see documentation")
+  }
+  
+  if (prefix %in% c('shared')) {
+    stop("addResourcePath called with the reserved prefix '", prefix, "'; ",
+         "please use a different prefix")
+  }
+  
+  directoryPath <- normalizePath(directoryPath, mustWork=TRUE)
+  
+  existing <- .globals$resources[[prefix]]
+  
+  if (!is.null(existing)) {
+    if (existing$directoryPath != directoryPath) {
+      warning("Overriding existing prefix ", prefix, " => ",
+              existing$directoryPath)
+    }
+  }
+  
+  message('Shiny URLs starting with /', prefix, ' will mapped to ', directoryPath)
+  
+  .globals$resources[[prefix]] <- list(directoryPath=directoryPath,
+                                       func=staticHandler(directoryPath))
+}
+
+resourcePathHandler <- function(ws, header) {
+  path <- header$RESOURCE
+  
+  match <- regexpr('^/([^/]+)/', path, perl=TRUE)
+  if (match == -1)
+    return(NULL)
+  len <- attr(match, 'capture.length')
+  prefix <- substr(path, 2, 2 + len - 1)
+  
+  resInfo <- .globals$resources[[prefix]]
+  if (is.null(resInfo))
+    return(NULL)
+  
+  suffix <- substr(path, 2 + len, nchar(path))
+  
+  header$RESOURCE <- suffix
+  
+  return(resInfo$func(ws, header))
+}
+
 .globals$server <- NULL
 #' Define Server Functionality
 #' 
@@ -281,16 +581,71 @@ shinyServer <- function(func) {
   invisible()
 }
 
+decodeMessage <- function(data) {
+  readInt <- function(pos) {
+    packBits(rawToBits(data[pos:(pos+3)]), type='integer')
+  }
+  
+  if (readInt(1) != 0x01020202L)
+    return(fromJSON(rawToChar(data), asText=TRUE, simplify=FALSE))
+  
+  i <- 5
+  parts <- list()
+  while (i <= length(data)) {
+    length <- readInt(i)
+    i <- i + 4
+    if (length != 0)
+      parts <- append(parts, list(data[i:(i+length-1)]))
+    else
+      parts <- append(parts, list(raw(0)))
+    i <- i + length
+  }
+  
+  mainMessage <- decodeMessage(parts[[1]])
+  mainMessage$blobs <- parts[2:length(parts)]
+  return(mainMessage)
+}
+
+# Takes a list-of-lists and returns a matrix. The lists
+# must all be the same length. NULL is replaced by NA.
+unpackMatrix <- function(data) {
+  if (length(data) == 0)
+    return(matrix(nrow=0, ncol=0))
+  
+  m <- matrix(unlist(lapply(data, function(x) {
+    sapply(x, function(y) {
+      ifelse(is.null(y), NA, y)
+    })
+  })), nrow = length(data[[1]]), ncol = length(data))
+  return(m)
+}
+
+# Combine dir and (file)name into a file path. If a file already exists with a
+# name differing only by case, then use it instead.
+file.path.ci <- function(dir, name) {
+  default <- file.path(dir, name)
+  if (file.exists(default))
+    return(default)
+  if (!file.exists(dir))
+    return(default)
+  
+  matches <- list.files(dir, name, ignore.case=TRUE, full.names=TRUE,
+                        include.dirs=TRUE)
+  if (length(matches) == 0)
+    return(default)
+  return(matches[[1]])
+}
+
 # Instantiates the app in the current working directory.
 # port - The TCP port that the application should listen on.
 startApp <- function(port=8101L) {
 
   sys.www.root <- system.file('www', package='shiny')
   
-  globalR <- file.path(getwd(), 'global.R')
-  uiR <- file.path(getwd(), 'ui.R')
-  serverR <- file.path(getwd(), 'server.R')
-  wwwDir <- file.path(getwd(), 'www')
+  globalR <- file.path.ci(getwd(), 'global.R')
+  uiR <- file.path.ci(getwd(), 'ui.R')
+  serverR <- file.path.ci(getwd(), 'server.R')
+  wwwDir <- file.path.ci(getwd(), 'www')
   
   if (!file.exists(uiR) && !file.exists(wwwDir))
     stop(paste("Neither ui.R nor a www subdirectory was found in", getwd()))
@@ -298,13 +653,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=TRUE)
     if (is.null(.globals$server))
       stop("No server was defined in server.R")
   })
@@ -312,37 +667,60 @@ startApp <- function(port=8101L) {
   
   ws_env <- create_server(
     port=port,
-    webpage=httpServer(c(dynamicHandler(uiR), wwwDir, sys.www.root)))
+    webpage=httpServer(c(sessionHandler,
+                         dynamicHandler(uiR),
+                         wwwDir,
+                         sys.www.root,
+                         resourcePathHandler)))
   
   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))
-      message("RECV ", rawToChar(DATA))
+    if (getOption('shiny.trace', FALSE)) {
+      if (as.raw(0) %in% DATA)
+        message("RECV ", '$$binary data$$')
+      else
+        message("RECV ", rawToChar(DATA))
+    }
     
     if (identical(charToRaw("\003\xe9"), DATA))
       return()
     
     shinyapp <- apps$get(wsToKey(WS))
     
-    msg <- fromJSON(rawToChar(DATA), asText=T, simplify=F)
-    
+    msg <- decodeMessage(DATA)
+
     # Do our own list simplifying here. sapply/simplify2array give names to
     # character vectors, which is rarely what we want.
     if (!is.null(msg$data)) {
-      msg$data <- lapply(msg$data, function(x) {
-        if (is.list(x) && is.null(names(x)))
-          unlist(x, recursive=F)
-        else
-          x
-      })
+      for (name in names(msg$data)) {
+        val <- msg$data[[name]]
+        
+        splitName <- strsplit(name, ':')[[1]]
+        if (length(splitName) > 1) {
+          msg$data[[name]] <- NULL
+          
+          # TODO: Make the below a user-extensible registry of deserializers
+          msg$data[[ splitName[[1]] ]] <- switch(
+            splitName[[2]],
+            matrix = unpackMatrix(val),
+            stop('Unknown type specified for ', name)
+          )
+        }
+        else if (is.list(val) && is.null(names(val)))
+          msg$data[[name]] <- unlist(val, recursive=FALSE)
+      }
     }
     
     switch(
@@ -355,13 +733,15 @@ startApp <- function(port=8101L) {
           shinyServer(NULL)
           local({
             serverFileTimestamp <<- mtime
-            source(serverR, local=T)
+            source(serverR, local=TRUE)
             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({
@@ -371,7 +751,9 @@ startApp <- function(port=8101L) {
       },
       update = {
         shinyapp$session$mset(msg$data)
-      })
+      },
+      shinyapp$dispatch(msg)
+    )
     flushReact()
     shinyapp$flushOutput()
   }, ws_env)
@@ -383,7 +765,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) {
@@ -423,6 +805,10 @@ runApp <- function(appDir=getwd(),
                    launch.browser=getOption('shiny.launch.browser',
                                             interactive())) {
 
+  # Make warnings print immediately
+  ops <- options(warn = 1)
+  on.exit(options(ops))
+  
   orig.wd <- getwd()
   setwd(appDir)
   on.exit(setwd(orig.wd))
@@ -435,10 +821,11 @@ runApp <- function(appDir=getwd(),
   }
   
   tryCatch(
-    while (T) {
+    while (TRUE) {
       serviceApp(ws_env)
     },
     finally = {
+      timerCallbacks$clear()
       websocket_close(ws_env)
     }
   )
@@ -482,3 +869,102 @@ runExample <- function(example=NA,
     runApp(dir, port = port, launch.browser = launch.browser)
   }
 }
+
+# This is a wrapper for download.file and has the same interface.
+# The only difference is that, if the protocol is https, it changes the
+# download settings, depending on platform.
+download <- function(url, ...) {
+  # First, check protocol. If https, check platform:
+  if (grepl('^https://', url)) {
+    
+    # If Windows, call setInternet2, then use download.file with defaults.
+    if (.Platform$OS.type == "windows") {
+      # If we directly use setInternet2, R CMD CHECK gives a Note on Mac/Linux
+      mySI2 <- `::`(utils, 'setInternet2')
+      # Store initial settings
+      internet2_start <- mySI2(NA)
+      on.exit(mySI2(internet2_start))
+      
+      # Needed for https
+      mySI2(TRUE)
+      download.file(url, ...)
+      
+    } else {
+      # If non-Windows, check for curl/wget/lynx, then call download.file with
+      # appropriate method.
+      
+      if (nzchar(Sys.which("wget")[1])) {
+        method <- "wget"
+      } else if (nzchar(Sys.which("curl")[1])) {
+        method <- "curl"
+        
+        # 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 {
+        stop("no download method found")
+      }
+      
+      download.file(url, method = method, ...)
+    }
+    
+  } else {
+    download.file(url, ...)
+  }
+}
+
+#' Run a Shiny application from https://gist.github.com
+#' 
+#' Download and launch a Shiny application that is hosted on GitHub as a gist.
+#' 
+#' @param gist The identifier of the gist. For example, if the gist is
+#'   https://gist.github.com/3239667, then \code{3239667}, \code{'3239667'}, and
+#'   \code{'https://gist.github.com/3239667'} are all valid values.
+#' @param port The TCP port that the application should listen on. Defaults to 
+#'   port 8100.
+#' @param launch.browser If true, the system's default web browser will be 
+#'   launched automatically after the app is started. Defaults to true in 
+#'   interactive sessions only.
+#'   
+#' @export
+runGist <- function(gist,
+                    port=8100L,
+                    launch.browser=getOption('shiny.launch.browser',
+                                             interactive())) {
+
+  gistUrl <- if (is.numeric(gist) || grepl('^[0-9a-f]+$', gist)) {
+    sprintf('https://gist.github.com/gists/%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='')
+  } else {
+    stop('Unrecognized gist identifier format')
+  }
+  filePath <- tempfile('shinygist', fileext='.tar.gz')
+  if (download(gistUrl, filePath, mode = "wb", quiet = TRUE) != 0)
+    stop("Failed to download URL ", gistUrl)
+  on.exit(unlink(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))
+  
+  runApp(appdir, port=port, launch.browser=launch.browser)
+}

R/shinyui.R

@@ -47,17 +47,66 @@ 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
+#' 
+#' Use \code{singleton} to wrap contents (tag, text, HTML, or lists) that should
+#' be included in the generated document only once, yet may appear in the 
+#' document-generating code more than once. Only the first appearance of the 
+#' content (in document order) will be used. Useful for custom components that 
+#' have JavaScript files or stylesheets.
+#' 
+#' @param x A \code{\link{tag}}, text, \code{\link{HTML}}, or list.
+#'
+#' @export
+singleton <- function(x) {
+  class(x) <- c(class(x), 'shiny.singleton')
+  return(x)
+}
 
 renderPage <- function(ui, connection) {
   
   # provide a filter so we can intercept head tag requests
   context <- new.env()
   context$head <- character()
-  context$filter <- function(tag) {
-    if (identical(tag$name, "head")) {
+  context$singletons <- character()
+  context$filter <- function(content) {
+    if (inherits(content, 'shiny.singleton')) {
+      sig <- digest(content, algo='sha1')
+      if (sig %in% context$singletons)
+        return(FALSE)
+      context$singletons <- c(sig, context$singletons)
+    }
+    
+    if (isTag(content) && identical(content$name, "head")) {
       textConn <- textConnection(NULL, "w") 
       textConnWriter <- function(text) cat(text, file = textConn)
-      tagWriteChildren(tag, textConnWriter, 1, context)
+      tagWriteChildren(content, textConnWriter, 1, context)
       context$head <- append(context$head, textConnectionValue(textConn))
       close(textConn)
       return (FALSE)
@@ -81,7 +130,7 @@ renderPage <- function(ui, connection) {
                '   <script src="shared/jquery.js" type="text/javascript"></script>',
                '   <script src="shared/shiny.js" type="text/javascript"></script>',
                '   <link rel="stylesheet" type="text/css" href="shared/shiny.css"/>',
-               context$head[!duplicated(context$head)],
+               context$head,
                '</head>',
                '<body>', 
                recursive=TRUE),
@@ -135,6 +184,8 @@ renderPage <- function(ui, connection) {
 #' @export
 shinyUI <- function(ui, path='/') {
   
+  force(ui)
+  
   registerClient({
     
     function(ws, header) {
@@ -146,7 +197,7 @@ shinyUI <- function(ui, path='/') {
       
       renderPage(ui, textConn)
       html <- paste(textConnectionValue(textConn), collapse='\n')
-      return(http_response(ws, 200, content=html))
+      return(httpResponse(200, content=html))
     }
   })
 }

R/shinywrappers.R

@@ -12,10 +12,16 @@ suppressPackageStartupMessages({
 #' the CSS class name \code{shiny-plot-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 +29,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).
@@ -39,6 +55,7 @@ reactivePlot <- function(func, width='auto', height='auto', ...) {
       return(NULL)
     
     do.call(png, c(args, filename=png.file, width=width, height=height))
+    on.exit(unlink(png.file))
     tryCatch(
       func(),
       finally=dev.off())
@@ -47,8 +64,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,21 +86,26 @@ 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, ...) {
   reactive(function() {
     classNames <- getOption('shiny.table.class', 'data table table-bordered table-condensed')
     data <- func()
+
+    if (is.null(data) || is.na(data))
+      return("")
+    
     return(paste(
       capture.output(
         print(xtable(data, ...), 
               type='html', 
               html.table.attributes=paste('class="',
-                                          htmlEscape(classNames, T),
+                                          htmlEscape(classNames, TRUE),
                                           '"',
-                                          sep=''))),
+                                          sep=''), ...)),
       collapse="\n"))
   })
 }
@@ -124,4 +153,82 @@ reactiveText <- function(func) {
   reactive(function() {
     return(paste(capture.output(cat(func())), collapse="\n"))
   })
+}
+
+#' UI Output
+#' 
+#' \bold{Experimental feature.} Makes a reactive version of a function that
+#' generates HTML using the Shiny UI library.
+#' 
+#' The corresponding HTML output tag should be \code{div} and have the CSS class
+#' name \code{shiny-html-output} (or use \code{\link{uiOutput}}).
+#' 
+#' @param func A function that returns a Shiny tag object, \code{\link{HTML}}, 
+#'   or a list of such objects.
+#'   
+#' @seealso conditionalPanel
+#'   
+#' @export
+#' @examples
+#' \dontrun{
+#'   output$moreControls <- reactiveUI(function() {
+#'     list(
+#'       
+#'     )
+#'   })
+#' }
+reactiveUI <- function(func) {
+  reactive(function() {
+    result <- func()
+    if (is.null(result) || length(result) == 0)
+      return(NULL)
+    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/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,26 +101,18 @@ slider <- function(inputId, min, max, value, step = NULL, ...,
   }
   
   # build slider
-  sliderFragment <- list(
-    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 <- 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)
@@ -64,6 +64,15 @@ as.character.shiny.tag <- function(x, ...) {
   return(HTML(paste(readLines(f), collapse='\n')))
 }
 
+#' @S3method print shiny.tag.list
+print.shiny.tag.list <- print.shiny.tag
+
+#' @S3method format shiny.tag.list
+format.shiny.tag.list <- format.shiny.tag
+
+#' @S3method as.character shiny.tag.list
+as.character.shiny.tag.list <- as.character.shiny.tag
+
 normalizeText <- function(text) {
   if (!is.null(attr(text, "html")))
     text
@@ -72,6 +81,13 @@ normalizeText <- function(text) {
   
 }
 
+#' @export
+tagList <- function(...) {
+  lst <- list(...)
+  class(lst) <- c("shiny.tag.list", "list")
+  return(lst)
+}
+
 #' @export
 tagAppendChild <- function(tag, child) {
   tag$children[[length(tag$children)+1]] <- child
@@ -150,9 +166,12 @@ tagWriteChildren <- function(tag, textWriter, indent, context) {
       tagWrite(child, textWriter, indent, context)
     }
     else {
-      child <- normalizeText(child)
-      indentText <- paste(rep(" ", indent*3), collapse="")
-      textWriter(paste(indentText, child, "\n", sep=""))
+      # first call optional filter -- exit function if it returns false
+      if (is.null(context) || is.null(context$filter) || context$filter(child)) {
+        child <- normalizeText(child)
+        indentText <- paste(rep(" ", indent*3), collapse="")
+        textWriter(paste(indentText, child, "\n", sep=""))
+      }
     }
   }
 }
@@ -194,8 +213,11 @@ tagWrite <- function(tag, textWriter, indent=0, context = NULL) {
     
     # special case for a single child text node (skip newlines and indentation)
     if ((length(tag$children) == 1) && is.character(tag$children[[1]]) ) {
-      text <- normalizeText(tag$children[[1]])
-      textWriter(paste(">", text, "</", tag$name, ">\n", sep=""))
+      if (is.null(context) || is.null(context$filter) 
+          || context$filter(tag$children[[1]])) {
+        text <- normalizeText(tag$children[[1]])
+        textWriter(paste(">", text, "</", tag$name, ">\n", sep=""))
+      }
     }
     else {
       textWriter(">\n")

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.
@@ -17,30 +19,11 @@ Shiny is a new package from RStudio that makes it incredibly easy to build inter
 
 ## Installation
 
-### Linux & Mac
-
-First download the Shiny source package from here:
-
-[https://github.com/downloads/rstudio/shiny/shiny_0.1.1.tar.gz](https://github.com/downloads/rstudio/shiny/shiny_0.1.1.tar.gz)
-
-Now install the package as follows (substituting *\<shiny-pkg-file\>* with the path to which you downloaded the package):
+From an R console:
 
 ```r
-install.packages(c("websockets", "RJSONIO", "xtable"))
-install.packages("<shiny-pkg-file>", repos = NULL, type="source")
-```
-
-### Windows
-
-First download the Shiny binary package from here:
-
-[https://github.com/downloads/rstudio/shiny/shiny_0.1.1.zip](https://github.com/downloads/rstudio/shiny/shiny_0.1.1.zip)
-
-Now install the package as follows (substituting *\<shiny-pkg-file\>* with the path to which you downloaded the package):
-
-```r
-install.packages(c("websockets", "RJSONIO", "xtable"))
-install.packages("<shiny-pkg-file>", repos = NULL)
+options(repos=c(RStudio="http://rstudio.org/_packages", getOption("repos")))
+install.packages("shiny")
 ```
 
 ## Getting Started

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

@@ -0,0 +1,18 @@
+library(shiny)
+
+shinyServer(function(input, output) {
+  output$contents <- reactiveTable(function() {
+    
+    # input$file1 will be NULL initially. After the user selects and uploads a 
+    # file, it will be a data frame with 'name', 'size', 'type', and 'data' 
+    # columns. The 'data' column will contain the local filenames where the data
+    # can be found.
+
+    inFile <- input$file1
+
+    if (is.null(inFile))
+      return(NULL)
+    
+    read.csv(inFile$data, header=input$header, sep=input$sep, quote=input$quote)
+  })
+})

inst/examples/09_upload/ui.R

@@ -0,0 +1,24 @@
+library(shiny)
+
+shinyUI(pageWithSidebar(
+  headerPanel("CSV Viewer"),
+  sidebarPanel(
+    fileInput('file1', 'Choose CSV File',
+              accept=c('text/csv', 'text/comma-separated-values,text/plain')),
+    tags$hr(),
+    checkboxInput('header', 'Header', TRUE),
+    radioButtons('sep', 'Separator',
+                 c(Comma=',',
+                   Semicolon=';',
+                   Tab='\t'),
+                 'Comma'),
+    radioButtons('quote', 'Quote',
+                 c(None='',
+                   'Double Quote'='"',
+                   'Single Quote'="'"),
+                 'Double Quote')
+  ),
+  mainPanel(
+    tableOutput('contents')
+  )
+))

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/bootstrap/js/bootstrap.js

@@ -1,5 +1,5 @@
 /* ===================================================
- * bootstrap-transition.js v2.0.4
+ * bootstrap-transition.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#transitions
  * ===================================================
  * Copyright 2012 Twitter, Inc.
@@ -36,8 +36,7 @@
           , transEndEventNames = {
                'WebkitTransition' : 'webkitTransitionEnd'
             ,  'MozTransition'    : 'transitionend'
-            ,  'OTransition'      : 'oTransitionEnd'
-            ,  'msTransition'     : 'MSTransitionEnd'
+            ,  'OTransition'      : 'oTransitionEnd otransitionend'
             ,  'transition'       : 'transitionend'
             }
           , name
@@ -59,7 +58,7 @@
   })
 
 }(window.jQuery);/* ==========================================================
- * bootstrap-alert.js v2.0.4
+ * bootstrap-alert.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#alerts
  * ==========================================================
  * Copyright 2012 Twitter, Inc.
@@ -148,7 +147,7 @@
   })
 
 }(window.jQuery);/* ============================================================
- * bootstrap-button.js v2.0.4
+ * bootstrap-button.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#buttons
  * ============================================================
  * Copyright 2012 Twitter, Inc.
@@ -243,7 +242,7 @@
   })
 
 }(window.jQuery);/* ==========================================================
- * bootstrap-carousel.js v2.0.4
+ * bootstrap-carousel.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#carousel
  * ==========================================================
  * Copyright 2012 Twitter, Inc.
@@ -290,7 +289,7 @@
     }
 
   , to: function (pos) {
-      var $active = this.$element.find('.active')
+      var $active = this.$element.find('.item.active')
         , children = $active.parent().children()
         , activePos = children.index($active)
         , that = this
@@ -312,6 +311,10 @@
 
   , pause: function (e) {
       if (!e) this.paused = true
+      if (this.$element.find('.next, .prev').length && $.support.transition.end) {
+        this.$element.trigger($.support.transition.end)
+        this.cycle()
+      }
       clearInterval(this.interval)
       this.interval = null
       return this
@@ -328,13 +331,15 @@
     }
 
   , slide: function (type, next) {
-      var $active = this.$element.find('.active')
+      var $active = this.$element.find('.item.active')
         , $next = next || $active[type]()
         , isCycling = this.interval
         , direction = type == 'next' ? 'left' : 'right'
         , fallback  = type == 'next' ? 'first' : 'last'
         , that = this
-        , e = $.Event('slide')
+        , e = $.Event('slide', {
+            relatedTarget: $next[0]
+          })
 
       this.sliding = true
 
@@ -382,9 +387,10 @@
       var $this = $(this)
         , data = $this.data('carousel')
         , options = $.extend({}, $.fn.carousel.defaults, typeof option == 'object' && option)
+        , action = typeof option == 'string' ? option : options.slide
       if (!data) $this.data('carousel', (data = new Carousel(this, options)))
       if (typeof option == 'number') data.to(option)
-      else if (typeof option == 'string' || (option = options.slide)) data[option]()
+      else if (action) data[action]()
       else if (options.interval) data.cycle()
     })
   }
@@ -411,7 +417,7 @@
   })
 
 }(window.jQuery);/* =============================================================
- * bootstrap-collapse.js v2.0.4
+ * bootstrap-collapse.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#collapse
  * =============================================================
  * Copyright 2012 Twitter, Inc.
@@ -479,7 +485,7 @@
 
       this.$element[dimension](0)
       this.transition('addClass', $.Event('show'), 'shown')
-      this.$element[dimension](this.$element[0][scroll])
+      $.support.transition && this.$element[dimension](this.$element[0][scroll])
     }
 
   , hide: function () {
@@ -556,18 +562,19 @@
   * ==================== */
 
   $(function () {
-    $('body').on('click.collapse.data-api', '[data-toggle=collapse]', function ( e ) {
+    $('body').on('click.collapse.data-api', '[data-toggle=collapse]', function (e) {
       var $this = $(this), href
         , target = $this.attr('data-target')
           || e.preventDefault()
           || (href = $this.attr('href')) && href.replace(/.*(?=#[^\s]+$)/, '') //strip for ie7
         , option = $(target).data('collapse') ? 'toggle' : $this.data()
+      $this[$(target).hasClass('in') ? 'addClass' : 'removeClass']('collapsed')
       $(target).collapse(option)
     })
   })
 
 }(window.jQuery);/* ============================================================
- * bootstrap-dropdown.js v2.0.4
+ * bootstrap-dropdown.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#dropdowns
  * ============================================================
  * Copyright 2012 Twitter, Inc.
@@ -594,7 +601,7 @@
  /* DROPDOWN CLASS DEFINITION
   * ========================= */
 
-  var toggle = '[data-toggle="dropdown"]'
+  var toggle = '[data-toggle=dropdown]'
     , Dropdown = function (element) {
         var $el = $(element).on('click.dropdown.data-api', this.toggle)
         $('html').on('click.dropdown.data-api', function () {
@@ -609,34 +616,82 @@
   , toggle: function (e) {
       var $this = $(this)
         , $parent
-        , selector
         , isActive
 
       if ($this.is('.disabled, :disabled')) return
 
-      selector = $this.attr('data-target')
-
-      if (!selector) {
-        selector = $this.attr('href')
-        selector = selector && selector.replace(/.*(?=#[^\s]*$)/, '') //strip for ie7
-      }
-
-      $parent = $(selector)
-      $parent.length || ($parent = $this.parent())
+      $parent = getParent($this)
 
       isActive = $parent.hasClass('open')
 
       clearMenus()
 
-      if (!isActive) $parent.toggleClass('open')
+      if (!isActive) {
+        $parent.toggleClass('open')
+        $this.focus()
+      }
 
       return false
     }
 
+  , keydown: function (e) {
+      var $this
+        , $items
+        , $active
+        , $parent
+        , isActive
+        , index
+
+      if (!/(38|40|27)/.test(e.keyCode)) return
+
+      $this = $(this)
+
+      e.preventDefault()
+      e.stopPropagation()
+
+      if ($this.is('.disabled, :disabled')) return
+
+      $parent = getParent($this)
+
+      isActive = $parent.hasClass('open')
+
+      if (!isActive || (isActive && e.keyCode == 27)) return $this.click()
+
+      $items = $('[role=menu] li:not(.divider) a', $parent)
+
+      if (!$items.length) return
+
+      index = $items.index($items.filter(':focus'))
+
+      if (e.keyCode == 38 && index > 0) index--                                        // up
+      if (e.keyCode == 40 && index < $items.length - 1) index++                        // down
+      if (!~index) index = 0
+
+      $items
+        .eq(index)
+        .focus()
+    }
+
   }
 
   function clearMenus() {
-    $(toggle).parent().removeClass('open')
+    getParent($(toggle))
+      .removeClass('open')
+  }
+
+  function getParent($this) {
+    var selector = $this.attr('data-target')
+      , $parent
+
+    if (!selector) {
+      selector = $this.attr('href')
+      selector = selector && selector.replace(/.*(?=#[^\s]*$)/, '') //strip for ie7
+    }
+
+    $parent = $(selector)
+    $parent.length || ($parent = $this.parent())
+
+    return $parent
   }
 
 
@@ -659,14 +714,16 @@
    * =================================== */
 
   $(function () {
-    $('html').on('click.dropdown.data-api', clearMenus)
+    $('html')
+      .on('click.dropdown.data-api touchstart.dropdown.data-api', clearMenus)
     $('body')
-      .on('click.dropdown', '.dropdown form', function (e) { e.stopPropagation() })
-      .on('click.dropdown.data-api', toggle, Dropdown.prototype.toggle)
+      .on('click.dropdown touchstart.dropdown.data-api', '.dropdown', function (e) { e.stopPropagation() })
+      .on('click.dropdown.data-api touchstart.dropdown.data-api'  , toggle, Dropdown.prototype.toggle)
+      .on('keydown.dropdown.data-api touchstart.dropdown.data-api', toggle + ', [role=menu]' , Dropdown.prototype.keydown)
   })
 
 }(window.jQuery);/* =========================================================
- * bootstrap-modal.js v2.0.4
+ * bootstrap-modal.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#modals
  * =========================================================
  * Copyright 2012 Twitter, Inc.
@@ -693,10 +750,11 @@
  /* MODAL CLASS DEFINITION
   * ====================== */
 
-  var Modal = function (content, options) {
+  var Modal = function (element, options) {
     this.options = options
-    this.$element = $(content)
+    this.$element = $(element)
       .delegate('[data-dismiss="modal"]', 'click.dismiss.modal', $.proxy(this.hide, this))
+    this.options.remote && this.$element.find('.modal-body').load(this.options.remote)
   }
 
   Modal.prototype = {
@@ -719,8 +777,9 @@
 
         this.isShown = true
 
-        escape.call(this)
-        backdrop.call(this, function () {
+        this.escape()
+
+        this.backdrop(function () {
           var transition = $.support.transition && that.$element.hasClass('fade')
 
           if (!that.$element.parent().length) {
@@ -734,7 +793,12 @@
             that.$element[0].offsetWidth // force reflow
           }
 
-          that.$element.addClass('in')
+          that.$element
+            .addClass('in')
+            .attr('aria-hidden', false)
+            .focus()
+
+          that.enforceFocus()
 
           transition ?
             that.$element.one($.support.transition.end, function () { that.$element.trigger('shown') }) :
@@ -758,90 +822,98 @@
 
         $('body').removeClass('modal-open')
 
-        escape.call(this)
+        this.escape()
 
-        this.$element.removeClass('in')
+        $(document).off('focusin.modal')
+
+        this.$element
+          .removeClass('in')
+          .attr('aria-hidden', true)
 
         $.support.transition && this.$element.hasClass('fade') ?
-          hideWithTransition.call(this) :
-          hideModal.call(this)
+          this.hideWithTransition() :
+          this.hideModal()
       }
 
-  }
-
-
- /* MODAL PRIVATE METHODS
-  * ===================== */
-
-  function hideWithTransition() {
-    var that = this
-      , timeout = setTimeout(function () {
-          that.$element.off($.support.transition.end)
-          hideModal.call(that)
-        }, 500)
-
-    this.$element.one($.support.transition.end, function () {
-      clearTimeout(timeout)
-      hideModal.call(that)
-    })
-  }
-
-  function hideModal(that) {
-    this.$element
-      .hide()
-      .trigger('hidden')
-
-    backdrop.call(this)
-  }
-
-  function backdrop(callback) {
-    var that = this
-      , animate = this.$element.hasClass('fade') ? 'fade' : ''
-
-    if (this.isShown && this.options.backdrop) {
-      var doAnimate = $.support.transition && animate
-
-      this.$backdrop = $('<div class="modal-backdrop ' + animate + '" />')
-        .appendTo(document.body)
-
-      if (this.options.backdrop != 'static') {
-        this.$backdrop.click($.proxy(this.hide, this))
+    , enforceFocus: function () {
+        var that = this
+        $(document).on('focusin.modal', function (e) {
+          if (that.$element[0] !== e.target && !that.$element.has(e.target).length) {
+            that.$element.focus()
+          }
+        })
       }
 
-      if (doAnimate) this.$backdrop[0].offsetWidth // force reflow
+    , escape: function () {
+        var that = this
+        if (this.isShown && this.options.keyboard) {
+          this.$element.on('keyup.dismiss.modal', function ( e ) {
+            e.which == 27 && that.hide()
+          })
+        } else if (!this.isShown) {
+          this.$element.off('keyup.dismiss.modal')
+        }
+      }
 
-      this.$backdrop.addClass('in')
+    , hideWithTransition: function () {
+        var that = this
+          , timeout = setTimeout(function () {
+              that.$element.off($.support.transition.end)
+              that.hideModal()
+            }, 500)
 
-      doAnimate ?
-        this.$backdrop.one($.support.transition.end, callback) :
-        callback()
+        this.$element.one($.support.transition.end, function () {
+          clearTimeout(timeout)
+          that.hideModal()
+        })
+      }
 
-    } else if (!this.isShown && this.$backdrop) {
-      this.$backdrop.removeClass('in')
+    , hideModal: function (that) {
+        this.$element
+          .hide()
+          .trigger('hidden')
 
-      $.support.transition && this.$element.hasClass('fade')?
-        this.$backdrop.one($.support.transition.end, $.proxy(removeBackdrop, this)) :
-        removeBackdrop.call(this)
+        this.backdrop()
+      }
 
-    } else if (callback) {
-      callback()
-    }
-  }
+    , removeBackdrop: function () {
+        this.$backdrop.remove()
+        this.$backdrop = null
+      }
 
-  function removeBackdrop() {
-    this.$backdrop.remove()
-    this.$backdrop = null
-  }
+    , backdrop: function (callback) {
+        var that = this
+          , animate = this.$element.hasClass('fade') ? 'fade' : ''
 
-  function escape() {
-    var that = this
-    if (this.isShown && this.options.keyboard) {
-      $(document).on('keyup.dismiss.modal', function ( e ) {
-        e.which == 27 && that.hide()
-      })
-    } else if (!this.isShown) {
-      $(document).off('keyup.dismiss.modal')
-    }
+        if (this.isShown && this.options.backdrop) {
+          var doAnimate = $.support.transition && animate
+
+          this.$backdrop = $('<div class="modal-backdrop ' + animate + '" />')
+            .appendTo(document.body)
+
+          if (this.options.backdrop != 'static') {
+            this.$backdrop.click($.proxy(this.hide, this))
+          }
+
+          if (doAnimate) this.$backdrop[0].offsetWidth // force reflow
+
+          this.$backdrop.addClass('in')
+
+          doAnimate ?
+            this.$backdrop.one($.support.transition.end, callback) :
+            callback()
+
+        } else if (!this.isShown && this.$backdrop) {
+          this.$backdrop.removeClass('in')
+
+          $.support.transition && this.$element.hasClass('fade')?
+            this.$backdrop.one($.support.transition.end, $.proxy(this.removeBackdrop, this)) :
+            this.removeBackdrop()
+
+        } else if (callback) {
+          callback()
+        }
+      }
   }
 
 
@@ -873,17 +945,23 @@
 
   $(function () {
     $('body').on('click.modal.data-api', '[data-toggle="modal"]', function ( e ) {
-      var $this = $(this), href
-        , $target = $($this.attr('data-target') || (href = $this.attr('href')) && href.replace(/.*(?=#[^\s]+$)/, '')) //strip for ie7
-        , option = $target.data('modal') ? 'toggle' : $.extend({}, $target.data(), $this.data())
+      var $this = $(this)
+        , href = $this.attr('href')
+        , $target = $($this.attr('data-target') || (href && href.replace(/.*(?=#[^\s]+$)/, ''))) //strip for ie7
+        , option = $target.data('modal') ? 'toggle' : $.extend({ remote: !/#/.test(href) && href }, $target.data(), $this.data())
 
       e.preventDefault()
-      $target.modal(option)
+
+      $target
+        .modal(option)
+        .one('hide', function () {
+          $this.focus()
+        })
     })
   })
 
 }(window.jQuery);/* ===========================================================
- * bootstrap-tooltip.js v2.0.4
+ * bootstrap-tooltip.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#tooltips
  * Inspired by the original jQuery.tipsy by Jason Frame
  * ===========================================================
@@ -928,11 +1006,13 @@
       this.options = this.getOptions(options)
       this.enabled = true
 
-      if (this.options.trigger != 'manual') {
-        eventIn  = this.options.trigger == 'hover' ? 'mouseenter' : 'focus'
+      if (this.options.trigger == 'click') {
+        this.$element.on('click.' + this.type, this.options.selector, $.proxy(this.toggle, this))
+      } else if (this.options.trigger != 'manual') {
+        eventIn = this.options.trigger == 'hover' ? 'mouseenter' : 'focus'
         eventOut = this.options.trigger == 'hover' ? 'mouseleave' : 'blur'
-        this.$element.on(eventIn, this.options.selector, $.proxy(this.enter, this))
-        this.$element.on(eventOut, this.options.selector, $.proxy(this.leave, this))
+        this.$element.on(eventIn + '.' + this.type, this.options.selector, $.proxy(this.enter, this))
+        this.$element.on(eventOut + '.' + this.type, this.options.selector, $.proxy(this.leave, this))
       }
 
       this.options.selector ?
@@ -1032,20 +1112,11 @@
       }
     }
 
-  , isHTML: function(text) {
-      // html string detection logic adapted from jQuery
-      return typeof text != 'string'
-        || ( text.charAt(0) === "<"
-          && text.charAt( text.length - 1 ) === ">"
-          && text.length >= 3
-        ) || /^(?:[^<]*<[\w\W]+>[^>]*$)/.exec(text)
-    }
-
   , setContent: function () {
       var $tip = this.tip()
         , title = this.getTitle()
 
-      $tip.find('.tooltip-inner')[this.isHTML(title) ? 'html' : 'text'](title)
+      $tip.find('.tooltip-inner')[this.options.html ? 'html' : 'text'](title)
       $tip.removeClass('fade in top bottom left right')
     }
 
@@ -1069,6 +1140,8 @@
       $.support.transition && this.$tip.hasClass('fade') ?
         removeWithAnimation() :
         $tip.remove()
+
+      return this
     }
 
   , fixTitle: function () {
@@ -1128,6 +1201,10 @@
       this[this.tip().hasClass('in') ? 'hide' : 'show']()
     }
 
+  , destroy: function () {
+      this.hide().$element.off('.' + this.type).removeData(this.type)
+    }
+
   }
 
 
@@ -1154,11 +1231,12 @@
   , trigger: 'hover'
   , title: ''
   , delay: 0
+  , html: true
   }
 
 }(window.jQuery);
 /* ===========================================================
- * bootstrap-popover.js v2.0.4
+ * bootstrap-popover.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#popovers
  * ===========================================================
  * Copyright 2012 Twitter, Inc.
@@ -1185,7 +1263,7 @@
  /* POPOVER PUBLIC CLASS DEFINITION
   * =============================== */
 
-  var Popover = function ( element, options ) {
+  var Popover = function (element, options) {
     this.init('popover', element, options)
   }
 
@@ -1202,8 +1280,8 @@
         , title = this.getTitle()
         , content = this.getContent()
 
-      $tip.find('.popover-title')[this.isHTML(title) ? 'html' : 'text'](title)
-      $tip.find('.popover-content > *')[this.isHTML(content) ? 'html' : 'text'](content)
+      $tip.find('.popover-title')[this.options.html ? 'html' : 'text'](title)
+      $tip.find('.popover-content > *')[this.options.html ? 'html' : 'text'](content)
 
       $tip.removeClass('fade top bottom left right in')
     }
@@ -1230,6 +1308,10 @@
       return this.$tip
     }
 
+  , destroy: function () {
+      this.hide().$element.off('.' + this.type).removeData(this.type)
+    }
+
   })
 
 
@@ -1250,12 +1332,13 @@
 
   $.fn.popover.defaults = $.extend({} , $.fn.tooltip.defaults, {
     placement: 'right'
+  , trigger: 'click'
   , content: ''
   , template: '<div class="popover"><div class="arrow"></div><div class="popover-inner"><h3 class="popover-title"></h3><div class="popover-content"><p></p></div></div></div>'
   })
 
 }(window.jQuery);/* =============================================================
- * bootstrap-scrollspy.js v2.0.4
+ * bootstrap-scrollspy.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#scrollspy
  * =============================================================
  * Copyright 2012 Twitter, Inc.
@@ -1279,15 +1362,15 @@
   "use strict"; // jshint ;_;
 
 
-  /* SCROLLSPY CLASS DEFINITION
-   * ========================== */
+ /* SCROLLSPY CLASS DEFINITION
+  * ========================== */
 
-  function ScrollSpy( element, options) {
+  function ScrollSpy(element, options) {
     var process = $.proxy(this.process, this)
       , $element = $(element).is('body') ? $(window) : $(element)
       , href
     this.options = $.extend({}, $.fn.scrollspy.defaults, options)
-    this.$scrollElement = $element.on('scroll.scroll.data-api', process)
+    this.$scrollElement = $element.on('scroll.scroll-spy.data-api', process)
     this.selector = (this.options.target
       || ((href = $(element).attr('href')) && href.replace(/.*(?=#[^\s]+$)/, '')) //strip for ie7
       || '') + ' .nav li > a'
@@ -1314,7 +1397,7 @@
               , href = $el.data('target') || $el.attr('href')
               , $href = /^#\w/.test(href) && $(href)
             return ( $href
-              && href.length
+              && $href.length
               && [[ $href.position().top, href ]] ) || null
           })
           .sort(function (a, b) { return a[0] - b[0] })
@@ -1364,7 +1447,7 @@
           .parent('li')
           .addClass('active')
 
-        if (active.parent('.dropdown-menu'))  {
+        if (active.parent('.dropdown-menu').length)  {
           active = active.closest('li.dropdown').addClass('active')
         }
 
@@ -1377,7 +1460,7 @@
  /* SCROLLSPY PLUGIN DEFINITION
   * =========================== */
 
-  $.fn.scrollspy = function ( option ) {
+  $.fn.scrollspy = function (option) {
     return this.each(function () {
       var $this = $(this)
         , data = $this.data('scrollspy')
@@ -1397,7 +1480,7 @@
  /* SCROLLSPY DATA-API
   * ================== */
 
-  $(function () {
+  $(window).on('load', function () {
     $('[data-spy="scroll"]').each(function () {
       var $spy = $(this)
       $spy.scrollspy($spy.data())
@@ -1405,7 +1488,7 @@
   })
 
 }(window.jQuery);/* ========================================================
- * bootstrap-tab.js v2.0.4
+ * bootstrap-tab.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#tabs
  * ========================================================
  * Copyright 2012 Twitter, Inc.
@@ -1432,7 +1515,7 @@
  /* TAB CLASS DEFINITION
   * ==================== */
 
-  var Tab = function ( element ) {
+  var Tab = function (element) {
     this.element = $(element)
   }
 
@@ -1539,7 +1622,7 @@
   })
 
 }(window.jQuery);/* =============================================================
- * bootstrap-typeahead.js v2.0.4
+ * bootstrap-typeahead.js v2.1.0
  * http://twitter.github.com/bootstrap/javascript.html#typeahead
  * =============================================================
  * Copyright 2012 Twitter, Inc.
@@ -1617,17 +1700,23 @@
     }
 
   , lookup: function (event) {
-      var that = this
-        , items
-        , q
+      var items
 
       this.query = this.$element.val()
 
-      if (!this.query) {
+      if (!this.query || this.query.length < this.options.minLength) {
         return this.shown ? this.hide() : this
       }
 
-      items = $.grep(this.source, function (item) {
+      items = $.isFunction(this.source) ? this.source(this.query, $.proxy(this.process, this)) : this.source
+
+      return items ? this.process(items) : this
+    }
+
+  , process: function (items) {
+      var that = this
+
+      items = $.grep(items, function (item) {
         return that.matcher(item)
       })
 
@@ -1709,7 +1798,7 @@
         .on('keyup',    $.proxy(this.keyup, this))
 
       if ($.browser.webkit || $.browser.msie) {
-        this.$element.on('keydown', $.proxy(this.keypress, this))
+        this.$element.on('keydown', $.proxy(this.keydown, this))
       }
 
       this.$menu
@@ -1717,6 +1806,40 @@
         .on('mouseenter', 'li', $.proxy(this.mouseenter, this))
     }
 
+  , move: function (e) {
+      if (!this.shown) return
+
+      switch(e.keyCode) {
+        case 9: // tab
+        case 13: // enter
+        case 27: // escape
+          e.preventDefault()
+          break
+
+        case 38: // up arrow
+          e.preventDefault()
+          this.prev()
+          break
+
+        case 40: // down arrow
+          e.preventDefault()
+          this.next()
+          break
+      }
+
+      e.stopPropagation()
+    }
+
+  , keydown: function (e) {
+      this.suppressKeyPressRepeat = !~$.inArray(e.keyCode, [40,38,9,13,27])
+      this.move(e)
+    }
+
+  , keypress: function (e) {
+      if (this.suppressKeyPressRepeat) return
+      this.move(e)
+    }
+
   , keyup: function (e) {
       switch(e.keyCode) {
         case 40: // down arrow
@@ -1742,32 +1865,6 @@
       e.preventDefault()
   }
 
-  , keypress: function (e) {
-      if (!this.shown) return
-
-      switch(e.keyCode) {
-        case 9: // tab
-        case 13: // enter
-        case 27: // escape
-          e.preventDefault()
-          break
-
-        case 38: // up arrow
-          if (e.type != 'keydown') break
-          e.preventDefault()
-          this.prev()
-          break
-
-        case 40: // down arrow
-          if (e.type != 'keydown') break
-          e.preventDefault()
-          this.next()
-          break
-      }
-
-      e.stopPropagation()
-    }
-
   , blur: function (e) {
       var that = this
       setTimeout(function () { that.hide() }, 150)
@@ -1805,12 +1902,13 @@
   , items: 8
   , menu: '<ul class="typeahead dropdown-menu"></ul>'
   , item: '<li><a href="#"></a></li>'
+  , minLength: 1
   }
 
   $.fn.typeahead.Constructor = Typeahead
 
 
- /* TYPEAHEAD DATA-API
+ /*   TYPEAHEAD DATA-API
   * ================== */
 
   $(function () {
@@ -1822,4 +1920,108 @@
     })
   })
 
+}(window.jQuery);
+/* ==========================================================
+ * bootstrap-affix.js v2.1.0
+ * http://twitter.github.com/bootstrap/javascript.html#affix
+ * ==========================================================
+ * Copyright 2012 Twitter, Inc.
+ *
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ * ========================================================== */
+
+
+!function ($) {
+
+  "use strict"; // jshint ;_;
+
+
+ /* AFFIX CLASS DEFINITION
+  * ====================== */
+
+  var Affix = function (element, options) {
+    this.options = $.extend({}, $.fn.affix.defaults, options)
+    this.$window = $(window).on('scroll.affix.data-api', $.proxy(this.checkPosition, this))
+    this.$element = $(element)
+    this.checkPosition()
+  }
+
+  Affix.prototype.checkPosition = function () {
+    if (!this.$element.is(':visible')) return
+
+    var scrollHeight = $(document).height()
+      , scrollTop = this.$window.scrollTop()
+      , position = this.$element.offset()
+      , offset = this.options.offset
+      , offsetBottom = offset.bottom
+      , offsetTop = offset.top
+      , reset = 'affix affix-top affix-bottom'
+      , affix
+
+    if (typeof offset != 'object') offsetBottom = offsetTop = offset
+    if (typeof offsetTop == 'function') offsetTop = offset.top()
+    if (typeof offsetBottom == 'function') offsetBottom = offset.bottom()
+
+    affix = this.unpin != null && (scrollTop + this.unpin <= position.top) ?
+      false    : offsetBottom != null && (position.top + this.$element.height() >= scrollHeight - offsetBottom) ?
+      'bottom' : offsetTop != null && scrollTop <= offsetTop ?
+      'top'    : false
+
+    if (this.affixed === affix) return
+
+    this.affixed = affix
+    this.unpin = affix == 'bottom' ? position.top - scrollTop : null
+
+    this.$element.removeClass(reset).addClass('affix' + (affix ? '-' + affix : ''))
+  }
+
+
+ /* AFFIX PLUGIN DEFINITION
+  * ======================= */
+
+  $.fn.affix = function (option) {
+    return this.each(function () {
+      var $this = $(this)
+        , data = $this.data('affix')
+        , options = typeof option == 'object' && option
+      if (!data) $this.data('affix', (data = new Affix(this, options)))
+      if (typeof option == 'string') data[option]()
+    })
+  }
+
+  $.fn.affix.Constructor = Affix
+
+  $.fn.affix.defaults = {
+    offset: 0
+  }
+
+
+ /* AFFIX DATA-API
+  * ============== */
+
+  $(window).on('load', function () {
+    $('[data-spy="affix"]').each(function () {
+      var $spy = $(this)
+        , data = $spy.data()
+
+      data.offset = data.offset || {}
+
+      data.offsetBottom && (data.offset.bottom = data.offsetBottom)
+      data.offsetTop && (data.offset.top = data.offsetTop)
+
+      $spy.affix(data)
+    })
+  })
+
+
 }(window.jQuery);

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 */

man/addResourcePath.Rd

@@ -0,0 +1,36 @@
+\name{addResourcePath}
+\alias{addResourcePath}
+\title{Resource Publishing}
+\usage{
+  addResourcePath(prefix, directoryPath)
+}
+\arguments{
+  \item{prefix}{The URL prefix (without slashes). Valid
+  characters are a-z, A-Z, 0-9, hyphen, and underscore; and
+  must begin with a-z or A-Z. For example, a value of 'foo'
+  means that any request paths that begin with '/foo' will
+  be mapped to the given directory.}
+
+  \item{directoryPath}{The directory that contains the
+  static resources to be served.}
+}
+\description{
+  Adds a directory of static resources to Shiny's web
+  server, with the given path prefix. Primarily intended
+  for package authors to make supporting JavaScript/CSS
+  files available to their components.
+}
+\details{
+  You can call \code{addResourcePath} multiple times for a
+  given \code{prefix}; only the most recent value will be
+  retained. If the normalized \code{directoryPath} is
+  different than the directory that's currently mapped to
+  the \code{prefix}, a warning will be issued.
+}
+\examples{
+addResourcePath('datasets', system.file('data', package='datasets'))
+}
+\seealso{
+  \code{\link{singleton}}
+}
+

man/bootstrapPage.Rd

@@ -0,0 +1,26 @@
+\name{bootstrapPage}
+\alias{bootstrapPage}
+\title{Create a Twitter Bootstrap page}
+\usage{
+  bootstrapPage(...)
+}
+\arguments{
+  \item{...}{The contents of the document body.}
+}
+\value{
+  A UI defintion that can be passed to the \link{shinyUI}
+  function.
+}
+\description{
+  Create a Shiny UI page that loads the CSS and JavaScript
+  for \href{http://getbootstrap.com}{Twitter Bootstrap},
+  and has no content in the page body (other than what you
+  provide).
+}
+\details{
+  This function is primarily intended for users who are
+  proficient in HTML/CSS, and know how to lay out pages in
+  Bootstrap. Most users should use template functions like
+  \code{\link{pageWithSidebar}}.
+}
+

man/checkboxGroupInput.Rd

@@ -0,0 +1,39 @@
+\name{checkboxGroupInput}
+\alias{checkboxGroupInput}
+\title{Checkbox Group Input Control}
+\usage{
+  checkboxGroupInput(inputId, label, choices,
+    selected = NULL)
+}
+\arguments{
+  \item{inputId}{Input variable to assign the control's
+  value to.}
+
+  \item{label}{Display label for the control.}
+
+  \item{choices}{List of values to show checkboxes for. If
+  elements of the list are named then that name rather than
+  the value is displayed to the user.}
+
+  \item{selected}{Names of items that should be initially
+  selected, if any.}
+}
+\value{
+  A list of HTML elements that can be added to a UI
+  definition.
+}
+\description{
+  Create a group of checkboxes that can be used to toggle
+  multiple choices independently. The server will receive
+  the input as a character vector of the selected values.
+}
+\examples{
+checkboxGroupInput("variable", "Variable:",
+                   c("Cylinders" = "cyl",
+                     "Transmission" = "am",
+                     "Gears" = "gear"))
+}
+\seealso{
+  \code{\link{checkboxInput}}
+}
+

man/checkboxInput.Rd

@@ -1,25 +1,29 @@
 \name{checkboxInput}
 \alias{checkboxInput}
-\title{Create a checkbox input control}
+\title{Checkbox Input Control}
 \usage{
   checkboxInput(inputId, label, value = FALSE)
 }
 \arguments{
   \item{inputId}{Input variable to assign the control's
-  value to}
+  value to.}
 
-  \item{label}{Display label for the control}
+  \item{label}{Display label for the control.}
 
-  \item{value}{Initial value}
+  \item{value}{Initial value (\code{TRUE} or
+  \code{FALSE}).}
 }
 \value{
   A checkbox control that can be added to a UI definition.
 }
 \description{
   Create a checkbox that can be used to specify logical
-  values
+  values.
 }
 \examples{
 checkboxInput("outliers", "Show outliers", FALSE)
 }
+\seealso{
+  \code{\link{checkboxGroupInput}}
+}
 

man/conditionalPanel.Rd

@@ -0,0 +1,54 @@
+\name{conditionalPanel}
+\alias{conditionalPanel}
+\title{Conditional Panel}
+\usage{
+  conditionalPanel(condition, ...)
+}
+\arguments{
+  \item{condition}{A JavaScript expression that will be
+  evaluated repeatedly to determine whether the panel
+  should be displayed.}
+
+  \item{...}{Elements to include in the panel.}
+}
+\description{
+  Creates a panel that is visible or not, depending on the
+  value of a JavaScript expression. The JS expression is
+  evaluated once at startup and whenever Shiny detects a
+  relevant change in input/output.
+}
+\details{
+  In the JS expression, you can refer to \code{input} and
+  \code{output} JavaScript objects that contain the current
+  values of input and output. For example, if you have an
+  input with an id of \code{foo}, then you can use
+  \code{input.foo} to read its value. (Be sure not to
+  modify the input/output objects, as this may cause
+  unpredictable behavior.)
+}
+\examples{
+sidebarPanel(
+   selectInput(
+      "plotType", "Plot Type",
+      c(Scatter = "scatter",
+        Histogram = "hist")),
+
+   # Only show this panel if the plot type is a histogram
+   conditionalPanel(
+      condition = "input.plotType == 'hist'",
+      selectInput(
+         "breaks", "Breaks",
+         c("Sturges",
+           "Scott",
+           "Freedman-Diaconis",
+           "[Custom]" = "custom")),
+
+      # Only show this panel if Custom is selected
+      conditionalPanel(
+         condition = "input.breaks == 'custom'",
+         sliderInput("breakCount", "Break Count", min=1, max=1000, value=10)
+      )
+   )
+)
+}
+

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{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/fileInput.Rd

@@ -0,0 +1,27 @@
+\name{fileInput}
+\alias{fileInput}
+\title{File Upload Control}
+\usage{
+  fileInput(inputId, label, multiple = FALSE,
+    accept = NULL)
+}
+\arguments{
+  \item{inputId}{Input variable to assign the control's
+  value to.}
+
+  \item{label}{Display label for the control.}
+
+  \item{multiple}{Whether the user should be allowed to
+  select and upload multiple files at once.}
+
+  \item{accept}{A character vector of MIME types; gives the
+  browser a hint of what kind of files the server is
+  expecting.}
+}
+\description{
+  Create a file upload control that can be used to upload
+  one or more files. \bold{Experimental feature. Only works
+  in some browsers (primarily tested on Chrome and
+  Firefox).}
+}
+

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/htmlOutput.Rd

@@ -1,8 +1,11 @@
 \name{htmlOutput}
 \alias{htmlOutput}
+\alias{uiOutput}
 \title{Create an HTML output element}
 \usage{
   htmlOutput(outputId)
+
+  uiOutput(outputId)
 }
 \arguments{
   \item{outputId}{output variable to read the value from}
@@ -16,6 +19,11 @@
   HTML \code{div} tag, and is presumed to contain HTML
   content which should not be escaped.
 }
+\details{
+  \code{uiOutput} is intended to be used with
+  \code{reactiveUI} on the server side. It is currently
+  just an alias for \code{htmlOutput}.
+}
 \examples{
 htmlOutput("summary")
 }

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/numericInput.Rd

@@ -2,7 +2,8 @@
 \alias{numericInput}
 \title{Create a numeric input control}
 \usage{
-  numericInput(inputId, label, value, min = NA, max = NA)
+  numericInput(inputId, label, value, min = NA, max = NA,
+    step = NA)
 }
 \arguments{
   \item{inputId}{Input variable to assign the control's
@@ -15,6 +16,9 @@
   \item{min}{Minimum allowed value}
 
   \item{max}{Maximum allowed value}
+
+  \item{step}{Interval to use when stepping between min and
+  max}
 }
 \value{
   A numeric input control that can be added to a UI

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

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/reactiveUI.Rd

@@ -0,0 +1,33 @@
+\name{reactiveUI}
+\alias{reactiveUI}
+\title{UI Output}
+\usage{
+  reactiveUI(func)
+}
+\arguments{
+  \item{func}{A function that returns a Shiny tag object,
+  \code{\link{HTML}}, or a list of such objects.}
+}
+\description{
+  \bold{Experimental feature.} Makes a reactive version of
+  a function that generates HTML using the Shiny UI
+  library.
+}
+\details{
+  The corresponding HTML output tag should be \code{div}
+  and have the CSS class name \code{shiny-html-output} (or
+  use \code{\link{uiOutput}}).
+}
+\examples{
+\dontrun{
+  output$moreControls <- reactiveUI(function() {
+    list(
+
+    )
+  })
+}
+}
+\seealso{
+  conditionalPanel
+}
+

man/repeatable.Rd

@@ -0,0 +1,38 @@
+\name{repeatable}
+\alias{repeatable}
+\title{Make a random number generator repeatable}
+\usage{
+  repeatable(rngfunc,
+    seed = runif(1, 0, .Machine$integer.max))
+}
+\arguments{
+  \item{rngfunc}{The function that is affected by the R
+  session's seed.}
+
+  \item{seed}{The seed to set every time the resulting
+  function is called.}
+}
+\value{
+  A repeatable version of the function that was passed in.
+}
+\description{
+  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.
+}
+\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
+}
+

man/runGist.Rd

@@ -0,0 +1,26 @@
+\name{runGist}
+\alias{runGist}
+\title{Run a Shiny application from https://gist.github.com}
+\usage{
+  runGist(gist, port = 8100L,
+    launch.browser = getOption("shiny.launch.browser", interactive()))
+}
+\arguments{
+  \item{gist}{The identifier of the gist. For example, if
+  the gist is https://gist.github.com/3239667, then
+  \code{3239667}, \code{'3239667'}, and
+  \code{'https://gist.github.com/3239667'} are all valid
+  values.}
+
+  \item{port}{The TCP port that the application should
+  listen on. Defaults to port 8100.}
+
+  \item{launch.browser}{If true, the system's default web
+  browser will be launched automatically after the app is
+  started. Defaults to true in interactive sessions only.}
+}
+\description{
+  Download and launch a Shiny application that is hosted on
+  GitHub as a gist.
+}
+

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

man/singleton.Rd

@@ -0,0 +1,20 @@
+\name{singleton}
+\alias{singleton}
+\title{Include Content Only Once}
+\usage{
+  singleton(x)
+}
+\arguments{
+  \item{x}{A \code{\link{tag}}, text, \code{\link{HTML}},
+  or list.}
+}
+\description{
+  Use \code{singleton} to wrap contents (tag, text, HTML,
+  or lists) that should be included in the generated
+  document only once, yet may appear in the
+  document-generating code more than once. Only the first
+  appearance of the content (in document order) will be
+  used. Useful for custom components that have JavaScript
+  files or stylesheets.
+}
+

man/tabPanel.Rd

@@ -2,19 +2,24 @@
 \alias{tabPanel}
 \title{Create a tab panel}
 \usage{
-  tabPanel(title, ...)
+  tabPanel(title, ..., value = NULL)
 }
 \arguments{
   \item{title}{Display title for tab}
 
   \item{...}{UI elements to include within the tab}
+
+  \item{value}{The value that should be sent when
+  \code{tabsetPanel} reports that this tab is selected. If
+  omitted and \code{tabsetPanel} has an \code{id}, then the
+  title will be used.}
 }
 \value{
-  A tab that can be passed to \link{tabsetPanel}
+  A tab that can be passed to \code{\link{tabsetPanel}}
 }
 \description{
-  Create a tab panel that can be inluded within a
-  \link{tabsetPanel}.
+  Create a tab panel that can be included within a
+  \code{\link{tabsetPanel}}.
 }
 \examples{
 # Show a tabset that includes a plot, summary, and

man/tabsetPanel.Rd

@@ -2,19 +2,25 @@
 \alias{tabsetPanel}
 \title{Create a tabset panel}
 \usage{
-  tabsetPanel(...)
+  tabsetPanel(..., id = NULL)
 }
 \arguments{
-  \item{...}{\link{tabPanel} elements to include in the
-  tabset}
+  \item{...}{\code{\link{tabPanel}} elements to include in
+  the tabset}
+
+  \item{id}{If provided, you can use
+  \code{input$}\emph{\code{id}} in your server logic to
+  determine which of the current tabs is active. The value
+  will correspond to the \code{value} argument that is
+  passed to \code{\link{tabPanel}}.}
 }
 \value{
-  A tabset that can be passed to \link{mainPanel}
+  A tabset that can be passed to \code{\link{mainPanel}}
 }
 \description{
-  Create a tabset that contains \link{tabPanel} elements.
-  Tabsets are useful for dividing output into multiple
-  independently viewable sections.
+  Create a tabset that contains \code{\link{tabPanel}}
+  elements. Tabsets are useful for dividing output into
+  multiple independently viewable sections.
 }
 \examples{
 # Show a tabset that includes a plot, summary, and

man/tag.Rd

@@ -1,15 +1,22 @@
 \name{tag}
 \alias{tag}
 \alias{tagAppendChild}
+\alias{tagList}
 \title{
 HTML Tag Object
 }
 \description{
-Create an HTML tag definition. Note that all of the valid HTML5 tags are already defined in the \link{tags} environment so these functions should only be used to generate additional tags.
+\code{tag} creates an HTML tag definition. Note that all of the valid HTML5 tags
+are already defined in the \link{tags} environment so these functions should
+only be used to generate additional tags. \code{tagAppendChild} and
+\code{tagList} are for supporting package authors who wish to create their own
+sets of tags; see the contents of bootstrap.R for examples.
 
 \code{tag(_tag_name, varArgs)}
 
 \code{tagAppendChild(tag, child)}
+
+\code{tagList(...)}
 }
 
 \arguments{
@@ -18,7 +25,7 @@ Create an HTML tag definition. Note that all of the valid HTML5 tags are already
 }
   \item{varArgs}{
     List of attributes and children of the element. Named list items
-    become attributes, and other items become children. Valid
+    become attributes, and unnamed list items become children. Valid
     children are tags, single-character character vectors (which become
     text nodes), and raw HTML (see \code{\link{HTML}}). You can also
     pass lists that contain tags, text nodes, and HTML.
@@ -28,6 +35,9 @@ Create an HTML tag definition. Note that all of the valid HTML5 tags are already
 }
   \item{child}{
     A child element to append to a parent tag.
+}
+  \item{...}{
+    Unnamed items that comprise this list of tags.
 }
 }
 

man/wellPanel.Rd

@@ -0,0 +1,18 @@
+\name{wellPanel}
+\alias{wellPanel}
+\title{Create a well panel}
+\usage{
+  wellPanel(...)
+}
+\arguments{
+  \item{...}{UI elements to include inside the panel.}
+}
+\value{
+  The newly created panel.
+}
+\description{
+  Creates a panel with a slightly inset border and grey
+  background. Equivalent to Twitter Bootstrap's \code{well}
+  CSS class.
+}
+