Bump version to 0.4.0

Previously when getType() was defined for a type of object, shiny.js would
send updates immediately instead of applying the rate policy.

.Rbuildignore

@@ -0,0 +1,10 @@
+^\.Rproj\.user$
+^\.git$
+^examples$
+^README\.md$
+^shiny\.Rproj$
+^shiny\.sh$
+^shiny\.cmd$
+^run\.R$
+^\.gitignore$
+^res$

.gitignore

@@ -1,4 +1,9 @@
-vendor/ruby
-\.bundle/
-\.DS_Store
+.DS_Store
 .Rproj.user
+.Rhistory
+.Rprofile
+*.o
+*.so
+/src-i386/
+/src-x86_64/
+README.html

DESCRIPTION

@@ -0,0 +1,47 @@
+Package: shiny
+Type: Package
+Title: Web Application Framework for R
+Version: 0.4.0
+Date: 2013-01-23
+Author: RStudio, Inc.
+Maintainer: Winston Chang <winston@rstudio.com>
+Description: Shiny makes it incredibly easy to build interactive web
+    applications with R. Automatic "reactive" binding between inputs and
+    outputs and extensive pre-built widgets make it possible to build
+    beautiful, responsive, and powerful applications with minimal effort.
+License: GPL-3
+Depends:
+    R (>= 2.14.1)
+Imports:
+    stats,
+    tools,
+    utils,
+    datasets,
+    methods,
+    websockets (>= 1.1.6),
+    caTools,
+    RJSONIO,
+    xtable,
+    digest
+Suggests:
+    markdown,
+    Cairo,
+    testthat
+URL: http://www.rstudio.com/shiny/
+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'
+    'slider.R'
+    'bootstrap.R'
+    'run-url.R'

Gemfile

@@ -1,5 +0,0 @@
-source 'https://rubygems.org'
-
-gem 'em-websocket'
-gem 'eventmachine_httpserver'
-gem 'json'

Gemfile.lock

@@ -1,18 +0,0 @@
-GEM
-  remote: https://rubygems.org/
-  specs:
-    addressable (2.2.8)
-    em-websocket (0.3.6)
-      addressable (>= 2.1.1)
-      eventmachine (>= 0.12.9)
-    eventmachine (0.12.10)
-    eventmachine_httpserver (0.2.1)
-    json (1.7.3)
-
-PLATFORMS
-  ruby
-
-DEPENDENCIES
-  em-websocket
-  eventmachine_httpserver
-  json

NAMESPACE

@@ -0,0 +1,108 @@
+S3method("$",reactivevalues)
+S3method("$",shinyoutput)
+S3method("$<-",reactivevalues)
+S3method("$<-",shinyoutput)
+S3method("[",reactivevalues)
+S3method("[",shinyoutput)
+S3method("[<-",reactivevalues)
+S3method("[<-",shinyoutput)
+S3method("[[",reactivevalues)
+S3method("[[",shinyoutput)
+S3method("[[<-",reactivevalues)
+S3method("[[<-",shinyoutput)
+S3method("names<-",reactivevalues)
+S3method(as.character,shiny.tag)
+S3method(as.character,shiny.tag.list)
+S3method(as.list,reactivevalues)
+S3method(format,shiny.tag)
+S3method(format,shiny.tag.list)
+S3method(names,reactivevalues)
+S3method(print,shiny.tag)
+S3method(print,shiny.tag.list)
+export(HTML)
+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(exprToFunction)
+export(fileInput)
+export(h1)
+export(h2)
+export(h3)
+export(h4)
+export(h5)
+export(h6)
+export(headerPanel)
+export(helpText)
+export(htmlOutput)
+export(img)
+export(includeHTML)
+export(includeMarkdown)
+export(includeText)
+export(invalidateLater)
+export(isolate)
+export(mainPanel)
+export(numericInput)
+export(observe)
+export(outputOptions)
+export(p)
+export(pageWithSidebar)
+export(plotOutput)
+export(pre)
+export(radioButtons)
+export(reactive)
+export(reactivePlot)
+export(reactivePrint)
+export(reactiveTable)
+export(reactiveText)
+export(reactiveTimer)
+export(reactiveUI)
+export(reactiveValues)
+export(reactiveValuesToList)
+export(renderPlot)
+export(renderPrint)
+export(renderTable)
+export(renderText)
+export(renderUI)
+export(repeatable)
+export(runApp)
+export(runExample)
+export(runGist)
+export(runGitHub)
+export(runUrl)
+export(selectInput)
+export(shinyServer)
+export(shinyUI)
+export(sidebarPanel)
+export(singleton)
+export(sliderInput)
+export(span)
+export(strong)
+export(submitButton)
+export(tabPanel)
+export(tableOutput)
+export(tabsetPanel)
+export(tag)
+export(tagAppendChild)
+export(tagList)
+export(tags)
+export(textInput)
+export(textOutput)
+export(uiOutput)
+export(verbatimTextOutput)
+export(wellPanel)
+import(RJSONIO)
+import(caTools)
+import(digest)
+import(websockets)
+import(xtable)

NEWS

@@ -0,0 +1,225 @@
+shiny 0.4.0
+--------------------------------------------------------------------------------
+
+* Added suspend/resume capability to observers.
+
+* Output objects are automatically suspended when they are hidden on the user's
+  web browser.
+
+* `runGist()` accepts GitHub's new URL format, which includes the username.
+
+* `reactive()` and `observe()` now take expressions instead of functions.
+
+* `reactiveText()`, `reactivePlot()`, and so on, have been renamed to
+  `renderText()`, `renderPlot()`, etc.  They also now take expressions instead
+  of functions.
+
+* Fixed a bug where empty values in a numericInput were sent to the R process
+  as 0. They are now sent as NA.
+
+shiny 0.3.1
+--------------------------------------------------------------------------------
+
+* Fix issue #91: bug where downloading files did not work.
+
+* Add [[<- operator for shinyoutput object, making it possible to assign values
+  with `output[['plot1']] <- ...`.
+
+* Reactive functions now preserve the visible/invisible state of their returned
+  values.
+
+shiny 0.3.0
+--------------------------------------------------------------------------------
+
+* Reactive functions are now evaluated lazily.
+
+* Add `reactiveValues()`.
+
+* Using `as.list()` to convert a reactivevalues object (like `input`) to a list
+  is deprecated. The new function `reactiveValuesToList()` should be used
+  instead.
+
+* Add `isolate()`. This function is used for accessing reactive functions,
+  without them invalidating their parent contexts.
+
+* Fix issue #58: bug where reactive functions are not re-run when all items in
+  a checkboxGroup are unchecked.
+
+* Fix issue #71, where `reactiveTable()` would return blank if the first
+  element of a data frame was NA.
+
+* In `plotOutput`, better validation for CSS units when specifying width and
+  height.
+
+* `reactivePrint()` no longer displays invisible output.
+
+* `reactiveText()` no longer displays printed output, only the return value
+  from a function.
+
+* The `runGitHub()` and `runUrl()` functions have been added, for running
+  Shiny apps from GitHub repositories and zip/tar files at remote URLs.
+
+* Fix issue #64, where pressing Enter in a textbox would cause a form to
+  submit.
+
+shiny 0.2.4
+--------------------------------------------------------------------------------
+
+* `runGist` has been updated to use the new download URLs from
+  https://gist.github.com.
+
+* Shiny now uses `CairoPNG()` for output, when the Cairo package is available.
+  This provides better-looking output on Linux and Windows.
+
+shiny 0.2.3
+--------------------------------------------------------------------------------
+
+* Ignore request variables for routing purposes
+
+shiny 0.2.2
+--------------------------------------------------------------------------------
+
+* Fix CRAN warning (assigning to global environment)
+
+
+shiny 0.2.1
+--------------------------------------------------------------------------------
+
+* [BREAKING] Modify API of `downloadHandler`: The `content` function now takes
+  a file path, not writable connection, as an argument. This makes it much
+  easier to work with APIs that only write to file paths, not connections.
+
+
+shiny 0.2.0
+--------------------------------------------------------------------------------
+
+* Fix subtle name resolution bug--the usual symptom being S4 methods not being
+  invoked correctly when called from inside of ui.R or server.R
+
+
+shiny 0.1.14
+--------------------------------------------------------------------------------
+
+* Fix slider animator, which broke in 0.1.10
+
+
+shiny 0.1.13
+--------------------------------------------------------------------------------
+
+* Fix temp file leak in reactivePlot
+
+
+shiny 0.1.12
+--------------------------------------------------------------------------------
+
+* Fix problems with runGist on Windows
+* Add feature for on-the-fly file downloads (e.g. CSV data, PDFs)
+* Add CSS hooks for app-wide busy indicators
+
+
+shiny 0.1.11
+--------------------------------------------------------------------------------
+
+* Fix input binding with IE8 on Shiny Server
+* Fix issue #41: reactiveTable should allow print options too
+* Allow dynamic sizing of reactivePlot (i.e. using a function instead of a fixed
+  value)
+
+
+shiny 0.1.10
+--------------------------------------------------------------------------------
+
+* Support more MIME types when serving out of www
+* Fix issue #35: Allow modification of untar args
+* headerPanel can take an explicit window title parameter
+* checkboxInput uses correct attribute `checked` instead of `selected`
+* Fix plot rendering with IE8 on Shiny Server
+
+
+shiny 0.1.9
+--------------------------------------------------------------------------------
+
+* Much less flicker when updating plots
+* More customizable error display
+* Add `includeText`, `includeHTML`, and `includeMarkdown` functions for putting
+  text, HTML, and Markdown content from external files in the application's UI.
+
+
+shiny 0.1.8
+--------------------------------------------------------------------------------
+
+* 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

@@ -0,0 +1,858 @@
+#' 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
+#' 
+#' Create a Shiny UI that contains a header with the application title, a 
+#' sidebar for input controls, and a main area for output.
+#' 
+#' @param headerPanel The \link{headerPanel} with the application title
+#' @param sidebarPanel The \link{sidebarPanel} containing input controls
+#' @param mainPanel The \link{mainPanel} containing outputs
+#' @return A UI defintion that can be passed to the \link{shinyUI} function
+#' 
+#' @examples
+#' # Define UI
+#' shinyUI(pageWithSidebar(
+#'   
+#'   # Application title
+#'   headerPanel("Hello Shiny!"),
+#'   
+#'   # Sidebar with a slider input
+#'   sidebarPanel(
+#'     sliderInput("obs", 
+#'                 "Number of observations:", 
+#'                 min = 0, 
+#'                 max = 1000, 
+#'                 value = 500)
+#'   ),
+#'   
+#'   # Show a plot of the generated distribution
+#'   mainPanel(
+#'     plotOutput("distPlot")
+#'   )
+#' ))
+#'
+#' @export
+pageWithSidebar <- function(headerPanel, sidebarPanel, mainPanel) {
+  
+  bootstrapPage(
+    # basic application container divs
+    div(
+      class="container-fluid", 
+      div(class="row-fluid", 
+          headerPanel
+      ),
+      div(class="row-fluid", 
+          sidebarPanel, 
+          mainPanel
+      )
+    )
+  )
+}
+
+
+#' Create a header panel
+#' 
+#' 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, 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 
+#' passed to \link{pageWithSidebar}.
+#' 
+#' @param ... UI elements to include on the sidebar
+#' @return A sidebar that can be passed to \link{pageWithSidebar}
+#' 
+#' @examples
+#' # Sidebar with controls to select a dataset and specify
+#' # the number of observations to view
+#' sidebarPanel(
+#'   selectInput("dataset", "Choose a dataset:", 
+#'               choices = c("rock", "pressure", "cars")),
+#'   
+#'   numericInput("obs", "Observations:", 10)
+#' )
+#' @export
+sidebarPanel <- function(...) {
+  div(class="span4",
+    tags$form(class="well", 
+      ...
+    )
+  )
+}
+
+#' Create a main panel
+#' 
+#' Create a main panel containing output elements that can in turn be 
+#' passed to \link{pageWithSidebar}.
+#' 
+#' @param ... Ouput elements to include in the main panel
+#' @return A main panel that can be passed to \link{pageWithSidebar}
+#' 
+#' @examples
+#' # Show the caption and plot of the requested variable against mpg
+#' mainPanel(
+#'    h3(textOutput("caption")),
+#'    plotOutput("mpgPlot")
+#' )
+#' @export
+mainPanel <- function(...) {
+  div(class="span8",
+    ...
+  )
+}
+
+#' 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
+#' 
+#' @param inputId Input variable to assign the control's value to
+#' @param label Display label for the control
+#' @param value Initial value
+#' @return A text input control that can be added to a UI definition.
+#' 
+#' @examples
+#' textInput("caption", "Caption:", "Data Summary")
+#' @export
+textInput <- function(inputId, label, value = "") {
+  tagList(
+    tags$label(label),
+    tags$input(id = inputId, type="text", value=value)
+  )
+}
+
+#' Create a numeric input control
+#' 
+#' Create an input control for entry of numeric values
+#' 
+#' @param inputId Input variable to assign the control's value to
+#' @param label Display label for the control
+#' @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, step = NA) {
+  
+  # build input tag
+  inputTag <- tags$input(id = inputId, type = "number", value = value)
+  if (!is.na(min))
+    inputTag$attribs$min = min
+  if (!is.na(max))
+    inputTag$attribs$max = max
+  if (!is.na(step))
+    inputTag$attribs$step = step
+  
+  tagList(
+    tags$label(label),
+    inputTag
+  )
+}
+
+
+#' File Upload Control
+#' 
+#' 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 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 (!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.
+#' 
+#' @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(...) {
+  span(class="help-block", ...)
+}
+
+controlLabel <- function(controlName, label) {
+  tags$label(class = "control-label", `for` = controlName, label)
+}
+
+choicesWithNames <- function(choices) {
+  # get choice names
+  choiceNames <- names(choices)
+  if (is.null(choiceNames))
+    choiceNames <- character(length(choices))
+  
+  # default missing names to choice values
+  missingNames <- choiceNames == ""
+  choiceNames[missingNames] <- paste(choices)[missingNames]
+  names(choices) <- choiceNames
+  
+  # return choices
+  return (choices)
+}
+
+#' Create a select list input control
+#' 
+#' Create a select list that can be used to choose a single or
+#' multiple items from a list of 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 select from. If elements of the list are 
+#' named then that name rather than the value is displayed to the user.
+#' @param selected Name of initially selected item (or multiple names if
+#' \code{multiple = TRUE}). If not specified then defaults to the first item
+#' for single-select lists and no items for multiple select lists.
+#' @param multiple Is selection of multiple items allowed?
+#' @return A select list control that can be added to a UI definition.
+#' 
+#' @examples
+#' selectInput("variable", "Variable:",
+#'             c("Cylinders" = "cyl",
+#'               "Transmission" = "am",
+#'               "Gears" = "gear"))
+#' @export
+selectInput <- function(inputId, 
+                        label, 
+                        choices, 
+                        selected = NULL, 
+                        multiple = FALSE) {
+  # resolve names
+  choices <- choicesWithNames(choices)
+  
+  # default value if it's not specified
+  if (is.null(selected) && !multiple)
+    selected <- names(choices)[[1]]
+  
+  # create select tag and add options
+  selectTag <- tags$select(id = inputId)
+  if (multiple)
+    selectTag$attribs$multiple <- "multiple"
+  for (choiceName in names(choices)) {
+    optionTag <- tags$option(value = choices[[choiceName]], choiceName)
+    if (choiceName %in% selected)
+      optionTag$attribs$selected = "selected"
+    selectTag <- tagAppendChild(selectTag, optionTag)
+  } 
+  
+  # return label and select tag
+  tagList(controlLabel(inputId, label), selectTag)
+}
+
+#' Create radio buttons
+#' 
+#' Create a set of radio buttons used to select an item from a list.
+#' 
+#' @param inputId Input variable to assign the control's value to
+#' @param label Display label for the control
+#' @param choices List of values to select from (if elements of the list are 
+#' named then that name rather than the value is displayed to the user)
+#' @param selected Name of initially selected item (if not specified then
+#' defaults to the first item)
+#' @return A set of radio buttons that can be added to a UI definition.
+#' 
+#' @examples
+#' radioButtons("dist", "Distribution type:",
+#'              c("Normal" = "norm",
+#'                "Uniform" = "unif",
+#'                "Log-normal" = "lnorm",
+#'                "Exponential" = "exp"))
+#' @export
+radioButtons <- function(inputId, label, choices, selected = NULL) {
+  # resolve names
+  choices <- choicesWithNames(choices)
+  
+  # default value if it's not specified
+  if (is.null(selected))
+    selected <- names(choices)[[1]]
+  
+  # build list of radio button tags
+  inputTags <- list()
+  for (i in 1:length(choices)) {
+    id <- paste(inputId, i, sep="")
+    name <- names(choices)[[i]]
+    value <- choices[[i]]
+    inputTag <- tags$input(type = "radio", 
+                           name = inputId,
+                           id = id,
+                           value = value)
+    if (identical(name, selected))
+      inputTag$attribs$checked = "checked"
+    
+    labelTag <- tags$label(class = "radio")
+    labelTag <- tagAppendChild(labelTag, inputTag)
+    labelTag <- tagAppendChild(labelTag, name)
+    inputTags[[length(inputTags) + 1]] <- labelTag
+  }
+  
+  tagList(tags$label(class = "control-label", label),
+          inputTags)
+}
+
+#' Create a submit button
+#' 
+#' Create a submit button for an input form. Forms that include a submit
+#' button do not automatically update their outputs when inputs change,
+#' rather they wait until the user explicitly clicks the submit button.
+#' 
+#' @param text Button caption
+#' @return A submit button that can be added to a UI definition.
+#' 
+#' @examples
+#' submitButton("Update View")
+#' @export
+submitButton <- function(text = "Apply Changes") {
+  div(
+    tags$button(type="submit", class="btn btn-primary", text)
+  )
+}
+
+#' Slider Input Widget
+#' 
+#' Constructs a slider widget to select a numeric value from a range.
+#' 
+#' @param inputId Specifies the \code{input} slot that will be used to access 
+#'   the value.
+#' @param label A descriptive label to be displayed with the widget.
+#' @param min The minimum value (inclusive) that can be selected.
+#' @param max The maximum value (inclusive) that can be selected.
+#' @param value The initial value of the slider. A warning will be issued if the
+#'   value doesn't fit between \code{min} and \code{max}.
+#' @param step Specifies the interval between each selectable value on the 
+#'   slider (\code{NULL} means no restriction).
+#' @param round \code{TRUE} to round all values to the nearest integer; 
+#'   \code{FALSE} if no rounding is desired; or an integer to round to that 
+#'   number of digits (for example, 1 will round to the nearest 10, and -2 will 
+#'   round to the nearest .01). Any rounding will be applied after snapping to 
+#'   the nearest step.
+#' @param format Customize format values in slider labels. See 
+#'   \url{http://archive.plugins.jquery.com/project/numberformatter} for syntax 
+#'   details.
+#' @param locale The locale to be used when applying \code{format}. See details.
+#' @param ticks \code{FALSE} to hide tick marks, \code{TRUE} to show them 
+#'   according to some simple heuristics.
+#' @param animate \code{TRUE} to show simple animation controls with default 
+#'   settings; \code{FALSE} not to; or a custom settings list, such as those 
+#'   created using \code{\link{animationOptions}}.
+#'   
+#' @details
+#' 
+#' Valid values for \code{locale} are: \tabular{ll}{ Arab Emirates \tab "ae" \cr
+#' Australia \tab "au" \cr Austria \tab "at" \cr Brazil \tab "br" \cr Canada 
+#' \tab "ca" \cr China \tab "cn" \cr Czech \tab "cz" \cr Denmark \tab "dk" \cr 
+#' Egypt \tab "eg" \cr Finland \tab "fi" \cr France  \tab "fr" \cr Germany \tab 
+#' "de" \cr Greece \tab "gr" \cr Great Britain \tab "gb" \cr Hong Kong \tab "hk"
+#' \cr India \tab "in" \cr Israel \tab "il" \cr Japan \tab "jp" \cr Russia \tab 
+#' "ru" \cr South Korea \tab "kr" \cr Spain \tab "es" \cr Sweden \tab "se" \cr 
+#' Switzerland \tab "ch" \cr Taiwan \tab "tw" \cr Thailand \tab "th" \cr United 
+#' States \tab "us" \cr Vietnam \tab "vn" \cr }
+#' 
+#' @export
+sliderInput <- function(inputId, label, min, max, value, step = NULL,
+                        round=FALSE, format='#,##0.#####', locale='us',
+                        ticks=TRUE, animate=FALSE) {
+ 
+  # validate label
+  labelText <- as.character(label)
+  if (!is.character(labelText))
+    stop("label not specified")
+  
+  if (identical(animate, TRUE))
+    animate <- animationOptions()
+  
+  if (!is.null(animate) && !identical(animate, FALSE)) {
+    if (is.null(animate$playButton))
+      animate$playButton <- tags$i(class='icon-play')
+    if (is.null(animate$pauseButton))
+      animate$pauseButton <- tags$i(class='icon-pause')
+  }
+  
+  # build slider
+  tagList(
+    controlLabel(inputId, labelText),  
+    slider(inputId, min=min, max=max, value=value, step=step, round=round,
+           locale=locale, format=format, ticks=ticks,
+           animate=animate)
+  )
+}
+
+
+#' Create a tab panel
+#' 
+#' 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
+#' @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
+#' mainPanel(
+#'   tabsetPanel(
+#'     tabPanel("Plot", plotOutput("plot")), 
+#'     tabPanel("Summary", verbatimTextOutput("summary")), 
+#'     tabPanel("Table", tableOutput("table"))
+#'   )
+#' )
+#' @export
+tabPanel <- function(title, ..., value = NULL) {
+  div(class="tab-pane", title=title, `data-value`=value, ...)
+}
+
+#' Create a tabset panel
+#' 
+#' 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
+#' mainPanel(
+#'   tabsetPanel(
+#'     tabPanel("Plot", plotOutput("plot")), 
+#'     tabPanel("Summary", verbatimTextOutput("summary")), 
+#'     tabPanel("Table", tableOutput("table"))
+#'   )
+#' )
+#' @export
+tabsetPanel <- function(..., id = NULL) {
+  
+  # build tab-nav and tab-content divs
+  tabs <- list(...)
+  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
+    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("#", thisId, sep=""),
+                            `data-toggle` = "tab", 
+                            `data-value` = tabValue,
+                            divTag$attribs$title))
+    
+    # set the first tab as active
+    if (firstTab) {
+      liTag$attribs$class <- "active"
+      divTag$attribs$class <- "tab-pane active"
+      firstTab = FALSE
+    }
+    
+    # append the elements to our lists
+    tabNavList <- tagAppendChild(tabNavList, liTag)
+    tabContent <- tagAppendChild(tabContent, divTag)
+  }
+  
+  tabDiv <- tags$div(class = "tabbable", tabNavList, tabContent)
+}
+
+
+#' Create a text output element
+#' 
+#' Render a reactive output variable as text within an application page. The 
+#' text will be included within an HTML \code{div} tag. 
+#' @param outputId output variable to read the value from
+#' @return A text output element that can be included in a panel
+#' @details Text is HTML-escaped prior to rendering. This element is often used 
+#' to display \link{renderText} output variables.
+#' @examples
+#' h3(textOutput("caption"))
+#' @export
+textOutput <- function(outputId) {
+  div(id = outputId, class = "shiny-text-output")
+}
+
+#' Create a verbatim text output element
+#' 
+#' Render a reactive output variable as verbatim text within an
+#' application page. The text will be included within an HTML \code{pre} tag.
+#' @param outputId output variable to read the value from
+#' @return A verbatim text output element that can be included in a panel
+#' @details Text is HTML-escaped prior to rendering. This element is often used
+#' with the \link{renderPrint} function to preserve fixed-width formatting
+#' of printed objects.
+#' @examples
+#' mainPanel(
+#'   h4("Summary"),
+#'   verbatimTextOutput("summary"),
+#'  
+#'   h4("Observations"),
+#'   tableOutput("view")
+#' )
+#' @export
+verbatimTextOutput <- function(outputId) {
+  pre(id = outputId, class =  "shiny-text-output")
+}
+
+#' Create a plot output element
+#' 
+#' Render a \link{renderPlot} within an application page.
+#' @param outputId output variable to read the plot from
+#' @param width Plot width. Must be a valid CSS unit (like \code{"100\%"},
+#'   \code{"400px"}, \code{"auto"}) or a number, which will be coerced to a
+#'   string and have \code{"px"} appended.
+#' @param height Plot height
+#' @return A plot output element that can be included in a panel
+#' @examples
+#' # Show a plot of the generated distribution
+#' mainPanel(
+#'   plotOutput("distPlot")
+#' )
+#' @export
+plotOutput <- function(outputId, width = "100%", height="400px") {
+  style <- paste("width:", validateCssUnit(width), ";",
+    "height:", validateCssUnit(height))
+  div(id = outputId, class="shiny-plot-output", style = style)
+}
+
+#' Create a table output element
+#' 
+#' Render a \link{renderTable} within an application page.
+#' @param outputId output variable to read the table from
+#' @return A table output element that can be included in a panel
+#' @examples
+#' mainPanel(
+#'   tableOutput("view")
+#' )
+#' @export
+tableOutput <- function(outputId) {
+  div(id = outputId, class="shiny-html-output")
+}
+
+#' Create an HTML output element
+#' 
+#' 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{renderUI} 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
+#' htmlOutput("summary")
+#' @export
+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)
+}
+
+validateCssUnit <- function(x) {
+  if (is.character(x) &&
+     !grepl("^(auto|((\\.\\d+)|(\\d+(\\.\\d+)?))(%|in|cm|mm|em|ex|pt|pc|px))$", x)) {
+    stop('"', x, '" is not a valid CSS unit (e.g., "100%", "400px", "auto")')
+  }
+  if (is.numeric(x)) {
+    x <- paste(x, "px", sep = "")
+  }
+  x
+}

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

@@ -0,0 +1,71 @@
+# TESTS
+# Simple set/get
+# Simple remove
+# Simple containsKey
+# Simple keys
+# Simple values
+# Simple clear
+# Get of unknown key returns NULL
+# Remove of unknown key does nothing
+# Setting a key twice always results in last-one-wins
+# /TESTS
+Map <- setRefClass(
+  'Map',
+  fields = list(
+    .env = 'environment'
+  ),
+  methods = list(
+    initialize = function() {
+      .env <<- new.env(parent=emptyenv())
+    },
+    get = function(key) {
+      if (.self$containsKey(key))
+        return(base::get(key, pos=.env, inherits=FALSE))
+      else
+        return(NULL)
+    },
+    set = function(key, value) {
+      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=FALSE)
+        return(result)
+      }
+      return(NULL)
+    },
+    containsKey = function(key) {
+      exists(key, where=.env, inherits=FALSE)
+    },
+    keys = function() {
+      ls(envir=.env, all.names=TRUE)
+    },
+    values = function() {
+      mget(.self$keys(), envir=.env, inherits=FALSE)
+    },
+    clear = function() {
+      .env <<- new.env(parent=emptyenv())
+      invisible(NULL)
+    },
+    size = function() {
+      length(.env)
+    }
+  )
+)
+
+as.list.Map <- function(map) {
+  sapply(map$keys(),
+         map$get,
+         simplify=FALSE)
+}
+length.Map <- function(map) {
+  map$size()
+}

R/react.R

@@ -1,106 +1,66 @@
-# TESTS
-# Simple set/get
-# Simple remove
-# Simple contains.key
-# Simple keys
-# Simple values
-# Simple clear
-# Get of unknown key returns NULL
-# Remove of unknown key does nothing
-# Setting a key twice always results in last-one-wins
-# /TESTS
-Map <- setRefClass(
-  'Map',
-  fields = list(
-    .env = 'environment'
-  ),
-  methods = list(
-    initialize = function() {
-      .env <<- new.env(parent=emptyenv())
-    },
-    get = function(key) {
-      if (.self$contains.key(key))
-        return(base::get(key, pos=.env, inherits=F))
-      else
-        return(NULL)
-    },
-    set = function(key, value) {
-      assign(key, value, pos=.env, inherits=F)
-      return(value)
-    },
-    remove = function(key) {
-      if (.self$contains.key(key)) {
-        result <- .self$get(key)
-        rm(list = key, pos=.env, inherits=F)
-        return(result)
-      }
-      return(NULL)
-    },
-    contains.key = function(key) {
-      exists(key, where=.env, inherits=F)
-    },
-    keys = function() {
-      ls(envir=.env, all.names=T)
-    },
-    values = function() {
-      mget(.self$keys(), envir=.env, inherits=F)
-    },
-    clear = function() {
-      .env <<- new.env(parent=emptyenv())
-      invisible(NULL)
-    },
-    size = function() {
-      length(.env)
-    }
-  )
-)
-
-as.list.Map <- function(map) {
-  sapply(map$keys(),
-         map$get,
-         simplify=F)
-}
-length.Map <- function(map) {
-  map$size()
-}
-
 Context <- setRefClass(
   'Context',
   fields = list(
     id = 'character',
+    .label = 'character',      # For debug purposes
     .invalidated = 'logical',
-    .callbacks = 'list'
+    .invalidateCallbacks = 'list',
+    .flushCallbacks = 'list'
   ),
   methods = list(
-    initialize = function() {
-      id <<- .get.reactive.environment()$next.id()
-      .invalidated <<- F
-      .callbacks <<- list()
+    initialize = function(label='') {
+      id <<- .getReactiveEnvironment()$nextId()
+      .invalidated <<- FALSE
+      .invalidateCallbacks <<- list()
+      .flushCallbacks <<- list()
+      .label <<- label
     },
     run = function(func) {
-      env <- .get.reactive.environment()
-      old.ctx <- env$current.context(warn=F)
-      env$set.current.context(.self)
-      on.exit(env$set.current.context(old.ctx))
-      func()
+      "Run the provided function under this context."
+      env <- .getReactiveEnvironment()
+      env$runWith(.self, func)
     },
     invalidate = function() {
+      "Invalidate this context. It will immediately call the callbacks
+        that have been registered with onInvalidate()."
       if (.invalidated)
         return()
-      .invalidated <<- T
-      .get.reactive.environment()$add.pending.invalidate(.self)
+      .invalidated <<- TRUE
+
+      lapply(.invalidateCallbacks, function(func) {
+        func()
+      })
       NULL
     },
-    on.invalidate = function(func) {
+    onInvalidate = function(func) {
+      "Register a function to be called when this context is invalidated.
+        If this context is already invalidated, the function is called
+        immediately."
       if (.invalidated)
         func()
       else
-        .callbacks <<- c(.callbacks, func)
+        .invalidateCallbacks <<- c(.invalidateCallbacks, func)
       NULL
     },
-    execute.callbacks = function() {
-      lapply(.callbacks, function(func) {
-        func()
+    addPendingFlush = function() {
+      "Tell the reactive environment that this context should be flushed the
+        next time flushReact() called."
+      .getReactiveEnvironment()$addPendingFlush(.self)
+    },
+    onFlush = function(func) {
+      "Register a function to be called when this context is flushed."
+      .flushCallbacks <<- c(.flushCallbacks, func)
+    },
+    executeFlushCallbacks = function() {
+      "For internal use only."
+      lapply(.flushCallbacks, function(func) {
+        withCallingHandlers({
+          func()
+        }, warning = function(e) {
+          # TODO: Callbacks in app
+        }, error = function(e) {
+          # TODO: Callbacks in app
+        })
       })
     }
   )
@@ -108,196 +68,66 @@ Context <- setRefClass(
 
 ReactiveEnvironment <- setRefClass(
   'ReactiveEnvironment',
-  fields = c('.current.context', '.next.id', '.pending.invalidate'),
+  fields = list(
+    .currentContext = 'ANY',
+    .nextId = 'integer',
+    .pendingFlush = 'list',
+    .inFlush = 'logical'
+  ),
   methods = list(
     initialize = function() {
-      .current.context <<- NULL
-      .next.id <<- 0L
-      .pending.invalidate <<- list()
+      .currentContext <<- NULL
+      .nextId <<- 0L
+      .pendingFlush <<- list()
+      .inFlush <<- FALSE
     },
-    next.id = function() {
-      .next.id <<- .next.id + 1L
-      return(as.character(.next.id))
+    nextId = function() {
+      .nextId <<- .nextId + 1L
+      return(as.character(.nextId))
     },
-    current.context = function(warn=T) {
-      if (warn && is.null(.current.context))
-        warning('No reactive context is active')
-      return(.current.context)
+    currentContext = function() {
+      if (is.null(.currentContext))
+        stop('Operation not allowed without an active reactive context. ',
+             '(You tried to do something that can only be done from inside a ',
+             'reactive function.)')
+      return(.currentContext)
     },
-    set.current.context = function(ctx) {
-      .current.context <<- ctx
+    runWith = function(ctx, func) {
+      old.ctx <- .currentContext
+      .currentContext <<- ctx
+      on.exit(.currentContext <<- old.ctx)
+      func()
     },
-    add.pending.invalidate = function(ctx) {
-      .pending.invalidate <<- c(.pending.invalidate, ctx)
+    addPendingFlush = function(ctx) {
+      .pendingFlush <<- c(ctx, .pendingFlush)
     },
     flush = function() {
-      while (length(.pending.invalidate) > 0) {
-        contexts <- .pending.invalidate
-        .pending.invalidate <<- list()
-        lapply(contexts, function(ctx) {
-          ctx$execute.callbacks()
-          NULL
-        })
+      # If already in a flush, don't start another one
+      if (.inFlush) return()
+      .inFlush <<- TRUE
+      on.exit(.inFlush <<- FALSE)
+
+      while (length(.pendingFlush) > 0) {
+        ctx <- .pendingFlush[[1]]
+        .pendingFlush <<- .pendingFlush[-1]
+        ctx$executeFlushCallbacks()
       }
     }
   )
 )
 
-Values <- setRefClass(
-  'Values',
-  fields = list(
-    .values = 'environment',
-    .dependencies = 'environment'
-  ),
-  methods = list(
-    initialize = function() {
-      .values <<- new.env(parent=emptyenv())
-      .dependencies <<- new.env(parent=emptyenv())
-    },
-    get = function(key) {
-      ctx <- .get.reactive.environment()$current.context()
-      dep.key <- paste(key, ':', ctx$id, sep='')
-      if (!exists(dep.key, where=.dependencies, inherits=F)) {
-        assign(dep.key, ctx, pos=.dependencies, inherits=F)
-        ctx$on.invalidate(function() {
-          rm(list=dep.key, pos=.dependencies, inherits=F)
-        })
-      }
-      
-      if (!exists(key, where=.values, inherits=F))
-        NULL
-      else
-        base::get(key, pos=.values, inherits=F)
-    },
-    set = function(key, value) {
-      if (exists(key, where=.values, inherits=F)) {
-        if (identical(base::get(key, pos=.values, inherits=F), value)) {
-          return(invisible())
-        }
-      }
-      
-      assign(key, value, pos=.values, inherits=F)
-      dep.keys <- objects(
-        pos=.dependencies,
-        pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep='')
-      )
-      lapply(
-        mget(dep.keys, envir=.dependencies),
-        function(ctx) {
-          ctx$invalidate()
-          NULL
-        }
-      )
-      invisible()
-    },
-    mset = function(lst) {
-      lapply(names(lst),
-             function(name) {
-               .self$set(name, lst[[name]])
-             })
-    }
-  )
-)
-
-Observable <- setRefClass(
-  'Observable',
-  fields = c(
-    '.func',         # function
-    '.dependencies', # Map
-    '.initialized',  # logical
-    '.value'         # any
-  ),
-  methods = list(
-    initialize = function(func) {
-      .func <<- func
-      .dependencies <<- Map$new()
-      .initialized <<- F
-    },
-    get.value = function() {
-      if (!.initialized) {
-        .initialized <<- T
-        .self$.update.value()
-      }
-      
-      ctx <- .get.reactive.environment()$current.context()
-      if (!.dependencies$contains.key(ctx$id)) {
-        .dependencies$set(ctx$id, ctx)
-        ctx$on.invalidate(function() {
-          .dependencies$remove(ctx$id)
-        })
-      }
-      return(.value)
-    },
-    .update.value = function() {
-      old.value <- .value
-      
-      ctx <- Context$new()
-      ctx$on.invalidate(function() {
-        .self$.update.value()
-      })
-      ctx$run(function() {
-        .value <<- .func()
-      })
-      if (!identical(old.value, .value)) {
-        lapply(
-          .dependencies$values(),
-          function(dep.ctx) {
-            dep.ctx$invalidate()
-            NULL
-          }
-        )
-      }
-    }
-  )
-)
-
-Observer <- setRefClass(
-  'Observer',
-  fields = list(
-    .func = 'function'
-  ),
-  methods = list(
-    initialize = function(func) {
-      .func <<- func
-      .self$run()
-    },
-    run = function() {
-      ctx <- Context$new()
-      ctx$on.invalidate(function() {
-        run()
-      })
-      ctx$run(.func)
-    }
-  )
-)
-
-.get.reactive.environment <- function() {
-  if (!exists('.ReactiveEnvironment', envir=.GlobalEnv, inherits=F)) {
-    assign('.ReactiveEnvironment', ReactiveEnvironment$new(), envir=.GlobalEnv)
-  }
-  get('.ReactiveEnvironment', envir=.GlobalEnv, inherits=F)
+.reactiveEnvironment <- ReactiveEnvironment$new()
+.getReactiveEnvironment <- function() {
+  .reactiveEnvironment
 }
 
-flush.react <- function() {
-  .get.reactive.environment()$flush()
+# Causes any pending invalidations to run.
+flushReact <- function() {
+  .getReactiveEnvironment()$flush()
 }
 
-test <- function () {
-  values <- Values$new()
-  obs <- Observer$new(function() {print(values$get('foo'))})
-  flush.react()
-  values$set('foo', 'bar')
-  flush.react()
-  
-  values$set('a', 100)
-  values$set('b', 250)
-  observable <- Observable$new(function() {
-    values$get('a') + values$get('b')
-  })
-  obs2 <- Observer$new(function() {print(paste0('a+b: ', observable$get.value()))})
-  flush.react()
-  values$set('b', 300)
-  flush.react()
-  values$mset(list(a = 10, b = 20))
-  flush.react()
+# Retrieves the current reactive context, or errors if there is no reactive
+# context active at the moment.
+getCurrentContext <- function() {
+  .getReactiveEnvironment()$currentContext()
 }

R/reactives.R

@@ -0,0 +1,659 @@
+Dependents <- setRefClass(
+  'Dependents',
+  fields = list(
+    .dependents = 'Map'
+  ),
+  methods = list(
+    register = function() {
+      ctx <- .getReactiveEnvironment()$currentContext()
+      if (!.dependents$containsKey(ctx$id)) {
+        .dependents$set(ctx$id, ctx)
+        ctx$onInvalidate(function() {
+          .dependents$remove(ctx$id)
+        })
+      }
+    },
+    invalidate = function() {
+      lapply(
+        .dependents$values(),
+        function(ctx) {
+          ctx$invalidate()
+          NULL
+        }
+      )
+    }
+  )
+)
+
+
+# ReactiveValues ------------------------------------------------------------
+
+ReactiveValues <- setRefClass(
+  'ReactiveValues',
+  fields = list(
+    .values = 'environment',
+    .dependents = 'environment',
+    # Dependents for the list of all names, including hidden
+    .namesDeps = 'Dependents',
+    # Dependents for all values, including hidden
+    .allValuesDeps = 'Dependents',
+    # Dependents for all values
+    .valuesDeps = 'Dependents'
+  ),
+  methods = list(
+    initialize = function() {
+      .values <<- new.env(parent=emptyenv())
+      .dependents <<- new.env(parent=emptyenv())
+    },
+    get = function(key) {
+      ctx <- .getReactiveEnvironment()$currentContext()
+      dep.key <- paste(key, ':', ctx$id, sep='')
+      if (!exists(dep.key, where=.dependents, inherits=FALSE)) {
+        assign(dep.key, ctx, pos=.dependents, inherits=FALSE)
+        ctx$onInvalidate(function() {
+          rm(list=dep.key, pos=.dependents, inherits=FALSE)
+        })
+      }
+      
+      if (!exists(key, where=.values, inherits=FALSE))
+        NULL
+      else
+        base::get(key, pos=.values, inherits=FALSE)
+    },
+    set = function(key, value) {
+      hidden <- substr(key, 1, 1) == "."
+
+      if (exists(key, where=.values, inherits=FALSE)) {
+        if (identical(base::get(key, pos=.values, inherits=FALSE), value)) {
+          return(invisible())
+        }
+      }
+      else {
+        .namesDeps$invalidate()
+      }
+
+      if (hidden)
+        .allValuesDeps$invalidate()
+      else
+        .valuesDeps$invalidate()
+      
+      assign(key, value, pos=.values, inherits=FALSE)
+      dep.keys <- objects(
+        pos=.dependents,
+        pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''),
+        all.names=TRUE
+      )
+      lapply(
+        mget(dep.keys, envir=.dependents),
+        function(ctx) {
+          ctx$invalidate()
+          NULL
+        }
+      )
+      invisible()
+    },
+    mset = function(lst) {
+      lapply(base::names(lst),
+             function(name) {
+               .self$set(name, lst[[name]])
+             })
+    },
+    names = function() {
+      .namesDeps$register()
+      return(ls(.values, all.names=TRUE))
+    },
+    toList = function(all.names=FALSE) {
+      if (all.names)
+        .allValuesDeps$register()
+
+      .valuesDeps$register()
+
+      return(as.list(.values, all.names=all.names))
+    }
+  )
+)
+
+
+# reactivevalues ------------------------------------------------------------
+# S3 wrapper class for ReactiveValues reference class
+
+#' Create an object for storing reactive values
+#'
+#' This function returns an object for storing reactive values. It is similar
+#' to a list, but with special capabilities for reactive programming. When you
+#' read a value from it, the calling reactive expression takes a reactive
+#' dependency on that value, and when you write to it, it notifies any reactive
+#' functions that depend on that value.
+#'
+#' @examples
+#' # Create the object with no values
+#' values <- reactiveValues()
+#'
+#' # Assign values to 'a' and 'b'
+#' values$a <- 3
+#' values[['b']] <- 4
+#'
+#' \dontrun{
+#' # From within a reactive context, you can access values with:
+#' values$a
+#' values[['a']]
+#' }
+#'
+#' # If not in a reactive context (e.g., at the console), you can use isolate()
+#' # to retrieve the value:
+#' isolate(values$a)
+#' isolate(values[['a']])
+#'
+#' # Set values upon creation
+#' values <- reactiveValues(a = 1, b = 2)
+#' isolate(values$a)
+#'
+#' @param ... Objects that will be added to the reactivevalues object. All of
+#'   these objects must be named.
+#'
+#' @seealso \code{\link{isolate}}.
+#'
+#' @export
+reactiveValues <- function(...) {
+  args <- list(...)
+  if ((length(args) > 0) && (is.null(names(args)) || any(names(args) == "")))
+    stop("All arguments passed to reactiveValues() must be named.")
+
+  values <- .createReactiveValues(ReactiveValues$new())
+
+  # Use .subset2() instead of [[, to avoid method dispatch
+  .subset2(values, 'impl')$mset(args)
+  values
+}
+
+# Create a reactivevalues object
+#
+# @param values A ReactiveValues object
+# @param readonly Should this object be read-only?
+.createReactiveValues <- function(values = NULL, readonly = FALSE) {
+  structure(list(impl=values), class='reactivevalues', readonly=readonly)
+}
+
+#' @S3method $ reactivevalues
+`$.reactivevalues` <- function(x, name) {
+  .subset2(x, 'impl')$get(name)
+}
+
+#' @S3method [[ reactivevalues
+`[[.reactivevalues` <- `$.reactivevalues`
+
+#' @S3method $<- reactivevalues
+`$<-.reactivevalues` <- function(x, name, value) {
+  if (attr(x, 'readonly')) {
+    stop("Attempted to assign value to a read-only reactivevalues object")
+  } else if (length(name) != 1 || !is.character(name)) {
+    stop("Must use single string to index into reactivevalues")
+  } else {
+    .subset2(x, 'impl')$set(name, value)
+    x
+  }
+}
+
+#' @S3method [[<- reactivevalues
+`[[<-.reactivevalues` <- `$<-.reactivevalues`
+
+#' @S3method [ reactivevalues
+`[.reactivevalues` <- function(values, name) {
+  stop("Single-bracket indexing of reactivevalues object is not allowed.")
+}
+
+#' @S3method [<- reactivevalues
+`[<-.reactivevalues` <- function(values, name, value) {
+  stop("Single-bracket indexing of reactivevalues object is not allowed.")
+}
+
+#' @S3method names reactivevalues
+names.reactivevalues <- function(x) {
+  .subset2(x, 'impl')$names()
+}
+
+#' @S3method names<- reactivevalues
+`names<-.reactivevalues` <- function(x, value) {
+  stop("Can't assign names to reactivevalues object")
+}
+
+#' @S3method as.list reactivevalues
+as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
+  shinyDeprecated("reactiveValuesToList",
+    msg = paste("'as.list.reactivevalues' is deprecated. ",
+      "Use reactiveValuesToList instead.",
+      "\nPlease see ?reactiveValuesToList for more information.",
+      sep = ""))
+
+  reactiveValuesToList(x, all.names)
+}
+
+#' Convert a reactivevalues object to a list
+#'
+#' This function does something similar to what you might \code{\link{as.list}}
+#' to do. The difference is that the calling context will take dependencies on
+#' every object in the reactivevalues object. To avoid taking dependencies on
+#' all the objects, you can wrap the call with \code{\link{isolate}()}.
+#'
+#' @param x A reactivevalues object.
+#' @param all.names If \code{TRUE}, include objects with a leading dot. If
+#'   \code{FALSE} (the default) don't include those objects.
+#' @examples
+#' values <- reactiveValues(a = 1)
+#' \dontrun{
+#' reactiveValuesToList(values)
+#' }
+#'
+#' # To get the objects without taking dependencies on them, use isolate().
+#' # isolate() can also be used when calling from outside a reactive context (e.g.
+#' # at the console)
+#' isolate(reactiveValuesToList(values))
+#'
+#' @export
+reactiveValuesToList <- function(x, all.names=FALSE) {
+  .subset2(x, 'impl')$toList(all.names)
+}
+
+# Observable ----------------------------------------------------------------
+
+Observable <- setRefClass(
+  'Observable',
+  fields = list(
+    .func = 'function',
+    .label = 'character',
+    .dependents = 'Dependents',
+    .invalidated = 'logical',
+    .running = 'logical',
+    .value = 'ANY',
+    .visible = 'logical',
+    .execCount = 'integer'
+  ),
+  methods = list(
+    initialize = function(func, label=deparse(substitute(func))) {
+      if (length(formals(func)) > 0)
+        stop("Can't make a reactive expression from a function that takes one ",
+             "or more parameters; only functions without parameters can be ",
+             "reactive.")
+      .func <<- func
+      .invalidated <<- TRUE
+      .running <<- FALSE
+      .label <<- label
+      .execCount <<- 0L
+    },
+    getValue = function() {
+      .dependents$register()
+
+      if (.invalidated || .running) {
+        .self$.updateValue()
+      }
+      
+      if (identical(class(.value), 'try-error'))
+        stop(attr(.value, 'condition'))
+
+      if (.visible)
+        .value
+      else
+        invisible(.value)
+    },
+    .updateValue = function() {
+      ctx <- Context$new(.label)
+      ctx$onInvalidate(function() {
+        .invalidated <<- TRUE
+        .dependents$invalidate()
+      })
+      .execCount <<- .execCount + 1L
+
+      .invalidated <<- FALSE
+
+      wasRunning <- .running
+      .running <<- TRUE
+      on.exit(.running <<- wasRunning)
+
+      ctx$run(function() {
+        result <- withVisible(try(.func(), silent=FALSE))
+        .visible <<- result$visible
+        .value <<- result$value
+      })
+    }
+  )
+)
+
+#' Create a reactive expression
+#'
+#' Wraps a normal expression to create a reactive expression. Conceptually, a
+#' reactive expression is a expression whose result will change over time.
+#'
+#' Reactive expressions are expressions that can read reactive values and call other
+#' reactive expressions. Whenever a reactive value changes, any reactive expressions
+#' that depended on it are marked as "invalidated" and will automatically
+#' re-execute if necessary. If a reactive expression is marked as invalidated, any
+#' other reactive expressions that recently called it are also marked as
+#' invalidated. In this way, invalidations ripple through the expressions that
+#' depend on each other.
+#'
+#' See the \href{http://rstudio.github.com/shiny/tutorial/}{Shiny tutorial} for
+#' more information about reactive expressions.
+#'
+#' @param x An expression (quoted or unquoted).
+#' @param env The parent environment for the reactive expression. By default, this
+#'   is the calling environment, the same as when defining an ordinary
+#'   non-reactive expression.
+#' @param quoted Is the expression quoted? By default, this is \code{FALSE}.
+#'   This is useful when you want to use an expression that is stored in a
+#'   variable; to do so, it must be quoted with `quote()`.
+#' @param label A label for the reactive expression, useful for debugging.
+#'
+#' @examples
+#' values <- reactiveValues(A=1)
+#'
+#' reactiveB <- reactive({
+#'   values$A + 1
+#' })
+#'
+#' # Can use quoted expressions
+#' reactiveC <- reactive(quote({ values$A + 2 }), quoted = TRUE)
+#'
+#' # To store expressions for later conversion to reactive, use quote()
+#' expr_q <- quote({ values$A + 3 })
+#' reactiveD <- reactive(expr_q, quoted = TRUE)
+#'
+#' # View the values from the R console with isolate()
+#' isolate(reactiveB())
+#' isolate(reactiveC())
+#' isolate(reactiveD())
+#'
+#' @export
+reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL) {
+  fun <- exprToFunction(x, env, quoted)
+  if (is.null(label))
+    label <- deparse(body(fun))
+
+  Observable$new(fun, label)$getValue
+}
+
+# Return the number of times that a reactive expression or observer has been run
+execCount <- function(x) {
+  if (is.function(x))
+    return(environment(x)$.execCount)
+  else if (is(x, 'Observer'))
+    return(x$.execCount)
+  else
+    stop('Unexpected argument to execCount')
+}
+
+# Observer ------------------------------------------------------------------
+
+Observer <- setRefClass(
+  'Observer',
+  fields = list(
+    .func = 'function',
+    .label = 'character',
+    .invalidateCallbacks = 'list',
+    .execCount = 'integer',
+    .onResume = 'function',
+    .suspended = 'logical'
+  ),
+  methods = list(
+    initialize = function(func, label, suspended = FALSE) {
+      if (length(formals(func)) > 0)
+        stop("Can't make an observer from a function that takes parameters; ",
+             "only functions without parameters can be reactive.")
+
+      .func <<- func
+      .label <<- label
+      .execCount <<- 0L
+      .suspended <<- suspended
+      .onResume <<- function() NULL
+
+      # Defer the first running of this until flushReact is called
+      .createContext()$invalidate()
+    },
+    .createContext = function() {
+      ctx <- Context$new(.label)
+
+      ctx$onInvalidate(function() {
+        lapply(.invalidateCallbacks, function(func) {
+          func()
+          NULL
+        })
+
+        continue <- function() {
+          ctx$addPendingFlush()
+        }
+        
+        if (.suspended == FALSE)
+          continue()
+        else
+          .onResume <<- continue
+      })
+      
+      ctx$onFlush(function() {
+        run()
+      })
+      
+      return(ctx)
+    },
+    run = function() {
+      ctx <- .createContext()
+      .execCount <<- .execCount + 1L
+      ctx$run(.func)
+    },
+    onInvalidate = function(func) {
+      "Register a function to run when this observer is invalidated"
+      .invalidateCallbacks <<- c(.invalidateCallbacks, func)
+    },
+    suspend = function() {
+      "Causes this observer to stop scheduling flushes (re-executions) in
+      response to invalidations. If the observer was invalidated prior to this
+      call but it has not re-executed yet (because it waits until onFlush is
+      called) then that re-execution will still occur, becasue the flush is
+      already scheduled."
+      .suspended <<- TRUE
+    },
+    resume = function() {
+      "Causes this observer to start re-executing in response to invalidations.
+      If the observer was invalidated while suspended, then it will schedule
+      itself for re-execution (pending flush)."
+      if (.suspended) {
+        .suspended <<- FALSE
+        .onResume()
+        .onResume <<- function() NULL
+      }
+      invisible()
+    }
+  )
+)
+
+#' Create a reactive observer
+#' 
+#' Creates an observer from the given expression An observer is like a reactive
+#' expression in that it can read reactive values and call reactive expressions, and
+#' will automatically re-execute when those dependencies change. But unlike 
+#' reactive expression, it doesn't yield a result and can't be used as an input 
+#' to other reactive expressions. Thus, observers are only useful for their side 
+#' effects (for example, performing I/O).
+#' 
+#' Another contrast between reactive expressions and observers is their execution
+#' strategy. Reactive expressions 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 x An expression (quoted or unquoted). Any return value will be ignored.
+#' @param env The parent environment for the reactive expression. By default, this
+#'   is the calling environment, the same as when defining an ordinary
+#'   non-reactive expression.
+#' @param quoted Is the expression quoted? By default, this is \code{FALSE}.
+#'   This is useful when you want to use an expression that is stored in a
+#'   variable; to do so, it must be quoted with `quote()`.
+#' @param label A label for the observer, useful for debugging.
+#' @param suspended If \code{TRUE}, start the observer in a suspended state.
+#'   If \code{FALSE} (the default), start in a non-suspended state.
+#'
+#' @examples
+#' values <- reactiveValues(A=1)
+#'
+#' obsB <- observe({
+#'   print(values$A + 1)
+#' })
+#'
+#' # Can use quoted expressions
+#' obsC <- observe(quote({ print(values$A + 2) }), quoted = TRUE)
+#'
+#' # To store expressions for later conversion to observe, use quote()
+#' expr_q <- quote({ print(values$A + 3) })
+#' obsD <- observe(expr_q, quoted = TRUE)
+#'
+#' # In a normal Shiny app, the web client will trigger flush events. If you
+#' # are at the console, you can force a flush with flushReact()
+#' shiny:::flushReact()
+#'
+#' @export
+observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
+                    suspended=FALSE) {
+
+  fun <- exprToFunction(x, env, quoted)
+  if (is.null(label))
+    label <- deparse(body(fun))
+
+  invisible(Observer$new(fun, label=label, suspended=suspended))
+}
+
+# ---------------------------------------------------------------------------
+
+#' Timer
+#' 
+#' Creates a reactive timer with the given interval. A reactive timer is like a 
+#' reactive value, except reactive values are triggered when they are set, while
+#' reactive timers are triggered simply by the passage of time.
+#' 
+#' \link[=reactive]{Reactive expressions} and observers that want to be 
+#' invalidated by the timer need to call the timer function that 
+#' \code{reactiveTimer} returns, even if the current time value is not actually 
+#' needed.
+#' 
+#' See \code{\link{invalidateLater}} as a safer and simpler alternative.
+#' 
+#' @param intervalMs How often to fire, in milliseconds
+#' @return A no-parameter function that can be called from a reactive context, 
+#'   in order to cause that context to be invalidated the next time the timer 
+#'   interval elapses. Calling the returned function also happens to yield the 
+#'   current time (as in \code{\link{Sys.time}}).
+#' @seealso invalidateLater
+#' @export
+reactiveTimer <- function(intervalMs=1000) {
+  dependents <- Map$new()
+  timerCallbacks$schedule(intervalMs, function() {
+    timerCallbacks$schedule(intervalMs, sys.function())
+    lapply(
+      dependents$values(),
+      function(dep.ctx) {
+        dep.ctx$invalidate()
+        NULL
+      })
+  })
+  return(function() {
+    ctx <- .getReactiveEnvironment()$currentContext()
+    if (!dependents$containsKey(ctx$id)) {
+      dependents$set(ctx$id, ctx)
+      ctx$onInvalidate(function() {
+        dependents$remove(ctx$id)
+      })
+    }
+    return(Sys.time())
+  })
+}
+
+#' Scheduled Invalidation
+#' 
+#' Schedules the current reactive context to be invalidated in the given number 
+#' of milliseconds.
+#' @param millis Approximate milliseconds to wait before invalidating the
+#'   current reactive context.
+#' @export
+invalidateLater <- function(millis) {
+  ctx <- .getReactiveEnvironment()$currentContext()
+  timerCallbacks$schedule(millis, function() {
+    ctx$invalidate()
+  })
+  invisible()
+}
+
+#' Create a non-reactive scope for an expression
+#' 
+#' Executes the given expression in a scope where reactive values or expression 
+#' can be read, but they cannot cause the reactive scope of the caller to be 
+#' re-evaluated when they change.
+#' 
+#' Ordinarily, the simple act of reading a reactive value causes a relationship 
+#' to be established between the caller and the reactive value, where a change 
+#' to the reactive value will cause the caller to re-execute. (The same applies 
+#' for the act of getting a reactive expression's value.) The \code{isolate} 
+#' function lets you read a reactive value or expression without establishing this
+#' relationship.
+#' 
+#' The expression given to \code{isolate()} is evaluated in the calling
+#' environment. This means that if you assign a variable inside the
+#' \code{isolate()}, its value will be visible outside of the \code{isolate()}.
+#' If you want to avoid this, you can use \code{\link{local}()} inside the
+#' \code{isolate()}.
+#'
+#' This function can also be useful for calling reactive expression at the
+#' console, which can be useful for debugging. To do so, simply wrap the
+#' calls to the reactive expression with \code{isolate()}.
+#'
+#' @param expr An expression that can access reactive values or expressions.
+#' 
+#' @examples
+#' \dontrun{
+#' observe({
+#'   input$saveButton  # Do take a dependency on input$saveButton
+#'   
+#'   # isolate a simple expression
+#'   data <- get(isolate(input$dataset))  # No dependency on input$dataset
+#'   writeToDatabase(data)
+#' })
+#' 
+#' observe({
+#'   input$saveButton  # Do take a dependency on input$saveButton
+#'   
+#'   # isolate a whole block
+#'   data <- isolate({
+#'     a <- input$valueA   # No dependency on input$valueA or input$valueB
+#'     b <- input$valueB
+#'     c(a=a, b=b)
+#'   })
+#'   writeToDatabase(data)
+#' })
+#'
+#' observe({
+#'   x <- 1
+#'   # x outside of isolate() is affected
+#'   isolate(x <- 2)
+#'   print(x) # 2
+#'
+#'   y <- 1
+#'   # Use local() to avoid affecting calling environment
+#'   isolate(local(y <- 2))
+#'   print(y) # 1
+#' })
+#'
+#' }
+#'
+#' # Can also use isolate to call reactive expressions from the R console
+#' values <- reactiveValues(A=1)
+#' fun <- reactive({ as.character(values$A) })
+#' isolate(fun())
+#' # "1"
+#'
+#' # isolate also works if the reactive expression accesses values from the
+#' # input object, like input$x
+#'
+#' @export
+isolate <- function(expr) {
+  ctx <- Context$new('[isolate]')
+  ctx$run(function() {
+    expr
+  })
+}

R/run-url.R

@@ -0,0 +1,164 @@
+#' 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/jcheng5/3239667, then \code{3239667},
+#'   \code{'3239667'}, and \code{'https://gist.github.com/jcheng5/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.
+#'
+#' @examples
+#' \dontrun{
+#' runGist(3239667)
+#' runGist("https://gist.github.com/jcheng5/3239667")
+#'
+#' # Old URL format without username
+#' runGist("https://gist.github.com/3239667")
+#' }
+#'
+#' @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/%s/download', gist)
+  } else if(grepl('^https://gist.github.com/([^/]+/)?([0-9a-f]+)$', gist)) {
+    paste(gist, '/download', sep='')
+  } else {
+    stop('Unrecognized gist identifier format')
+  }
+
+  runUrl(gistUrl, filetype=".tar.gz", subdir=NULL, port=port,
+    launch.browser=launch.browser)
+}
+
+
+#' Run a Shiny application from a GitHub repository
+#'
+#' Download and launch a Shiny application that is hosted in a GitHub repository.
+#'
+#' @param repo Name of the repository
+#' @param username GitHub username
+#' @param ref Desired git reference. Could be a commit, tag, or branch
+#'   name. Defaults to \code{"master"}.
+#' @param subdir A subdirectory in the repository that contains the app. By
+#'   default, this function will run an app from the top level of the repo, but
+#'   you can use a path such as `\code{"inst/shinyapp"}.
+#' @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.
+#'
+#' @examples
+#' \dontrun{
+#' runGitHub("shiny_example", "rstudio")
+#'
+#' # Can run an app from a subdirectory in the repo
+#' runGitHub("shiny_example", "rstudio", subdir = "inst/shinyapp/")
+#' }
+#'
+#' @export
+runGitHub <- function(repo, username = getOption("github.user"),
+  ref = "master", subdir = NULL, port = 8100,
+  launch.browser = getOption('shiny.launch.browser', interactive())) {
+
+  if (is.null(ref)) {
+    stop("Must specify either a ref. ")
+  }
+
+  message("Downloading github repo(s) ",
+    paste(repo, ref, sep = "/", collapse = ", "),
+    " from ",
+    paste(username, collapse = ", "))
+  name <- paste(username, "-", repo, sep = "")
+
+  url <- paste("https://github.com/", username, "/", repo, "/archive/",
+    ref, ".tar.gz", sep = "")
+
+  runUrl(url, subdir=subdir, port=port, launch.browser=launch.browser)
+}
+
+
+#' Run a Shiny application from a URL
+#'
+#' Download and launch a Shiny application that is hosted at a downloadable
+#' URL. The Shiny application must be saved in a .zip, .tar, or .tar.gz file.
+#' The Shiny application files must be contained in a subdirectory in the
+#' archive. For example, the files might be \code{myapp/server.r} and
+#' \code{myapp/ui.r}.
+#'
+#' @param url URL of the application.
+#' @param filetype The file type (\code{".zip"}, \code{".tar"}, or
+#'   \code{".tar.gz"}. Defaults to the file extension taken from the url.
+#' @param subdir A subdirectory in the repository that contains the app. By
+#'   default, this function will run an app from the top level of the repo, but
+#'   you can use a path such as `\code{"inst/shinyapp"}.
+#' @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.
+#'
+#' @examples
+#' \dontrun{
+#' runUrl('https://github.com/rstudio/shiny_example/archive/master.tar.gz')
+#'
+#' # Can run an app from a subdirectory in the archive
+#' runUrl("https://github.com/rstudio/shiny_example/archive/master.zip",
+#'  subdir = "inst/shinyapp/")
+#' }
+#'
+#' @export
+runUrl <- function(url, filetype = NULL, subdir = NULL, port = 8100,
+  launch.browser = getOption('shiny.launch.browser', interactive())) {
+
+  if (!is.null(subdir) && ".." %in% strsplit(subdir, '/')[[1]])
+    stop("'..' not allowed in subdir")
+
+  if (is.null(filetype))
+    filetype <- basename(url)
+
+  if (grepl("\\.tar\\.gz$", filetype))
+    fileext <- ".tar.gz"
+  else if (grepl("\\.tar$", filetype))
+    fileext <- ".tar"
+  else if (grepl("\\.zip$", filetype))
+    fileext <- ".zip"
+  else
+    stop("Unknown file extension.")
+
+  message("Downloading ", url)
+  filePath <- tempfile('shinyapp', fileext=fileext)
+  if (download(url, filePath, mode = "wb", quiet = TRUE) != 0)
+    stop("Failed to download URL ", url)
+  on.exit(unlink(filePath))
+
+  if (fileext %in% c(".tar", ".tar.gz")) {
+    # 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))
+
+  } else if (fileext == ".zip") {
+    dirname <- as.character(unzip(filePath, list=TRUE)$Name[1])
+    unzip(filePath, exdir = dirname(filePath))
+  }
+
+  appdir <- file.path(dirname(filePath), dirname)
+  on.exit(unlink(appdir, recursive = TRUE), add = TRUE)
+
+  appsubdir <- ifelse(is.null(subdir), appdir, file.path(appdir, subdir))
+  runApp(appsubdir, port=port, launch.browser=launch.browser)
+}

R/shinyui.R

@@ -0,0 +1,205 @@
+
+#' @export
+p <- function(...) tags$p(...)
+
+#' @export
+h1 <- function(...) tags$h1(...)
+
+#' @export
+h2 <- function(...) tags$h2(...)
+
+#' @export
+h3 <- function(...) tags$h3(...)
+
+#' @export
+h4 <- function(...) tags$h4(...)
+
+#' @export
+h5 <- function(...) tags$h5(...)
+
+#' @export
+h6 <- function(...) tags$h6(...)
+
+#' @export
+a <- function(...) tags$a(...)
+
+#' @export
+br <- function(...) tags$br(...)
+
+#' @export
+div <- function(...) tags$div(...)
+
+#' @export
+span <- function(...) tags$span(...)
+
+#' @export
+pre <- function(...) tags$pre(...)
+
+#' @export
+code <- function(...) tags$code(...)
+
+#' @export
+img <- function(...) tags$img(...)
+
+#' @export
+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$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)
+      tagWrite(content$children, textConnWriter, 1, context)
+      context$head <- append(context$head, textConnectionValue(textConn))
+      close(textConn)
+      return (FALSE)
+    }
+    else {
+      return (TRUE)
+    }
+  }
+  
+  # write ui HTML to a character vector
+  textConn <- textConnection(NULL, "w") 
+  tagWrite(ui, function(text) cat(text, file = textConn), 0, context)
+  uiHTML <- textConnectionValue(textConn)
+  close(textConn)
+ 
+  # write preamble
+  writeLines(c('<!DOCTYPE html>',
+               '<html>',
+               '<head>',
+               '  <meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>',
+               '  <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,
+               '</head>',
+               '<body>', 
+               recursive=TRUE),
+             con = connection)
+  
+  # write UI html to connection
+  writeLines(uiHTML, con = connection)
+  
+  # write end document
+  writeLines(c('</body>',
+               '</html>'),
+             con = connection)
+}
+
+#' Create a Shiny UI handler
+#' 
+#' Register a UI handler by providing a UI definition (created with e.g. 
+#' \link{pageWithSidebar}) and web server path (typically "/", the default
+#' value).
+#' 
+#' @param ui A user-interace definition
+#' @param path The web server path to server the UI from
+#' @return Called for its side-effect of registering a UI handler
+#' 
+#' @examples
+#' el <- div(HTML("I like <u>turtles</u>"))
+#' cat(as.character(el))
+#'   
+#' @examples
+#' # Define UI
+#' shinyUI(pageWithSidebar(
+#'   
+#'   # Application title
+#'   headerPanel("Hello Shiny!"),
+#'   
+#'   # Sidebar with a slider input
+#'   sidebarPanel(
+#'     sliderInput("obs", 
+#'                 "Number of observations:", 
+#'                 min = 0, 
+#'                 max = 1000, 
+#'                 value = 500)
+#'   ),
+#'   
+#'   # Show a plot of the generated distribution
+#'   mainPanel(
+#'     plotOutput("distPlot")
+#'   )
+#' ))
+#'
+#' @export
+shinyUI <- function(ui, path='/') {
+  
+  force(ui)
+  
+  registerClient({
+    
+    function(ws, header) {
+
+      if (header$PATH != path)
+        return(NULL)
+      
+      textConn <- textConnection(NULL, "w") 
+      on.exit(close(textConn))
+      
+      renderPage(ui, textConn)
+      html <- paste(textConnectionValue(textConn), collapse='\n')
+      return(httpResponse(200, content=html))
+    }
+  })
+}
+

R/shinywrappers.R

@@ -0,0 +1,387 @@
+suppressPackageStartupMessages({
+  library(caTools)
+  library(xtable)
+})
+
+#' Plot Output
+#' 
+#' Renders a reactive plot that is suitable for assigning to an \code{output} 
+#' slot.
+#' 
+#' The corresponding HTML output tag should be \code{div} or \code{img} and have
+#' the CSS class name \code{shiny-plot-output}.
+#'
+#' For output, it will try to use the following devices, in this order:
+#' quartz (via \code{\link[grDevices]{png}}), then \code{\link[Cairo]{CairoPNG}},
+#' and finally \code{\link[grDevices]{png}}. This is in order of quality of
+#' output. Notably, plain \code{png} output on Linux and Windows may not
+#' antialias some point shapes, resulting in poor quality output.
+#' 
+#' @param expr An expression 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. 
+#'   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.
+#' @param env The environment in which to evaluate \code{expr}.
+#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#'   is useful if you want to save an expression in a variable.
+#' @param func A function that generates a plot (deprecated; use \code{expr}
+#'   instead).
+#'   
+#' @export
+renderPlot <- function(expr, width='auto', height='auto', ...,
+                       env=parent.frame(), quoted=FALSE, func=NULL) {
+  if (!is.null(func)) {
+    shinyDeprecated(msg="renderPlot: argument 'func' is deprecated. Please use 'expr' instead.")
+  } else {
+    func <- exprToFunction(expr, env, quoted)
+  }
+
+
+  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).
+    prefix <- '.shinyout_'
+    if (width == 'auto')
+      width <- shinyapp$session$get(paste(prefix, name, '_width', sep=''));
+    if (height == 'auto')
+      height <- shinyapp$session$get(paste(prefix, name, '_height', sep=''));
+    
+    if (width <= 0 || height <= 0)
+      return(NULL)
+
+    # If quartz is available, use png() (which will default to quartz).
+    # Otherwise, if the Cairo package is installed, use CairoPNG().
+    # Finally, if neither quartz nor Cairo, use png().
+    if (capabilities("aqua")) {
+      pngfun <- png
+    } else if (nchar(system.file(package = "Cairo"))) {
+      require(Cairo)
+      pngfun <- CairoPNG
+    } else {
+      pngfun <- png
+    }
+
+    do.call(pngfun, c(args, filename=png.file, width=width, height=height))
+    on.exit(unlink(png.file))
+    tryCatch(
+      func(),
+      finally=dev.off())
+    
+    bytes <- file.info(png.file)$size
+    if (is.na(bytes))
+      return(NULL)
+    
+    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)
+    }
+  })
+}
+
+#' Table Output
+#' 
+#' Creates a reactive table that is suitable for assigning to an \code{output} 
+#' slot.
+#' 
+#' The corresponding HTML output tag should be \code{div} and have the CSS class
+#' name \code{shiny-html-output}.
+#' 
+#' @param expr An expression 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}} and
+#'   \code{\link[xtable]{print.xtable}}.
+#' @param env The environment in which to evaluate \code{expr}.
+#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#'   is useful if you want to save an expression in a variable.
+#' @param func A function that returns an R object that can be used with 
+#'   \code{\link[xtable]{xtable}} (deprecated; use \code{expr} instead).
+#'   
+#' @export
+renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL) {
+  if (!is.null(func)) {
+    shinyDeprecated(msg="renderTable: argument 'func' is deprecated. Please use 'expr' instead.")
+  } else {
+    func <- exprToFunction(expr, env, quoted)
+  }
+
+  function() {
+    classNames <- getOption('shiny.table.class', 'data table table-bordered table-condensed')
+    data <- func()
+
+    if (is.null(data))
+      return("")
+    
+    return(paste(
+      capture.output(
+        print(xtable(data, ...), 
+              type='html', 
+              html.table.attributes=paste('class="',
+                                          htmlEscape(classNames, TRUE),
+                                          '"',
+                                          sep=''), ...)),
+      collapse="\n"))
+  }
+}
+
+#' Printable Output
+#' 
+#' Makes a reactive version of the given function that captures any printed 
+#' output, and also captures its printable result (unless 
+#' \code{\link{invisible}}), into a string. The resulting function is suitable 
+#' for assigning to an  \code{output} slot.
+#' 
+#' The corresponding HTML output tag can be anything (though \code{pre} is 
+#' recommended if you need a monospace font and whitespace preserved) and should
+#' have the CSS class name \code{shiny-text-output}.
+#' 
+#' The result of executing \code{func} will be printed inside a 
+#' \code{\link[utils]{capture.output}} call.
+#' 
+#' Note that unlike most other Shiny output functions, if the given function 
+#' returns \code{NULL} then \code{NULL} will actually be visible in the output. 
+#' To display nothing, make your function return \code{\link{invisible}()}.
+#' 
+#' @param expr An expression that may print output and/or return a printable R 
+#'   object.
+#' @param env The environment in which to evaluate \code{expr}.
+#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#' @param func A function that may print output and/or return a printable R 
+#'   object (deprecated; use \code{expr} instead).
+#'   
+#' @seealso \code{\link{renderText}} for displaying the value returned from a 
+#'   function, instead of the printed output.
+#'
+#' @example res/text-example.R
+#'   
+#' @export
+renderPrint <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
+  if (!is.null(func)) {
+    shinyDeprecated(msg="renderPrint: argument 'func' is deprecated. Please use 'expr' instead.")
+  } else {
+    func <- exprToFunction(expr, env, quoted)
+  }
+
+  function() {
+    return(paste(capture.output({
+      result <- withVisible(func())
+      if (result$visible)
+        print(result$value)
+    }), collapse="\n"))
+  }
+}
+
+#' Text Output
+#' 
+#' Makes a reactive version of the given function that also uses 
+#' \code{\link[base]{cat}} to turn its result into a single-element character 
+#' vector.
+#' 
+#' The corresponding HTML output tag can be anything (though \code{pre} is 
+#' recommended if you need a monospace font and whitespace preserved) and should
+#' have the CSS class name \code{shiny-text-output}.
+#' 
+#' The result of executing \code{func} will passed to \code{cat}, inside a 
+#' \code{\link[utils]{capture.output}} call.
+#' 
+#' @param expr An expression that returns an R object that can be used as an
+#'   argument to \code{cat}.
+#' @param env The environment in which to evaluate \code{expr}.
+#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#'   is useful if you want to save an expression in a variable.
+#' @param func A function that returns an R object that can be used as an
+#'   argument to \code{cat}.(deprecated; use \code{expr} instead).
+#'   
+#' @seealso \code{\link{renderPrint}} for capturing the print output of a
+#'   function, rather than the returned text value.
+#'
+#' @example res/text-example.R
+#'   
+#' @export
+renderText <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
+  if (!is.null(func)) {
+    shinyDeprecated(msg="renderText: argument 'func' is deprecated. Please use 'expr' instead.")
+  } else {
+    func <- exprToFunction(expr, env, quoted)
+  }
+
+  function() {
+    value <- func()
+    return(paste(capture.output(cat(value)), 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 expr An expression that returns a Shiny tag object, \code{\link{HTML}}, 
+#'   or a list of such objects.
+#' @param env The environment in which to evaluate \code{expr}.
+#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#'   is useful if you want to save an expression in a variable.
+#' @param func A function that returns a Shiny tag object, \code{\link{HTML}}, 
+#'   or a list of such objects (deprecated; use \code{expr} instead).
+#'   
+#' @seealso conditionalPanel
+#'   
+#' @export
+#' @examples
+#' \dontrun{
+#'   output$moreControls <- renderUI({
+#'     list(
+#'       
+#'     )
+#'   })
+#' }
+renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
+  if (!is.null(func)) {
+    shinyDeprecated(msg="renderUI: argument 'func' is deprecated. Please use 'expr' instead.")
+  } else {
+    func <- exprToFunction(expr, env, quoted)
+  }
+
+  function() {
+    result <- func()
+    if (is.null(result) || length(result) == 0)
+      return(NULL)
+    # Wrap result in tagList in case it is an ordinary list
+    return(as.character(tagList(result)))
+  }
+}
+
+#' File Downloads
+#' 
+#' Allows content from the Shiny application to be made available to the user as
+#' file downloads (for example, downloading the currently visible data as a CSV 
+#' file). Both filename and contents can be calculated dynamically at the time 
+#' the user initiates the download. Assign the return value to a slot on 
+#' \code{output} in your server function, and in the UI use 
+#' \code{\link{downloadButton}} or \code{\link{downloadLink}} to make the
+#' download available.
+#' 
+#' @param filename A string of the filename, including extension, that the 
+#'   user's web browser should default to when downloading the file; or a 
+#'   function that returns such a string. (Reactive values and functions may be 
+#'   used from this function.)
+#' @param content A function that takes a single argument \code{file} that is a 
+#'   file path (string) of a nonexistent temp file, and writes the content to
+#'   that file path. (Reactive values and functions may be used from this
+#'   function.)
+#' @param contentType A string of the download's 
+#'   \href{http://en.wikipedia.org/wiki/Internet_media_type}{content type}, for 
+#'   example \code{"text/csv"} or \code{"image/png"}. If \code{NULL} or 
+#'   \code{NA}, the content type will be guessed based on the filename 
+#'   extension, or \code{application/octet-stream} if the extension is unknown.
+#'   
+#' @examples
+#' \dontrun{
+#' # In server.R:
+#' output$downloadData <- downloadHandler(
+#'   filename = function() {
+#'     paste('data-', Sys.Date(), '.csv', sep='')
+#'   },
+#'   content = function(file) {
+#'     write.csv(data, file)
+#'   }
+#' )
+#' 
+#' # In ui.R:
+#' downloadLink('downloadData', 'Download')
+#' }
+#' 
+#' @export
+downloadHandler <- function(filename, content, contentType=NA) {
+  return(function(shinyapp, name, ...) {
+    shinyapp$registerDownload(name, filename, contentType, content)
+  })
+}
+
+
+# Deprecated functions ------------------------------------------------------
+
+#' Plot output (deprecated)
+#'
+#' See \code{\link{renderPlot}}.
+#' @param func A function.
+#' @param width Width.
+#' @param height Height.
+#' @param ... Other arguments to pass on.
+#' @export
+reactivePlot <- function(func, width='auto', height='auto', ...) {
+  shinyDeprecated(new="renderPlot")
+  renderPlot({ func() }, width='auto', height='auto', ...)
+}
+
+#' Table output (deprecated)
+#'
+#' See \code{\link{renderTable}}.
+#' @param func A function.
+#' @param ... Other arguments to pass on.
+#' @export
+reactiveTable <- function(func, ...) {
+  shinyDeprecated(new="renderTable")
+  renderTable({ func() })
+}
+
+#' Print output (deprecated)
+#'
+#' See \code{\link{renderPrint}}.
+#' @param func A function.
+#' @export
+reactivePrint <- function(func) {
+  shinyDeprecated(new="renderPrint")
+  renderPrint({ func() })
+}
+
+#' UI output (deprecated)
+#'
+#' See \code{\link{renderUI}}.
+#' @param func A function.
+#' @export
+reactiveUI <- function(func) {
+  shinyDeprecated(new="renderUI")
+  renderUI({ func() })
+}
+
+#' Text output (deprecated)
+#'
+#' See \code{\link{renderText}}.
+#' @param func A function.
+#' @export
+reactiveText <- function(func) {
+  shinyDeprecated(new="renderText")
+  renderText({ func() })
+}

R/slider.R

@@ -0,0 +1,133 @@
+hasDecimals <- function(value) {
+  truncatedValue <- round(value)
+  return (!identical(value, truncatedValue))
+}
+
+#' Animation Options
+#' 
+#' Creates an options object for customizing animations for \link{sliderInput}.
+#' 
+#' @param interval The interval, in milliseconds, between each animation step.
+#' @param loop \code{TRUE} to automatically restart the animation when it 
+#'   reaches the end.
+#' @param playButton Specifies the appearance of the play button. Valid values 
+#'   are a one-element character vector (for a simple text label), an HTML tag 
+#'   or list of tags (using \code{\link{tag}} and friends), or raw HTML (using 
+#'   \code{\link{HTML}}).
+#' @param pauseButton Similar to \code{playButton}, but for the pause button.
+#'   
+#' @export
+animationOptions <- function(interval=1000,
+                             loop=FALSE,
+                             playButton=NULL,
+                             pauseButton=NULL) {
+  list(interval=interval,
+       loop=loop,
+       playButton=playButton,
+       pauseButton=pauseButton)
+}
+
+# Create a new slider control (list of slider input element and the script
+# tag used to configure it). This is a lower level control that should
+# be wrapped in an "input" construct (e.g. sliderInput in bootstrap.R)
+# 
+# this is a wrapper for: https://github.com/egorkhmelev/jslider
+# (www/shared/slider contains js, css, and img dependencies) 
+slider <- function(inputId, min, max, value, step = NULL, ...,
+                   round=FALSE, format='#,##0.#####', locale='us',
+                   ticks=TRUE, animate=FALSE) {
+  # validate inputId
+  inputId <- as.character(inputId)
+  if (!is.character(inputId))
+    stop("inputId not specified")
+    
+  # validate numeric inputs
+  if (!is.numeric(value) || !is.numeric(min) || !is.numeric(max)) 
+    stop("min, max, amd value must all be numeric values")
+  else if (min(value) < min) 
+    stop(paste("slider initial value", value, 
+               "is less than the specified minimum"))
+  else if (max(value) > max) 
+    stop(paste("slider initial value", value, 
+               "is greater than the specified maximum"))
+  else if (min > max) 
+    stop(paste("slider maximum is greater than minimum"))
+  else if (!is.null(step)) {
+    if (!is.numeric(step)) 
+      stop("step is not a numeric value")
+    if (step > (max - min)) 
+      stop("step is greater than range")
+  }
+  
+  # step
+  range <- max - min
+  if (is.null(step)) {
+    # short range or decimals means continuous decimal
+    if (range < 2 || hasDecimals(min) || hasDecimals(max))
+      step <- range / 250 # ~ one step per pixel
+    else
+      step = 1
+  }
+  
+  # Default state is to not have ticks
+  if (identical(ticks, TRUE)) {
+    # Automatic ticks
+    tickCount <- (range / step) + 1
+    if (tickCount <= 26)
+      ticks <- paste(rep('|', floor(tickCount)), collapse=';')
+    else {
+      ticks <- NULL
+#       # This is a smarter auto-tick algorithm, but to be truly useful
+#       # we need jslider to be able to space ticks irregularly
+#       tickSize <- 10^(floor(log10(range/0.39)))
+#       if ((range / tickSize) == floor(range / tickSize)) {
+#         ticks <- paste(rep('|', (range / tickSize) + 1), collapse=';')
+#       }
+#       else {
+#         ticks <- NULL
+#       }
+    }
+  }
+  else if (is.numeric(ticks) && length(ticks) == 1) {
+    # Use n ticks
+    ticks <- paste(rep('|', ticks), collapse=';')
+  }
+  else if (length(ticks) > 1 && (is.numeric(ticks) || is.character(ticks))) {
+    # Explicit ticks
+    ticks <- paste(ticks, collapse=';')
+  }
+  else {
+    ticks <- NULL
+  }
+  
+  # build slider
+  sliderFragment <- list(tags$input(
+    id=inputId, type="slider", 
+    name=inputId, value=paste(value, collapse=';'), class="jslider",
+    'data-from'=min, 'data-to'=max, 'data-step'=step,
+    'data-skin'='plastic', 'data-round'=round, 'data-locale'=locale,
+    'data-format'=format, 'data-scale'=ticks,
+    'data-smooth'=FALSE))
+
+  if (identical(animate, TRUE))
+    animate <- animationOptions()
+  
+  if (!is.null(animate) && !identical(animate, FALSE)) {
+    if (is.null(animate$playButton))
+      animate$playButton <- 'Play'
+    if (is.null(animate$pauseButton))
+      animate$pauseButton <- 'Pause'
+    
+    sliderFragment[[length(sliderFragment)+1]] <-
+      tags$div(class='slider-animate-container',
+               tags$a(href='#',
+                      class='slider-animate-button',
+                      'data-target-id'=inputId,
+                      'data-interval'=animate$interval,
+                      'data-loop'=animate$loop,
+                      tags$span(class='play', animate$playButton),
+                      tags$span(class='pause', animate$pauseButton)))
+  }
+  
+  return(sliderFragment)
+}

R/tags.R

@@ -0,0 +1,368 @@
+
+
+htmlEscape <- local({
+  .htmlSpecials <- list(
+    `&` = '&amp;',
+    `<` = '&lt;',
+    `>` = '&gt;'
+  )
+  .htmlSpecialsPattern <- paste(names(.htmlSpecials), collapse='|')
+  .htmlSpecialsAttrib <- c(
+    .htmlSpecials,
+    `'` = '&#39;',
+    `"` = '&quot;',
+    `\r` = '&#13;',
+    `\n` = '&#10;'
+  )
+  .htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse='|')
+  
+  function(text, attribute=TRUE) {
+    pattern <- if(attribute)
+      .htmlSpecialsPatternAttrib 
+    else
+      .htmlSpecialsPattern
+    
+    # Short circuit in the common case that there's nothing to escape
+    if (!grepl(pattern, text))
+      return(text)
+    
+    specials <- if(attribute)
+      .htmlSpecialsAttrib
+    else
+      .htmlSpecials
+    
+    for (chr in names(specials)) {
+      text <- gsub(chr, specials[[chr]], text, fixed=TRUE)
+    }
+    
+    return(text)
+  }
+})
+
+isTag <- function(x) {
+  inherits(x, "shiny.tag")
+}
+
+#' @S3method print shiny.tag
+print.shiny.tag <- function(x, ...) {
+  print(as.character(x), ...)
+}
+
+#' @S3method format shiny.tag
+format.shiny.tag <- function(x, ...) {
+  as.character.shiny.tag(x)
+}
+
+#' @S3method as.character shiny.tag
+as.character.shiny.tag <- function(x, ...) {
+  f = file()
+  on.exit(close(f))
+  textWriter <- function(text) {
+    cat(text, file=f)
+  }
+  tagWrite(x, textWriter)
+  return(HTML(paste(readLines(f, warn=FALSE), 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
+  else
+    htmlEscape(text, attribute=FALSE)
+  
+}
+
+#' @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
+  tag
+}
+
+#' @export
+tag <- function(`_tag_name`, varArgs) {
+  
+  # create basic tag data structure
+  tag <- list()
+  class(tag) <- "shiny.tag"
+  tag$name <- `_tag_name`
+  tag$attribs <- list()
+  tag$children <- list()
+  
+  # process varArgs
+  varArgsNames <- names(varArgs)
+  if (is.null(varArgsNames))
+    varArgsNames <- character(length=length(varArgs))
+  
+  if (length(varArgsNames) > 0) {
+    for (i in 1:length(varArgsNames)) {
+      # save name and value
+      name <- varArgsNames[[i]]
+      value <- varArgs[[i]]
+      
+      # process attribs
+      if (nzchar(name))
+        tag$attribs[[name]] <- value
+      
+      # process child tags
+      else if (isTag(value)) {
+        tag$children[[length(tag$children)+1]] <- value
+      }
+      
+      # recursively process lists of children
+      else if (is.list(value)) {
+        
+        tagAppendChildren <- function(tag, children) {
+          for(child in children) {
+            if (isTag(child))
+              tag <- tagAppendChild(tag, child)
+            else if (is.list(child))
+              tag <- tagAppendChildren(tag, child)
+            else if (is.character(child))
+              tag <- tagAppendChild(tag, child)
+            else
+              tag <- tagAppendChild(tag, as.character(child))
+          }
+          return (tag)
+        }
+        
+        tag <- tagAppendChildren(tag, value)
+      }
+      
+      # add text
+      else if (is.character(value)) {
+        tag <- tagAppendChild(tag, value)
+      }
+      
+      # everything else treated as text
+      else {
+        tag <- tagAppendChild(tag, as.character(value))
+      }
+    }
+  }
+  
+  # return the tag
+  return (tag)
+}
+
+tagWrite <- function(tag, textWriter, indent=0, context = NULL, eol = "\n") {
+  
+  # optionally process a list of tags
+  if (!isTag(tag) && is.list(tag)) {
+    sapply(tag, function(t) tagWrite(t, textWriter, indent, context))
+    return (NULL)
+  }
+  
+  # first call optional filter -- exit function if it returns false
+  if (!is.null(context) && !is.null(context$filter) && !context$filter(tag))
+    return (NULL)
+  
+  # compute indent text
+  indentText <- paste(rep(" ", indent*2), collapse="")
+  
+  # Check if it's just text (may either be plain-text or HTML)
+  if (is.character(tag)) {
+    textWriter(paste(indentText, normalizeText(tag), eol, sep=""))
+    return (NULL)
+  }
+  
+  # write tag name
+  textWriter(paste(indentText, "<", tag$name, sep=""))
+  
+  # write attributes
+  for (attrib in names(tag$attribs)) {
+    attribValue <- tag$attribs[[attrib]]
+    if (!is.na(attribValue)) {
+      if (is.logical(attribValue))
+        attribValue <- tolower(attribValue)
+      text <- htmlEscape(attribValue, attribute=TRUE) 
+      textWriter(paste(" ", attrib,"=\"", text, "\"", sep=""))
+    }
+    else {
+      textWriter(paste(" ", attrib, sep=""))
+    }
+  }
+  
+  # write any children
+  if (length(tag$children) > 0) {
+    textWriter(">")
+    
+    # special case for a single child text node (skip newlines and indentation)
+    if ((length(tag$children) == 1) && is.character(tag$children[[1]]) ) {
+      tagWrite(tag$children[[1]], textWriter, 0, context, "")
+      textWriter(paste("</", tag$name, ">", eol, sep=""))
+    }
+    else {
+      textWriter("\n")
+      for (child in tag$children)
+        tagWrite(child, textWriter, indent+1, context)
+      textWriter(paste(indentText, "</", tag$name, ">", eol, sep=""))
+    }
+  }
+  else {
+    # only self-close void elements 
+    # (see: http://dev.w3.org/html5/spec/single-page.html#void-elements)
+    if (tag$name %in% c("area", "base", "br", "col", "command", "embed", "hr", 
+                        "img", "input", "keygen", "link", "meta", "param",
+                        "source", "track", "wbr")) {
+      textWriter(paste("/>", eol, sep=""))
+    }
+    else {
+      textWriter(paste("></", tag$name, ">", eol, sep=""))
+    }
+  }
+}
+
+
+# environment used to store all available tags
+#' @export
+tags <- new.env()
+tags$a <- function(...) tag("a", list(...))
+tags$abbr <- function(...) tag("abbr", list(...))
+tags$address <- function(...) tag("address", list(...))
+tags$area <- function(...) tag("area", list(...))
+tags$article <- function(...) tag("article", list(...))
+tags$aside <- function(...) tag("aside", list(...))
+tags$audio <- function(...) tag("audio", list(...))
+tags$b <- function(...) tag("b", list(...))
+tags$base <- function(...) tag("base", list(...))
+tags$bdi <- function(...) tag("bdi", list(...))
+tags$bdo <- function(...) tag("bdo", list(...))
+tags$blockquote <- function(...) tag("blockquote", list(...))
+tags$body <- function(...) tag("body", list(...))
+tags$br <- function(...) tag("br", list(...))
+tags$button <- function(...) tag("button", list(...))
+tags$canvas <- function(...) tag("canvas", list(...))
+tags$caption <- function(...) tag("caption", list(...))
+tags$cite <- function(...) tag("cite", list(...))
+tags$code <- function(...) tag("code", list(...))
+tags$col <- function(...) tag("col", list(...))
+tags$colgroup <- function(...) tag("colgroup", list(...))
+tags$command <- function(...) tag("command", list(...))
+tags$data <- function(...) tag("data", list(...))
+tags$datalist <- function(...) tag("datalist", list(...))
+tags$dd <- function(...) tag("dd", list(...))
+tags$del <- function(...) tag("del", list(...))
+tags$details <- function(...) tag("details", list(...))
+tags$dfn <- function(...) tag("dfn", list(...))
+tags$div <- function(...) tag("div", list(...))
+tags$dl <- function(...) tag("dl", list(...))
+tags$dt <- function(...) tag("dt", list(...))
+tags$em <- function(...) tag("em", list(...))
+tags$embed <- function(...) tag("embed", list(...))
+tags$eventsource <- function(...) tag("eventsource", list(...))
+tags$fieldset <- function(...) tag("fieldset", list(...))
+tags$figcaption <- function(...) tag("figcaption", list(...))
+tags$figure <- function(...) tag("figure", list(...))
+tags$footer <- function(...) tag("footer", list(...))
+tags$form <- function(...) tag("form", list(...))
+tags$h1 <- function(...) tag("h1", list(...))
+tags$h2 <- function(...) tag("h2", list(...))
+tags$h3 <- function(...) tag("h3", list(...))
+tags$h4 <- function(...) tag("h4", list(...))
+tags$h5 <- function(...) tag("h5", list(...))
+tags$h6 <- function(...) tag("h6", list(...))
+tags$head <- function(...) tag("head", list(...))
+tags$header <- function(...) tag("header", list(...))
+tags$hgroup <- function(...) tag("hgroup", list(...))
+tags$hr <- function(...) tag("hr", list(...))
+tags$html <- function(...) tag("html", list(...))
+tags$i <- function(...) tag("i", list(...))
+tags$iframe <- function(...) tag("iframe", list(...))
+tags$img <- function(...) tag("img", list(...))
+tags$input <- function(...) tag("input", list(...))
+tags$ins <- function(...) tag("ins", list(...))
+tags$kbd <- function(...) tag("kbd", list(...))
+tags$keygen <- function(...) tag("keygen", list(...))
+tags$label <- function(...) tag("label", list(...))
+tags$legend <- function(...) tag("legend", list(...))
+tags$li <- function(...) tag("li", list(...))
+tags$link <- function(...) tag("link", list(...))
+tags$mark <- function(...) tag("mark", list(...))
+tags$map <- function(...) tag("map", list(...))
+tags$menu <- function(...) tag("menu", list(...))
+tags$meta <- function(...) tag("meta", list(...))
+tags$meter <- function(...) tag("meter", list(...))
+tags$nav <- function(...) tag("nav", list(...))
+tags$noscript <- function(...) tag("noscript", list(...))
+tags$object <- function(...) tag("object", list(...))
+tags$ol <- function(...) tag("ol", list(...))
+tags$optgroup <- function(...) tag("optgroup", list(...))
+tags$option <- function(...) tag("option", list(...))
+tags$output <- function(...) tag("output", list(...))
+tags$p <- function(...) tag("p", list(...))
+tags$param <- function(...) tag("param", list(...))
+tags$pre <- function(...) tag("pre", list(...))
+tags$progress <- function(...) tag("progress", list(...))
+tags$q <- function(...) tag("q", list(...))
+tags$ruby <- function(...) tag("ruby", list(...))
+tags$rp <- function(...) tag("rp", list(...))
+tags$rt <- function(...) tag("rt", list(...))
+tags$s <- function(...) tag("s", list(...))
+tags$samp <- function(...) tag("samp", list(...))
+tags$script <- function(...) tag("script", list(...))
+tags$section <- function(...) tag("section", list(...))
+tags$select <- function(...) tag("select", list(...))
+tags$small <- function(...) tag("small", list(...))
+tags$source <- function(...) tag("source", list(...))
+tags$span <- function(...) tag("span", list(...))
+tags$strong <- function(...) tag("strong", list(...))
+tags$style <- function(...) tag("style", list(...))
+tags$sub <- function(...) tag("sub", list(...))
+tags$summary <- function(...) tag("summary", list(...))
+tags$sup <- function(...) tag("sup", list(...))
+tags$table <- function(...) tag("table", list(...))
+tags$tbody <- function(...) tag("tbody", list(...))
+tags$td <- function(...) tag("td", list(...))
+tags$textarea <- function(...) tag("textarea", list(...))
+tags$tfoot <- function(...) tag("tfoot", list(...))
+tags$th <- function(...) tag("th", list(...))
+tags$thead <- function(...) tag("thead", list(...))
+tags$time <- function(...) tag("time", list(...))
+tags$title <- function(...) tag("title", list(...))
+tags$tr <- function(...) tag("tr", list(...))
+tags$track <- function(...) tag("track", list(...))
+tags$u <- function(...) tag("u", list(...))
+tags$ul <- function(...) tag("ul", list(...))
+tags$var <- function(...) tag("var", list(...))
+tags$video <- function(...) tag("video", list(...))
+tags$wbr <- function(...) tag("wbr", list(...))
+
+#' Mark Characters as HTML
+#' 
+#' Marks the given text as HTML, which means the \link{tag} functions will know
+#' not to perform HTML escaping on it.
+#' 
+#' @param text The text value to mark with HTML
+#' @param ... Any additional values to be converted to character and
+#'   concatenated together
+#' @return The same value, but marked as HTML.
+#' 
+#' @examples
+#' el <- div(HTML("I like <u>turtles</u>"))
+#' cat(as.character(el))
+#'   
+#' @export
+HTML <- function(text, ...) {
+  htmlText <- c(text, as.character(list(...)))
+  htmlText <- paste(htmlText, collapse=" ")
+  attr(htmlText, "html") <- TRUE
+  htmlText
+}
+
+

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

@@ -0,0 +1,72 @@
+# Return the current time, in milliseconds from epoch, with
+# unspecified time zone.
+now <- function() {
+  as.numeric(Sys.time()) * 1000
+}
+
+TimerCallbacks <- setRefClass(
+  'TimerCallbacks',
+  fields = list(
+    .nextId = 'integer',
+    .funcs = 'Map',
+    .times = 'data.frame'
+  ),
+  methods = list(
+    initialize = function() {
+      .nextId <<- 0L
+    },
+    clear = function() {
+      .nextId <<- 0L
+      .funcs$clear()
+      .times <<- data.frame()
+    },
+    schedule = function(millis, func) {
+      id <- .nextId
+      .nextId <<- .nextId + 1L
+      
+      t <- now()
+      
+      # TODO: Horribly inefficient, use a heap instead
+      .times <<- rbind(.times, data.frame(time=t+millis,
+                                          scheduled=t,
+                                          id=id))
+      .times <<- .times[order(.times$time),]
+      
+      .funcs$set(as.character(id), func)
+      
+      return(id)
+    },
+    timeToNextEvent = function() {
+      if (dim(.times)[1] == 0)
+        return(Inf)
+      return(.times[1, 'time'] - now())
+    },
+    takeElapsed = function() {
+      t <- now()
+      elapsed <- .times$time < now()
+      result <- .times[elapsed,]
+      .times <<- .times[!elapsed,]
+      
+      # TODO: Examine scheduled column to check if any funny business
+      #       has occurred with the system clock (e.g. if scheduled
+      #       is later than now())
+      
+      return(result)
+    },
+    executeElapsed = function() {
+      elapsed <- takeElapsed()
+      if (length(elapsed) == 0)
+        return(FALSE)
+      
+      for (id in elapsed$id) {
+        thisFunc <- .funcs$remove(as.character(id))
+        # TODO: Catch exception, and...?
+        # TODO: Detect NULL, and...?
+        thisFunc()
+      }
+      return(TRUE)
+    }
+  )
+)
+
+timerCallbacks <- TimerCallbacks$new()

R/utils.R

@@ -0,0 +1,212 @@
+#' 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
+}
+
+# Create a zero-arg function from a quoted expression and environment
+# @examples
+# makeFunction(body=quote(print(3)))
+makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
+  eval(call("function", args, body), env)
+}
+
+#' Convert an expression or quoted expression to a function
+#'
+#' This is to be called from another function, because it will attempt to get
+#' an unquoted expression from two calls back.
+#'
+#' If expr is a quoted expression, then this just converts it to a function.
+#' If expr is a function, then this simply returns expr (and prints a
+#'   deprecation message.
+#' If expr was a non-quoted expression from two calls back, then this will
+#'   quote the original expression and convert it to a function.
+#
+#' @param expr A quoted or unquoted expression, or a function.
+#' @param env The desired environment for the function. Defaults to the
+#'   calling environment two steps back.
+#' @param quoted Is the expression quoted?
+#'
+#' @examples
+#' # Example of a new renderer, similar to renderText
+#' # This is something that toolkit authors will do
+#' renderTriple <- function(expr, env=parent.frame(), quoted=FALSE) {
+#'   # Convert expr to a function
+#'   func <- shiny::exprToFunction(expr, env, quoted)
+#'
+#'   function() {
+#'     value <- func()
+#'     paste(rep(value, 3), collapse=", ")
+#'   }
+#' }
+#'
+#'
+#' # Example of using the renderer.
+#' # This is something that app authors will do.
+#' values <- reactiveValues(A="text")
+#'
+#' \dontrun{
+#' # Create an output object
+#' output$tripleA <- renderTriple({
+#'   values$A
+#' })
+#' }
+#'
+#' # At the R console, you can experiment with the renderer using isolate()
+#' tripleA <- renderTriple({
+#'   values$A
+#' })
+#'
+#' isolate(tripleA())
+#' # "text, text, text"
+#'
+#' @export
+exprToFunction <- function(expr, env=parent.frame(2), quoted=FALSE) {
+  # Get the quoted expr from two calls back
+  expr_sub <- eval(substitute(substitute(expr)), parent.frame())
+
+  # Check if expr is a function, making sure not to evaluate expr, in case it
+  # is actually an unquoted expression.
+  # If expr is a single token, then indexing with [[ will error; if it has multiple
+  # tokens, then [[ works. In the former case it will be a name object; in the
+  # latter, it will be a language object.
+  if (!is.name(expr_sub) && expr_sub[[1]] == as.name('function')) {
+    # Get name of function that called this function
+    called_fun <- sys.call(-1)[[1]]
+
+    shinyDeprecated(msg = paste("Passing functions to '", called_fun,
+      "' is deprecated. Please use expressions instead. See ?", called_fun,
+      " for more information.", sep=""))
+    return(expr)
+  }
+
+  if (quoted) {
+    # expr is a quoted expression
+    makeFunction(body=expr, env=env)
+  } else {
+    # expr is an unquoted expression
+    makeFunction(body=expr_sub, env=env)
+  }
+}
+
+#' Print message for deprecated functions in Shiny
+#'
+#' To disable these messages, use \code{options(shiny.deprecation.messages=FALSE)}.
+#'
+#' @param new Name of replacement function.
+#' @param msg Message to print. If used, this will override the default message.
+#' @param old Name of deprecated function.
+shinyDeprecated <- function(new=NULL, msg=NULL,
+                            old=as.character(sys.call(sys.parent()))[1L]) {
+
+  if (getOption("shiny.deprecation.messages", default=TRUE) == FALSE)
+    return(invisible())
+
+  if (is.null(msg)) {
+    msg <- paste(old, "is deprecated.")
+    if (!is.null(new))
+      msg <- paste(msg, "Please use", new, "instead.",
+        "To disable this message, run options(shiny.deprecation.messages=FALSE)")
+  }
+  # Similar to .Deprecated(), but print a message instead of warning
+  message(msg)
+}

README.md

@@ -1,10 +1,39 @@
-# Shiny
-### A web framework for R (eventually--Ruby for now)
+# Shiny 
 
-```sh
-sudo apt-get install ruby1.9.1 ruby1.9.1-dev
-sudo gem install bundler
-cd shiny
-bundle install --path vendor
-./run.sh
-```
+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.
+* Shiny applications are automatically "live" in the same way that spreadsheets are live. Outputs change instantly as users modify inputs, without requiring a reload of the browser.
+* Shiny user interfaces can be built entirely using R, or can be written directly in HTML, CSS, and JavaScript for more flexibility.
+* Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.)
+* Attractive default UI theme based on [Twitter Bootstrap](http://twitter.github.com/bootstrap).
+* A highly customizable slider widget with built-in support for animation.
+* Pre-built output widgets for displaying plots, tables, and printed output of R objects.
+* Fast bidirectional communication between the web browser and R using the [websockets](http://illposed.net/websockets.html) package.
+* Uses a [reactive](http://en.wikipedia.org/wiki/Reactive_programming) programming model that eliminates messy event handling code, so you can focus on the code that really matters.
+* Develop and redistribute your own Shiny widgets that other developers can easily drop into their own applications (coming soon!).
+
+## Installation
+
+From an R console:
+
+```r
+install.packages("shiny")
+```
+
+## Getting Started
+
+To learn more we highly recommend you check out the [Shiny Tutorial](http://rstudio.github.com/shiny/tutorial). The tutorial explains the framework in-depth, walks you through building a simple application, and includes extensive annotated examples.
+
+We hope you enjoy using Shiny. As you learn more and work with the package please [let us know](https://github.com/rstudio/shiny/issues) what problems you encounter and how you'd like to see Shiny evolve.
+
+## License
+
+The shiny package is licensed under the GPLv3. See these files in the inst directory for additional details:
+
+- COPYING - shiny package license (GPLv3)
+- NOTICE  - Copyright notices for additional included software

examples/02_hash/app.R

@@ -1,15 +0,0 @@
-library(digest)
-
-input <- Observable$new(function() {
-  str <- get.shiny.input('input1')
-  if (get.shiny.input('addnewline'))
-    str <- paste(str, "\n", sep='')
-  return(str)
-})
-
-define.shiny.output('md5_hash', function() {
-  digest(input$get.value(), algo='md5', serialize=F)
-})
-define.shiny.output('sha1_hash', function() {
-  digest(input$get.value(), algo='sha1', serialize=F)
-})

examples/02_hash/www/index.html

@@ -1,26 +0,0 @@
-<html>
-<head>
-  <script src="shared/jquery-1.7.2.js" type="text/javascript"></script>
-  <script src="shared/shiny.js" type="text/javascript"></script>
-  <link rel="stylesheet" type="text/css" href="shared/shiny.css"/>
-</head>
-<body>
-  <h1>Example 2: Hash Calculation</h1>
-
-  <p>
-    <label>Input:</label><br />
-    <input name="input1" value="Hello World!"/>
-    <input type="checkbox" name="addnewline" checked="checked"/> Append newline
-  </p>
-
-  <p>
-    <label>MD5:</label><br />
-    <pre id="md5_hash" class="live-text"></pre>
-  </p>
-
-  <p>
-    <label>SHA-1:</label><br />
-    <pre id="sha1_hash" class="live-text"></pre>
-  </p>
-</body>
-</html>

examples/03_distributions/app.R

@@ -1,24 +0,0 @@
-data <- Observable$new(function() {
-  # Choose a distribution function
-  dist <- switch(get.shiny.input('dist'),
-                 norm = rnorm,
-                 unif = runif,
-                 lnorm = rlnorm,
-                 exp = rexp,
-                 rnorm)
-  
-  # Generate n values from the distribution function
-  dist(max(1, get.shiny.input('n')))
-})
-
-define.shiny.plot('plot1', function() {
-  dist <- get.shiny.input('dist')
-  n <- get.shiny.input('n')
-  
-  hist(data$get.value(), 
-       main=paste('r', dist, '(', n, ')', sep=''))
-}, width=600, height=300)
-
-define.shiny.table('table1', function() {
-  data.frame(x=data$get.value())
-})

hash.rb

@@ -1,19 +0,0 @@
-require 'shiny'
-require 'digest/sha1'
-require 'digest/md5'
-
-shinyapp = ShinyApp.new
-
-input1 = React::ObservableValue.new {
-  shinyapp.session.get('input1') + (shinyapp.session.get('addnewline') ? "\n" : '')
-}
-
-shinyapp.define_output('md5_hash') do
-  Digest::MD5.hexdigest(input1.value)
-end
-
-shinyapp.define_output('sha1_hash') do
-  Digest::SHA1.hexdigest(input1.value)
-end
-
-shinyapp.run

inst/COPYING

@@ -0,0 +1,678 @@
+The shiny package is licensed to you under the GPLv3, the terms of 
+which are included below. The markdown pacakge includes other open 
+source software whose license terms can be found in the file NOTICE.
+
+                    GNU GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                            Preamble
+
+  The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+  The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works.  By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users.  We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors.  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+  To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights.  Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received.  You must make sure that they, too, receive
+or can get the source code.  And you must show them these terms so they
+know their rights.
+
+  Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+  For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software.  For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+  Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so.  This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software.  The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable.  Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products.  If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+  Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary.  To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+                       TERMS AND CONDITIONS
+
+  0. Definitions.
+
+  "This License" refers to version 3 of the GNU General Public License.
+
+  "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+  "The Program" refers to any copyrightable work licensed under this
+License.  Each licensee is addressed as "you".  "Licensees" and
+"recipients" may be individuals or organizations.
+
+  To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy.  The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+  A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+  To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy.  Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+  To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies.  Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+  An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License.  If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+  1. Source Code.
+
+  The "source code" for a work means the preferred form of the work
+for making modifications to it.  "Object code" means any non-source
+form of a work.
+
+  A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+  The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form.  A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+  The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities.  However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work.  For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+  The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+  The Corresponding Source for a work in source code form is that
+same work.
+
+  2. Basic Permissions.
+
+  All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met.  This License explicitly affirms your unlimited
+permission to run the unmodified Program.  The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work.  This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+  You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force.  You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright.  Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+  Conveying under any other circumstances is permitted solely under
+the conditions stated below.  Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+  3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+  No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+  When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+  4. Conveying Verbatim Copies.
+
+  You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+  You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+  5. Conveying Modified Source Versions.
+
+  You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+    a) The work must carry prominent notices stating that you modified
+    it, and giving a relevant date.
+
+    b) The work must carry prominent notices stating that it is
+    released under this License and any conditions added under section
+    7.  This requirement modifies the requirement in section 4 to
+    "keep intact all notices".
+
+    c) You must license the entire work, as a whole, under this
+    License to anyone who comes into possession of a copy.  This
+    License will therefore apply, along with any applicable section 7
+    additional terms, to the whole of the work, and all its parts,
+    regardless of how they are packaged.  This License gives no
+    permission to license the work in any other way, but it does not
+    invalidate such permission if you have separately received it.
+
+    d) If the work has interactive user interfaces, each must display
+    Appropriate Legal Notices; however, if the Program has interactive
+    interfaces that do not display Appropriate Legal Notices, your
+    work need not make them do so.
+
+  A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit.  Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+  6. Conveying Non-Source Forms.
+
+  You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+    a) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by the
+    Corresponding Source fixed on a durable physical medium
+    customarily used for software interchange.
+
+    b) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by a
+    written offer, valid for at least three years and valid for as
+    long as you offer spare parts or customer support for that product
+    model, to give anyone who possesses the object code either (1) a
+    copy of the Corresponding Source for all the software in the
+    product that is covered by this License, on a durable physical
+    medium customarily used for software interchange, for a price no
+    more than your reasonable cost of physically performing this
+    conveying of source, or (2) access to copy the
+    Corresponding Source from a network server at no charge.
+
+    c) Convey individual copies of the object code with a copy of the
+    written offer to provide the Corresponding Source.  This
+    alternative is allowed only occasionally and noncommercially, and
+    only if you received the object code with such an offer, in accord
+    with subsection 6b.
+
+    d) Convey the object code by offering access from a designated
+    place (gratis or for a charge), and offer equivalent access to the
+    Corresponding Source in the same way through the same place at no
+    further charge.  You need not require recipients to copy the
+    Corresponding Source along with the object code.  If the place to
+    copy the object code is a network server, the Corresponding Source
+    may be on a different server (operated by you or a third party)
+    that supports equivalent copying facilities, provided you maintain
+    clear directions next to the object code saying where to find the
+    Corresponding Source.  Regardless of what server hosts the
+    Corresponding Source, you remain obligated to ensure that it is
+    available for as long as needed to satisfy these requirements.
+
+    e) Convey the object code using peer-to-peer transmission, provided
+    you inform other peers where the object code and Corresponding
+    Source of the work are being offered to the general public at no
+    charge under subsection 6d.
+
+  A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+  A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling.  In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage.  For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product.  A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+  "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source.  The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+  If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information.  But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+  The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed.  Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+  Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+  7. Additional Terms.
+
+  "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law.  If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+  When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it.  (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.)  You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+  Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+    a) Disclaiming warranty or limiting liability differently from the
+    terms of sections 15 and 16 of this License; or
+
+    b) Requiring preservation of specified reasonable legal notices or
+    author attributions in that material or in the Appropriate Legal
+    Notices displayed by works containing it; or
+
+    c) Prohibiting misrepresentation of the origin of that material, or
+    requiring that modified versions of such material be marked in
+    reasonable ways as different from the original version; or
+
+    d) Limiting the use for publicity purposes of names of licensors or
+    authors of the material; or
+
+    e) Declining to grant rights under trademark law for use of some
+    trade names, trademarks, or service marks; or
+
+    f) Requiring indemnification of licensors and authors of that
+    material by anyone who conveys the material (or modified versions of
+    it) with contractual assumptions of liability to the recipient, for
+    any liability that these contractual assumptions directly impose on
+    those licensors and authors.
+
+  All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10.  If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term.  If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+  If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+  Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+  8. Termination.
+
+  You may not propagate or modify a covered work except as expressly
+provided under this License.  Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+  However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+  Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+  Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License.  If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+  9. Acceptance Not Required for Having Copies.
+
+  You are not required to accept this License in order to receive or
+run a copy of the Program.  Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance.  However,
+nothing other than this License grants you permission to propagate or
+modify any covered work.  These actions infringe copyright if you do
+not accept this License.  Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+  10. Automatic Licensing of Downstream Recipients.
+
+  Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License.  You are not responsible
+for enforcing compliance by third parties with this License.
+
+  An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations.  If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+  You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License.  For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+  11. Patents.
+
+  A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based.  The
+work thus licensed is called the contributor's "contributor version".
+
+  A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version.  For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+  Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+  In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement).  To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+  If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients.  "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+  If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+  A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License.  You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+  Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+  12. No Surrender of Others' Freedom.
+
+  If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all.  For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+  13. Use with the GNU Affero General Public License.
+
+  Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work.  The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+  14. Revised Versions of this License.
+
+  The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+  Each version is given a distinguishing version number.  If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation.  If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+  If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+  Later license versions may give you additional or different
+permissions.  However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+  15. Disclaimer of Warranty.
+
+  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. Limitation of Liability.
+
+  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+  17. Interpretation of Sections 15 and 16.
+
+  If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+                     END OF TERMS AND CONDITIONS
+
+            How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    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 3 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.
+
+    You should have received a copy of the GNU General Public License
+    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+  If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+    <program>  Copyright (C) <year>  <name of author>
+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+  You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+<http://www.gnu.org/licenses/>.
+
+  The GNU General Public License does not permit incorporating your program
+into proprietary programs.  If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library.  If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.  But first, please read
+<http://www.gnu.org/philosophy/why-not-lgpl.html>.

inst/NOTICE

@@ -0,0 +1,264 @@
+The shiny package inludes other open source software components. The following
+is a list of these components (full copies of the license agreements used by
+these components are included below):
+
+- jQuery
+- Bootstrap
+- jslider
+
+
+jQuery License
+----------------------------------------------------------------------   
+
+Copyright (c) 2012 jQuery Foundation and other contributors, 
+http://jquery.com/
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+
+Bootstrap License
+----------------------------------------------------------------------   
+
+                                 Apache License
+                           Version 2.0, January 2004
+                        http://www.apache.org/licenses/
+
+   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
+
+   1. Definitions.
+
+      "License" shall mean the terms and conditions for use, reproduction,
+      and distribution as defined by Sections 1 through 9 of this document.
+
+      "Licensor" shall mean the copyright owner or entity authorized by
+      the copyright owner that is granting the License.
+
+      "Legal Entity" shall mean the union of the acting entity and all
+      other entities that control, are controlled by, or are under common
+      control with that entity. For the purposes of this definition,
+      "control" means (i) the power, direct or indirect, to cause the
+      direction or management of such entity, whether by contract or
+      otherwise, or (ii) ownership of fifty percent (50%) or more of the
+      outstanding shares, or (iii) beneficial ownership of such entity.
+
+      "You" (or "Your") shall mean an individual or Legal Entity
+      exercising permissions granted by this License.
+
+      "Source" form shall mean the preferred form for making modifications,
+      including but not limited to software source code, documentation
+      source, and configuration files.
+
+      "Object" form shall mean any form resulting from mechanical
+      transformation or translation of a Source form, including but
+      not limited to compiled object code, generated documentation,
+      and conversions to other media types.
+
+      "Work" shall mean the work of authorship, whether in Source or
+      Object form, made available under the License, as indicated by a
+      copyright notice that is included in or attached to the work
+      (an example is provided in the Appendix below).
+
+      "Derivative Works" shall mean any work, whether in Source or Object
+      form, that is based on (or derived from) the Work and for which the
+      editorial revisions, annotations, elaborations, or other modifications
+      represent, as a whole, an original work of authorship. For the purposes
+      of this License, Derivative Works shall not include works that remain
+      separable from, or merely link (or bind by name) to the interfaces of,
+      the Work and Derivative Works thereof.
+
+      "Contribution" shall mean any work of authorship, including
+      the original version of the Work and any modifications or additions
+      to that Work or Derivative Works thereof, that is intentionally
+      submitted to Licensor for inclusion in the Work by the copyright owner
+      or by an individual or Legal Entity authorized to submit on behalf of
+      the copyright owner. For the purposes of this definition, "submitted"
+      means any form of electronic, verbal, or written communication sent
+      to the Licensor or its representatives, including but not limited to
+      communication on electronic mailing lists, source code control systems,
+      and issue tracking systems that are managed by, or on behalf of, the
+      Licensor for the purpose of discussing and improving the Work, but
+      excluding communication that is conspicuously marked or otherwise
+      designated in writing by the copyright owner as "Not a Contribution."
+
+      "Contributor" shall mean Licensor and any individual or Legal Entity
+      on behalf of whom a Contribution has been received by Licensor and
+      subsequently incorporated within the Work.
+
+   2. Grant of Copyright License. Subject to the terms and conditions of
+      this License, each Contributor hereby grants to You a perpetual,
+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+      copyright license to reproduce, prepare Derivative Works of,
+      publicly display, publicly perform, sublicense, and distribute the
+      Work and such Derivative Works in Source or Object form.
+
+   3. Grant of Patent License. Subject to the terms and conditions of
+      this License, each Contributor hereby grants to You a perpetual,
+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+      (except as stated in this section) patent license to make, have made,
+      use, offer to sell, sell, import, and otherwise transfer the Work,
+      where such license applies only to those patent claims licensable
+      by such Contributor that are necessarily infringed by their
+      Contribution(s) alone or by combination of their Contribution(s)
+      with the Work to which such Contribution(s) was submitted. If You
+      institute patent litigation against any entity (including a
+      cross-claim or counterclaim in a lawsuit) alleging that the Work
+      or a Contribution incorporated within the Work constitutes direct
+      or contributory patent infringement, then any patent licenses
+      granted to You under this License for that Work shall terminate
+      as of the date such litigation is filed.
+
+   4. Redistribution. You may reproduce and distribute copies of the
+      Work or Derivative Works thereof in any medium, with or without
+      modifications, and in Source or Object form, provided that You
+      meet the following conditions:
+
+      (a) You must give any other recipients of the Work or
+          Derivative Works a copy of this License; and
+
+      (b) You must cause any modified files to carry prominent notices
+          stating that You changed the files; and
+
+      (c) You must retain, in the Source form of any Derivative Works
+          that You distribute, all copyright, patent, trademark, and
+          attribution notices from the Source form of the Work,
+          excluding those notices that do not pertain to any part of
+          the Derivative Works; and
+
+      (d) If the Work includes a "NOTICE" text file as part of its
+          distribution, then any Derivative Works that You distribute must
+          include a readable copy of the attribution notices contained
+          within such NOTICE file, excluding those notices that do not
+          pertain to any part of the Derivative Works, in at least one
+          of the following places: within a NOTICE text file distributed
+          as part of the Derivative Works; within the Source form or
+          documentation, if provided along with the Derivative Works; or,
+          within a display generated by the Derivative Works, if and
+          wherever such third-party notices normally appear. The contents
+          of the NOTICE file are for informational purposes only and
+          do not modify the License. You may add Your own attribution
+          notices within Derivative Works that You distribute, alongside
+          or as an addendum to the NOTICE text from the Work, provided
+          that such additional attribution notices cannot be construed
+          as modifying the License.
+
+      You may add Your own copyright statement to Your modifications and
+      may provide additional or different license terms and conditions
+      for use, reproduction, or distribution of Your modifications, or
+      for any such Derivative Works as a whole, provided Your use,
+      reproduction, and distribution of the Work otherwise complies with
+      the conditions stated in this License.
+
+   5. Submission of Contributions. Unless You explicitly state otherwise,
+      any Contribution intentionally submitted for inclusion in the Work
+      by You to the Licensor shall be under the terms and conditions of
+      this License, without any additional terms or conditions.
+      Notwithstanding the above, nothing herein shall supersede or modify
+      the terms of any separate license agreement you may have executed
+      with Licensor regarding such Contributions.
+
+   6. Trademarks. This License does not grant permission to use the trade
+      names, trademarks, service marks, or product names of the Licensor,
+      except as required for reasonable and customary use in describing the
+      origin of the Work and reproducing the content of the NOTICE file.
+
+   7. Disclaimer of Warranty. Unless required by applicable law or
+      agreed to in writing, Licensor provides the Work (and each
+      Contributor provides its Contributions) on an "AS IS" BASIS,
+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+      implied, including, without limitation, any warranties or conditions
+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
+      PARTICULAR PURPOSE. You are solely responsible for determining the
+      appropriateness of using or redistributing the Work and assume any
+      risks associated with Your exercise of permissions under this License.
+
+   8. Limitation of Liability. In no event and under no legal theory,
+      whether in tort (including negligence), contract, or otherwise,
+      unless required by applicable law (such as deliberate and grossly
+      negligent acts) or agreed to in writing, shall any Contributor be
+      liable to You for damages, including any direct, indirect, special,
+      incidental, or consequential damages of any character arising as a
+      result of this License or out of the use or inability to use the
+      Work (including but not limited to damages for loss of goodwill,
+      work stoppage, computer failure or malfunction, or any and all
+      other commercial damages or losses), even if such Contributor
+      has been advised of the possibility of such damages.
+
+   9. Accepting Warranty or Additional Liability. While redistributing
+      the Work or Derivative Works thereof, You may choose to offer,
+      and charge a fee for, acceptance of support, warranty, indemnity,
+      or other liability obligations and/or rights consistent with this
+      License. However, in accepting such obligations, You may act only
+      on Your own behalf and on Your sole responsibility, not on behalf
+      of any other Contributor, and only if You agree to indemnify,
+      defend, and hold each Contributor harmless for any liability
+      incurred by, or claims asserted against, such Contributor by reason
+      of your accepting any such warranty or additional liability.
+
+   END OF TERMS AND CONDITIONS
+
+   APPENDIX: How to apply the Apache License to your work.
+
+      To apply the Apache License to your work, attach the following
+      boilerplate notice, with the fields enclosed by brackets "[]"
+      replaced with your own identifying information. (Don't include
+      the brackets!)  The text should be enclosed in the appropriate
+      comment syntax for the file format. We also recommend that a
+      file or class name and description of purpose be included on the
+      same "printed page" as the copyright notice for easier
+      identification within third-party archives.
+
+   Copyright [yyyy] [name of copyright owner]
+
+   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.
+
+
+jslider License
+----------------------------------------------------------------------   
+
+The MIT License (MIT)
+Copyright (c) 2012 Egor Khmelev
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

inst/examples/01_hello/server.R

@@ -0,0 +1,20 @@
+library(shiny)
+
+# Define server logic required to generate and plot a random distribution
+shinyServer(function(input, output) {
+   
+  # Expression that generates a plot of the distribution. The expression
+  # is wrapped in a call to renderPlot to indicate that:
+  #
+  #  1) It is "reactive" and therefore should be automatically 
+  #     re-executed when inputs change
+  #  2) Its output type is a plot 
+  #
+  output$distPlot <- renderPlot({
+        
+    # generate an rnorm distribution and plot it
+    dist <- rnorm(input$obs)
+    hist(dist)
+  })
+  
+})

inst/examples/01_hello/ui.R

@@ -0,0 +1,22 @@
+library(shiny)
+
+# Define UI for application that plots random distributions 
+shinyUI(pageWithSidebar(
+  
+  # Application title
+  headerPanel("Hello Shiny!"),
+  
+  # Sidebar with a slider input for number of observations
+  sidebarPanel(
+    sliderInput("obs", 
+                "Number of observations:", 
+                min = 0, 
+                max = 1000, 
+                value = 500)
+  ),
+  
+  # Show a plot of the generated distribution
+  mainPanel(
+    plotOutput("distPlot")
+  )
+))

inst/examples/02_text/server.R

@@ -0,0 +1,25 @@
+library(shiny)
+library(datasets)
+
+# Define server logic required to summarize and view the selected dataset
+shinyServer(function(input, output) {
+  
+  # Return the requested dataset
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+  
+  # Generate a summary of the dataset
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+  
+  # Show the first "n" observations
+  output$view <- renderTable({
+    head(datasetInput(), n = input$obs)
+  })
+})

inst/examples/02_text/ui.R

@@ -0,0 +1,25 @@
+library(shiny)
+
+# Define UI for dataset viewer application
+shinyUI(pageWithSidebar(
+  
+  # Application title
+  headerPanel("Shiny Text"),
+  
+  # Sidebar with controls to select a dataset and specify the number
+  # of observations to view
+  sidebarPanel(
+    selectInput("dataset", "Choose a dataset:", 
+                choices = c("rock", "pressure", "cars")),
+    
+    numericInput("obs", "Number of observations to view:", 10)
+  ),
+  
+  # Show a summary of the dataset and an HTML table with the requested
+  # number of observations
+  mainPanel(
+    verbatimTextOutput("summary"),
+    
+    tableOutput("view")
+  )
+))

inst/examples/03_reactivity/server.R

@@ -0,0 +1,50 @@
+library(shiny)
+library(datasets)
+
+# Define server logic required to summarize and view the selected dataset
+shinyServer(function(input, output) {
+
+  # By declaring databaseInput as a reactive expression we ensure that:
+  #
+  #  1) It is only called when the inputs it depends on changes
+  #  2) The computation and result are shared by all the callers (it 
+  #     only executes a single time)
+  #  3) When the inputs change and the expression is re-executed, the
+  #     new result is compared to the previous result; if the two are
+  #     identical, then the callers are not notified
+  #
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+  
+  # The output$caption is computed based on a reactive expression that
+  # returns input$caption. When the user changes the "caption" field:
+  #
+  #  1) This function is automatically called to recompute the output 
+  #  2) The new caption is pushed back to the browser for re-display
+  # 
+  # Note that because the data-oriented reactive expressions below don't 
+  # depend on input$caption, those expressions are NOT called when 
+  # input$caption changes.
+  output$caption <- renderText({
+    input$caption
+  })
+  
+  # The output$summary depends on the datasetInput reactive expression, 
+  # so will be re-executed whenever datasetInput is re-executed 
+  # (i.e. whenever the input$dataset changes)
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+  
+  # The output$view depends on both the databaseInput reactive expression
+  # and input$obs, so will be re-executed whenever input$dataset or 
+  # input$obs is changed. 
+  output$view <- renderTable({
+    head(datasetInput(), n = input$obs)
+  })
+})

inst/examples/03_reactivity/ui.R

@@ -0,0 +1,32 @@
+library(shiny)
+
+# Define UI for dataset viewer application
+shinyUI(pageWithSidebar(
+  
+  # Application title
+  headerPanel("Reactivity"),
+  
+  # Sidebar with controls to provide a caption, select a dataset, and 
+  # specify the number of observations to view. Note that changes made
+  # to the caption in the textInput control are updated in the output
+  # area immediately as you type
+  sidebarPanel(
+    textInput("caption", "Caption:", "Data Summary"),
+    
+    selectInput("dataset", "Choose a dataset:", 
+                choices = c("rock", "pressure", "cars")),
+    
+    numericInput("obs", "Number of observations to view:", 10)
+  ),
+  
+  
+  # Show the caption, a summary of the dataset and an HTML table with
+  # the requested number of observations
+  mainPanel(
+    h3(textOutput("caption")), 
+    
+    verbatimTextOutput("summary"), 
+    
+    tableOutput("view")
+  )
+))

inst/examples/04_mpg/server.R

@@ -0,0 +1,32 @@
+library(shiny)
+library(datasets)
+
+# We tweak the "am" field to have nicer factor labels. Since this doesn't
+# rely on any user inputs we can do this once at startup and then use the
+# value throughout the lifetime of the application
+mpgData <- mtcars
+mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
+
+
+# Define server logic required to plot various variables against mpg
+shinyServer(function(input, output) {
+  
+  # Compute the forumla text in a reactive expression since it is 
+  # shared by the output$caption and output$mpgPlot functions
+  formulaText <- reactive({
+    paste("mpg ~", input$variable)
+  })
+   
+  # Return the formula text for printing as a caption
+  output$caption <- renderText({
+    formulaText()
+  })
+  
+  # Generate a plot of the requested variable against mpg and only 
+  # include outliers if requested
+  output$mpgPlot <- renderPlot({
+    boxplot(as.formula(formulaText()), 
+            data = mpgData,
+            outline = input$outliers)
+  })
+})

inst/examples/04_mpg/ui.R

@@ -0,0 +1,26 @@
+library(shiny)
+
+# Define UI for miles per gallon application
+shinyUI(pageWithSidebar(
+  
+  # Application title
+  headerPanel("Miles Per Gallon"),
+  
+  # Sidebar with controls to select the variable to plot against mpg
+  # and to specify whether outliers should be included
+  sidebarPanel(
+    selectInput("variable", "Variable:",
+                c("Cylinders" = "cyl",
+                  "Transmission" = "am",
+                  "Gears" = "gear")),
+
+    checkboxInput("outliers", "Show outliers", FALSE)
+  ),
+  
+  # Show the caption and plot of the requested variable against mpg
+  mainPanel(
+    h3(textOutput("caption")),
+    
+    plotOutput("mpgPlot")
+  )
+))

inst/examples/05_sliders/server.R

@@ -0,0 +1,28 @@
+library(shiny)
+
+# Define server logic for slider examples
+shinyServer(function(input, output) {
+  
+  # Reactive expression to compose a data frame containing all of the values
+  sliderValues <- reactive({
+    
+    # Compose data frame
+    data.frame(
+      Name = c("Integer", 
+               "Decimal",
+               "Range",
+               "Custom Format",
+               "Animation"),
+      Value = as.character(c(input$integer, 
+                             input$decimal,
+                             paste(input$range, collapse=' '),
+                             input$format,
+                             input$animation)), 
+      stringsAsFactors=FALSE)
+  }) 
+  
+  # Show the values using an HTML table
+  output$values <- renderTable({
+    sliderValues()
+  })
+})

inst/examples/05_sliders/ui.R

@@ -0,0 +1,37 @@
+library(shiny)
+
+# Define UI for slider demo application
+shinyUI(pageWithSidebar(
+  
+  #  Application title
+  headerPanel("Sliders"),
+  
+  # Sidebar with sliders that demonstrate various available options
+  sidebarPanel(
+    # Simple integer interval
+    sliderInput("integer", "Integer:", 
+                min=0, max=1000, value=500),
+    
+    # Decimal interval with step value
+    sliderInput("decimal", "Decimal:", 
+                min = 0, max = 1, value = 0.5, step= 0.1),
+   
+    # Specification of range within an interval
+    sliderInput("range", "Range:",
+                min = 1, max = 1000, value = c(200,500)),
+    
+    # Provide a custom currency format for value display, with basic animation
+    sliderInput("format", "Custom Format:", 
+                min = 0, max = 10000, value = 0, step = 2500,
+                format="$#,##0", locale="us", animate=TRUE),
+    
+    # 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=TRUE))
+  ),
+  
+  # Show a table summarizing the values entered
+  mainPanel(
+    tableOutput("values")
+  )
+))

inst/examples/06_tabsets/server.R

@@ -0,0 +1,42 @@
+library(shiny)
+
+# Define server logic for random distribution application
+shinyServer(function(input, output) {
+  
+  # Reactive expression to generate the requested distribution. This is 
+  # called whenever the inputs change. The output functions defined 
+  # below then all use the value computed from this expression
+  data <- reactive({
+    dist <- switch(input$dist,
+                   norm = rnorm,
+                   unif = runif,
+                   lnorm = rlnorm,
+                   exp = rexp,
+                   rnorm)
+    
+    dist(input$n)
+  })
+  
+  # Generate a plot of the data. Also uses the inputs to build the 
+  # plot label. Note that the dependencies on both the inputs and
+  # the data reactive expression are both tracked, and all expressions 
+  # are called in the sequence implied by the dependency graph
+  output$plot <- renderPlot({
+    dist <- input$dist
+    n <- input$n
+    
+    hist(data(), 
+         main=paste('r', dist, '(', n, ')', sep=''))
+  })
+  
+  # Generate a summary of the data
+  output$summary <- renderPrint({
+    summary(data())
+  })
+  
+  # Generate an HTML table view of the data
+  output$table <- renderTable({
+    data.frame(x=data())
+  })
+  
+})

inst/examples/06_tabsets/ui.R

@@ -0,0 +1,36 @@
+library(shiny)
+
+# Define UI for random distribution application 
+shinyUI(pageWithSidebar(
+    
+  # Application title
+  headerPanel("Tabsets"),
+  
+  # Sidebar with controls to select the random distribution type
+  # and number of observations to generate. Note the use of the br()
+  # element to introduce extra vertical spacing
+  sidebarPanel(
+    radioButtons("dist", "Distribution type:",
+                 c("Normal" = "norm",
+                   "Uniform" = "unif",
+                   "Log-normal" = "lnorm",
+                   "Exponential" = "exp")),
+    br(),
+    
+    sliderInput("n", 
+                "Number of observations:", 
+                 value = 500,
+                 min = 1, 
+                 max = 1000)
+  ),
+  
+  # Show a tabset that includes a plot, summary, and table view
+  # of the generated distribution
+  mainPanel(
+    tabsetPanel(
+      tabPanel("Plot", plotOutput("plot")), 
+      tabPanel("Summary", verbatimTextOutput("summary")), 
+      tabPanel("Table", tableOutput("table"))
+    )
+  )
+))

inst/examples/07_widgets/server.R

@@ -0,0 +1,25 @@
+library(shiny)
+library(datasets)
+
+# Define server logic required to summarize and view the selected dataset
+shinyServer(function(input, output) {
+  
+  # Return the requested dataset
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+  
+  # Generate a summary of the dataset
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+  
+  # Show the first "n" observations
+  output$view <- renderTable({
+    head(datasetInput(), n = input$obs)
+  })
+})

inst/examples/07_widgets/ui.R

@@ -0,0 +1,39 @@
+library(shiny)
+
+# Define UI for dataset viewer application
+shinyUI(pageWithSidebar(
+  
+  # Application title.
+  headerPanel("More Widgets"),
+  
+  # Sidebar with controls to select a dataset and specify the number
+  # of observations to view. The helpText function is also used to 
+  # include clarifying text. Most notably, the inclusion of a 
+  # submitButton defers the rendering of output until the user 
+  # explicitly clicks the button (rather than doing it immediately
+  # when inputs change). This is useful if the computations required
+  # to render output are inordinately time-consuming.
+  sidebarPanel(
+    selectInput("dataset", "Choose a dataset:", 
+                choices = c("rock", "pressure", "cars")),
+    
+    numericInput("obs", "Number of observations to view:", 10),
+    
+    helpText("Note: while the data view will show only the specified",
+             "number of observations, the summary will still be based",
+             "on the full dataset."),
+    
+    submitButton("Update View")
+  ),
+  
+  # Show a summary of the dataset and an HTML table with the requested
+  # number of observations. Note the use of the h4 function to provide
+  # an additional header above each output section.
+  mainPanel(
+    h4("Summary"),
+    verbatimTextOutput("summary"),
+    
+    h4("Observations"),
+    tableOutput("view")
+  )
+))

inst/examples/08_html/server.R

@@ -0,0 +1,42 @@
+library(shiny)
+
+# Define server logic for random distribution application
+shinyServer(function(input, output) {
+  
+  # Reactive expression to generate the requested distribution. This is 
+  # called whenever the inputs change. The output expressions defined 
+  # below then all used the value computed from this expression
+  data <- reactive({
+    dist <- switch(input$dist,
+                   norm = rnorm,
+                   unif = runif,
+                   lnorm = rlnorm,
+                   exp = rexp,
+                   rnorm)
+    
+    dist(input$n)
+  })
+  
+  # Generate a plot of the data. Also uses the inputs to build the 
+  # plot label. Note that the dependencies on both the inputs and
+  # the data reactive expression are both tracked, and all expressions 
+  # are called in the sequence implied by the dependency graph
+  output$plot <- renderPlot({
+    dist <- input$dist
+    n <- input$n
+    
+    hist(data(), 
+         main=paste('r', dist, '(', n, ')', sep=''))
+  })
+  
+  # Generate a summary of the data
+  output$summary <- renderPrint({
+    summary(data())
+  })
+  
+  # Generate an HTML table view of the data
+  output$table <- renderTable({
+    data.frame(x=data())
+  })
+  
+})

inst/examples/08_html/www/index.html

@@ -1,12 +1,15 @@
 <html>
-<head>
-  <script src="shared/jquery-1.7.2.js" type="text/javascript"></script>
-  <script src="shared/shiny.js" type="text/javascript"></script>
-  <link rel="stylesheet" type="text/css" href="shared/shiny.css"/>
-</head>
-<body>
-  <h1>Example 3: Distributions</h1>
 
+<head>
+  <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"/> 
+</head>
+ 
+<body>
+
+  <h1>HTML UI</h1>
+ 
   <p>
     <label>Distribution type:</label><br />
     <select name="dist">
@@ -14,17 +17,22 @@
       <option value="unif">Uniform</option>
       <option value="lnorm">Log-normal</option>
       <option value="exp">Exponential</option>
-    </select>
+    </select> 
   </p>
-
+ 
   <p>
-    <label>Number of observations:</label><br />
-    <input type="numeric" name="n" value="500" />
-  </p>
+ 
+    <label>Number of observations:</label><br /> 
+    <input type="number" name="n" value="500" min="1" max="1000" />
 
-  <div id="plot1" class="live-plot"></div>
+  </p>
+ 
+  <pre id="summary" class="shiny-text-output"></pre> 
   
-  <div id="table1" class="live-html"></div>
+  <div id="plot" class="shiny-plot-output" 
+       style="width: 100%; height: 400px"></div> 
   
+  <div id="table" class="shiny-html-output"></div>
+ 
 </body>
-</html>
+</html>

inst/examples/09_upload/server.R

@@ -0,0 +1,18 @@
+library(shiny)
+
+shinyServer(function(input, output) {
+  output$contents <- renderTable({
+    
+    # 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,19 @@
+shinyServer(function(input, output) {
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+  
+  output$table <- renderTable({
+    datasetInput()
+  })
+  
+  output$downloadData <- downloadHandler(
+    filename = function() { paste(input$dataset, '.csv', sep='') },
+    content = function(file) {
+      write.csv(datasetInput(), file)
+    }
+  )
+})

inst/examples/10_download/ui.R

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

inst/tests/test-bootstrap.r

@@ -0,0 +1,17 @@
+context("bootstrap")
+
+test_that("CSS unit validation", {
+  # On error, return NA; on success, return result
+  validateCssUnit_wrap <- function(x) {
+    tryCatch(validateCssUnit(x), error = function(e) { NA_character_ })
+  }
+
+  # Test strings and expected results
+  strings  <- c("100x", "10px", "10.4px", ".4px", "1px0", "px", "5", "%", "5%", "auto", "1auto", "") 
+  expected <- c(NA,     "10px", "10.4px", ".4px", NA,     NA,   NA,  NA,  "5%", "auto", NA,      NA)
+  results <- vapply(strings, validateCssUnit_wrap, character(1), USE.NAMES = FALSE)
+  expect_equal(results, expected)
+
+  # Numbers should return string with "px"
+  expect_equal(validateCssUnit(100), "100px")
+})

inst/tests/test-gc.r

@@ -0,0 +1,73 @@
+context("garbage collection")
+
+test_that("unreferenced observers are garbage collected", {
+  vals_removed <- FALSE
+  obs_removed  <- FALSE
+  vals <- reactiveValues(A=1)
+  obs  <- observe({ vals$A })
+
+  # These are called when the objects are garbage-collected
+  reg.finalizer(attr(.subset2(vals,'impl'), ".xData"),
+                function(e) vals_removed <<- TRUE)
+  reg.finalizer(attr(obs, ".xData"),
+                function(e) obs_removed  <<- TRUE)
+
+  flushReact()
+
+  # Removing this reference to obs doesn't delete it because vals still has a
+  # reference to it
+  rm(obs)
+  invisible(gc())
+  expect_equal(c(vals_removed, obs_removed), c(FALSE, FALSE))
+
+  # Updating vals$A and flushing won't make obs go away because it creates a new
+  # context, and vals$A's context tracks obs's context as a dependent
+  vals$A <- 2
+  flushReact()
+  invisible(gc())
+  expect_equal(c(vals_removed, obs_removed), c(FALSE, FALSE))
+
+  # Removing vals will result in vals and obs being garbage collected since
+  # there are no other references to them
+  rm(vals)
+  invisible(gc())
+  expect_equal(c(vals_removed, obs_removed), c(TRUE, TRUE))
+})
+
+
+test_that("suspended observers are garbage collected", {
+  vals_removed <- FALSE
+  obs_removed  <- FALSE
+  vals <- reactiveValues(A=1)
+  obs  <- observe({ vals$A })
+
+  # These are called when the objects are garbage-collected
+  reg.finalizer(attr(.subset2(vals,'impl'), ".xData"),
+                function(e) vals_removed <<- TRUE)
+  reg.finalizer(attr(obs, ".xData"),
+                function(e) obs_removed  <<- TRUE)
+
+  flushReact()
+
+  vals$A <- 2
+  flushReact()
+  invisible(gc())
+
+  # Simply suspending and removing our reference to obs doesn't result in GC,
+  # because vals's context still has a reference to obs's context, as a dependent
+  obs$suspend()
+  rm(obs)
+  invisible(gc())
+  expect_equal(c(vals_removed, obs_removed), c(FALSE, FALSE))
+
+  # Next time we update vals$A and flush, there's no more reference to obs
+  vals$A <- 3
+  flushReact()
+  invisible(gc())
+  expect_equal(c(vals_removed, obs_removed), c(FALSE, TRUE))
+
+  # Deleting vals should work immediately now
+  rm(vals)
+  invisible(gc())  # Removes vals object
+  expect_equal(c(vals_removed, obs_removed), c(TRUE, TRUE))
+})

inst/tests/test-reactivity.r

@@ -0,0 +1,652 @@
+context("reactivity")
+
+
+# Test for correct behavior of ReactiveValues
+test_that("ReactiveValues", {
+  # Creation and indexing into ReactiveValues -------------------------------
+  values <- reactiveValues()
+
+  # $ indexing
+  values$a <- 3
+  expect_equal(isolate(values$a), 3)
+
+  # [[ indexing
+  values[['a']] <- 4
+  expect_equal(isolate(values[['a']]), 4)
+
+  # Create with initialized values
+  values <- reactiveValues(a=1, b=2)
+  expect_equal(isolate(values$a), 1)
+  expect_equal(isolate(values[['b']]), 2)
+
+  # NULL values -------------------------------------------------------------
+  # Initializing with NULL value
+  values <- reactiveValues(a=NULL, b=2)
+  # a should exist and be NULL
+  expect_equal(isolate(names(values)), c("a", "b"))
+  expect_true(is.null(isolate(values$a)))
+
+  # Assigning NULL should keep object (not delete it), and set value to NULL
+  values$b <- NULL
+  expect_equal(isolate(names(values)), c("a", "b"))
+  expect_true(is.null(isolate(values$b)))
+
+
+  # Errors -----------------------------------------------------------------
+  # Error: indexing with non-string
+  expect_error(isolate(values[[1]]))
+  expect_error(isolate(values[[NULL]]))
+  expect_error(isolate(values[[list('a')]]))
+
+  # Error: [ indexing shouldn't work
+  expect_error(isolate(values['a']))
+  expect_error(isolate(values['a'] <- 1))
+
+  # Error: unnamed arguments
+  expect_error(reactiveValues(1))
+  expect_error(reactiveValues(1, b=2))
+
+  # Error: assignment to readonly values
+  values <- .createReactiveValues(ReactiveValues$new(), readonly = TRUE)
+  expect_error(values$a <- 1)
+})
+
+
+# Test for overreactivity. funcB has an indirect dependency on valueA (via
+# funcA) and also a direct dependency on valueA. When valueA changes, funcB
+# should only execute once.
+test_that("Functions are not over-reactive", {
+
+  values <- reactiveValues(A=10)
+
+  funcA <- reactive({
+    values$A
+  })
+
+  funcB <- reactive({
+    funcA()
+    values$A
+  })
+
+  obsC <- observe({
+    funcB()
+  })
+
+  flushReact()
+  expect_equal(execCount(funcB), 1)
+  expect_equal(execCount(obsC), 1)
+
+  values$A <- 11
+  flushReact()
+  expect_equal(execCount(funcB), 2)
+  expect_equal(execCount(obsC), 2)
+})
+
+## "foo => bar" is defined as "foo is a dependency of bar"
+##
+## vA => fB
+## (fB, vA) => obsE
+## (fB, vA) => obsF
+##
+## obsE and obsF should each execute once when vA changes.
+test_that("overreactivity2", {
+  # ----------------------------------------------
+  # Test 1
+  # B depends on A, and observer depends on A and B. The observer uses A and
+  # B, in that order.
+
+  # This is to store the value from observe()
+  observed_value1 <- NA
+  observed_value2 <- NA
+
+  values <- reactiveValues(A=1)
+  funcB  <- reactive({
+    values$A + 5
+  })
+  obsC <- observe({
+    observed_value1 <<-  funcB() * values$A
+  })
+  obsD <- observe({
+    observed_value2 <<-  funcB() * values$A
+  })
+
+  flushReact()
+  expect_equal(observed_value1, 6)   # Should be 1 * (1 + 5) = 6
+  expect_equal(observed_value2, 6)   # Should be 1 * (1 + 5) = 6
+  expect_equal(execCount(funcB), 1)
+  expect_equal(execCount(obsC), 1)
+  expect_equal(execCount(obsD), 1)
+
+  values$A <- 2
+  flushReact()
+  expect_equal(observed_value1, 14)  # Should be 2 * (2 + 5) = 14
+  expect_equal(observed_value2, 14)  # Should be 2 * (2 + 5) = 14
+  expect_equal(execCount(funcB), 2)
+  expect_equal(execCount(obsC), 2)
+  expect_equal(execCount(obsD), 2)
+})
+
+## Test for isolation. funcB depends on funcA depends on valueA. When funcA
+## is invalidated, if its new result is not different than its old result,
+## then it doesn't invalidate its dependents. This is done by adding an observer
+## (valueB) between obsA and funcC.
+##
+## valueA => obsB => valueC => funcD => obsE
+test_that("isolation", {
+  values <- reactiveValues(A=10, C=NULL)
+
+  obsB <- observe({
+    values$C <- values$A > 0
+  })
+
+  funcD <- reactive({
+    values$C
+  })
+
+  obsE <- observe({
+    funcD()
+  })
+
+  flushReact()
+  countD <- execCount(funcD)
+
+  values$A <- 11
+  flushReact()
+  expect_equal(execCount(funcD), countD)
+})
+
+
+## Test for laziness. With lazy evaluation, the observers should "pull" values
+## from their dependent functions. In contrast, eager evaluation would have
+## reactive values and functions "push" their changes down to their descendents.
+test_that("laziness", {
+
+  values <- reactiveValues(A=10)
+
+  funcA <- reactive({
+    values$A > 0
+  })
+
+  funcB <- reactive({
+    funcA()
+  })
+
+  obsC <- observe({
+    if (values$A > 10)
+      return()
+    funcB()
+  })
+
+  flushReact()
+  expect_equal(execCount(funcA), 1)
+  expect_equal(execCount(funcB), 1)
+  expect_equal(execCount(obsC), 1)
+
+  values$A <- 11
+  flushReact()
+  expect_equal(execCount(funcA), 1)
+  expect_equal(execCount(funcB), 1)
+  expect_equal(execCount(obsC), 2)
+})
+
+
+## Suppose B depends on A and C depends on A and B. Then when A is changed,
+## the evaluation order should be A, B, C. Also, each time A is changed, B and
+## C should be run once, if we want to be maximally efficient.
+test_that("order of evaluation", {
+  # ----------------------------------------------
+  # Test 1
+  # B depends on A, and observer depends on A and B. The observer uses A and
+  # B, in that order.
+
+  # This is to store the value from observe()
+  observed_value <- NA
+
+  values <- reactiveValues(A=1)
+  funcB  <- reactive({
+    values$A + 5
+  })
+  obsC <- observe({
+    observed_value <<- values$A * funcB()
+  })
+
+  flushReact()
+  expect_equal(observed_value, 6)   # Should be 1 * (1 + 5) = 6
+  expect_equal(execCount(funcB), 1)
+  expect_equal(execCount(obsC), 1)
+
+  values$A <- 2
+  flushReact()
+  expect_equal(observed_value, 14)  # Should be 2 * (2 + 5) = 14
+  expect_equal(execCount(funcB), 2)
+  expect_equal(execCount(obsC), 2)
+
+
+  # ----------------------------------------------
+  # Test 2:
+  # Same as Test 1, except the observer uses A and B in reversed order.
+  # Resulting values should be the same.
+
+  observed_value <- NA
+
+  values <- reactiveValues(A=1)
+  funcB <- reactive({
+    values$A + 5
+  })
+  obsC <- observe({
+    observed_value <<- funcB() * values$A
+  })
+
+  flushReact()
+  # Should be 1 * (1 + 5) = 6
+  expect_equal(observed_value, 6)
+  expect_equal(execCount(funcB), 1)
+  expect_equal(execCount(obsC), 1)
+
+  values$A <- 2
+  flushReact()
+  # Should be 2 * (2 + 5) = 14
+  expect_equal(observed_value, 14)
+  expect_equal(execCount(funcB), 2)
+  expect_equal(execCount(obsC), 2)
+})
+
+
+## Expressions in isolate() should not invalidate the parent context.
+test_that("isolate() blocks invalidations from propagating", {
+
+  obsC_value <- NA
+  obsD_value <- NA
+
+  values <- reactiveValues(A=1, B=10)
+  funcB <- reactive({
+    values$B + 100
+  })
+
+  # References to valueB and funcB are isolated
+  obsC <- observe({
+    obsC_value <<-
+      values$A + isolate(values$B) + isolate(funcB())
+  })
+
+  # In contrast with obsC, this has a non-isolated reference to funcB
+  obsD <- observe({
+    obsD_value <<-
+      values$A + isolate(values$B) + funcB()
+  })
+
+
+  flushReact()
+  expect_equal(obsC_value, 121)
+  expect_equal(execCount(obsC), 1)
+  expect_equal(obsD_value, 121)
+  expect_equal(execCount(obsD), 1)
+
+  # Changing A should invalidate obsC and obsD
+  values$A <- 2
+  flushReact()
+  expect_equal(obsC_value, 122)
+  expect_equal(execCount(obsC), 2)
+  expect_equal(obsD_value, 122)
+  expect_equal(execCount(obsD), 2)
+
+  # Changing B shouldn't invalidate obsC becuause references to B are in isolate()
+  # But it should invalidate obsD.
+  values$B <- 20
+  flushReact()
+  expect_equal(obsC_value, 122)
+  expect_equal(execCount(obsC), 2)
+  expect_equal(obsD_value, 142)
+  expect_equal(execCount(obsD), 3)
+
+  # Changing A should invalidate obsC and obsD, and they should see updated
+  # values for valueA, valueB, and funcB
+  values$A <- 3
+  flushReact()
+  expect_equal(obsC_value, 143)
+  expect_equal(execCount(obsC), 3)
+  expect_equal(obsD_value, 143)
+  expect_equal(execCount(obsD), 4)
+})
+
+
+test_that("isolate() evaluates expressions in calling environment", {
+  outside <- 1
+  inside <- 1
+  loc <- 1
+
+  outside <- isolate(2)      # Assignment outside isolate
+  isolate(inside <- 2)       # Assignment inside isolate
+  # Should affect vars in the calling environment
+  expect_equal(outside, 2)
+  expect_equal(inside, 2)
+
+  isolate(local(loc <<- 2))  # <<- inside isolate(local)
+  isolate(local(loc <- 3))   # <- inside isolate(local) - should have no effect
+  expect_equal(loc, 2)
+})
+
+
+test_that("Circular refs/reentrancy in reactive functions work", {
+
+  values <- reactiveValues(A=3)
+
+  funcB <- reactive({
+    # Each time fB executes, it reads and then writes valueA,
+    # effectively invalidating itself--until valueA becomes 0.
+    if (values$A == 0)
+      return()
+    values$A <- values$A - 1
+    return(values$A)
+  })
+
+  obsC <- observe({
+    funcB()
+  })
+
+  flushReact()
+  expect_equal(execCount(obsC), 4)
+
+  values$A <- 3
+
+  flushReact()
+  expect_equal(execCount(obsC), 8)
+
+})
+
+test_that("Simple recursion", {
+
+  values <- reactiveValues(A=5)
+  funcB <- reactive({
+    if (values$A == 0)
+      return(0)
+    values$A <- values$A - 1
+    funcB()
+  })
+
+  obsC <- observe({
+    funcB()
+  })
+
+  flushReact()
+  expect_equal(execCount(obsC), 2)
+  expect_equal(execCount(funcB), 6)
+})
+
+test_that("Non-reactive recursion", {
+  nonreactiveA <- 3
+  outputD <- NULL
+
+  funcB <- reactive({
+    if (nonreactiveA == 0)
+      return(0)
+    nonreactiveA <<- nonreactiveA - 1
+    return(funcB())
+  })
+  obsC <- observe({
+    outputD <<- funcB()
+  })
+
+  flushReact()
+  expect_equal(execCount(funcB), 4)
+  expect_equal(outputD, 0)
+})
+
+test_that("Circular dep with observer only", {
+
+  values <- reactiveValues(A=3)
+  obsB <- observe({
+    if (values$A == 0)
+      return()
+    values$A <- values$A - 1
+  })
+
+  flushReact()
+  expect_equal(execCount(obsB), 4)
+})
+
+test_that("Writing then reading value is not circular", {
+
+  values <- reactiveValues(A=3)
+  funcB <- reactive({
+    values$A <- isolate(values$A) - 1
+    values$A
+  })
+
+  obsC <- observe({
+    funcB()
+  })
+
+  flushReact()
+  expect_equal(execCount(obsC), 1)
+
+  values$A <- 10
+
+  flushReact()
+  expect_equal(execCount(obsC), 2)
+})
+
+test_that("names() and reactiveValuesToList()", {
+
+  values <- reactiveValues(A=1, .B=2)
+
+  # Dependent on names
+  depNames <- observe({
+    names(values)
+  })
+
+  # Dependent on all non-hidden objects
+  depValues <- observe({
+    reactiveValuesToList(values)
+  })
+
+  # Dependent on all objects, including hidden
+  depAllValues <- observe({
+    reactiveValuesToList(values, all.names = TRUE)
+  })
+
+  # names() returns all names
+  expect_equal(sort(isolate(names(values))), sort(c(".B", "A")))
+  # Assigning names fails
+  expect_error(isolate(names(v) <- c('x', 'y')))
+
+  expect_equal(isolate(reactiveValuesToList(values)), list(A=1))
+  expect_equal(isolate(reactiveValuesToList(values, all.names=TRUE)), list(A=1, .B=2))
+
+
+  flushReact()
+  expect_equal(execCount(depNames), 1)
+  expect_equal(execCount(depValues), 1)
+  expect_equal(execCount(depAllValues), 1)
+
+  # Update existing variable
+  values$A <- 2
+  flushReact()
+  expect_equal(execCount(depNames), 1)
+  expect_equal(execCount(depValues), 2)
+  expect_equal(execCount(depAllValues), 2)
+
+  # Update existing hidden variable
+  values$.B <- 3
+  flushReact()
+  expect_equal(execCount(depNames), 1)
+  expect_equal(execCount(depValues), 2)
+  expect_equal(execCount(depAllValues), 3)
+
+  # Add new variable
+  values$C <- 1
+  flushReact()
+  expect_equal(execCount(depNames), 2)
+  expect_equal(execCount(depValues), 3)
+  expect_equal(execCount(depAllValues), 4)
+
+  # Add new hidden variable
+  values$.D <- 1
+  flushReact()
+  expect_equal(execCount(depNames), 3)
+  expect_equal(execCount(depValues), 3)
+  expect_equal(execCount(depAllValues), 5)
+})
+
+test_that("Observer pausing works", {
+  values <- reactiveValues(a=1)
+  
+  funcA <- reactive({
+    values$a
+  })
+  
+  obsB <- observe({
+    funcA()
+  })
+  
+  # Important: suspend() only affects observer at invalidation time
+  
+  # Observers are invalidated at creation time, so it will run once regardless
+  # of being suspended
+  obsB$suspend()
+  flushReact()
+  expect_equal(execCount(funcA), 1)
+  expect_equal(execCount(obsB), 1)
+  
+  # When resuming, if nothing changed, don't do anything
+  obsB$resume()
+  flushReact()
+  expect_equal(execCount(funcA), 1)
+  expect_equal(execCount(obsB), 1)
+  
+  # Make sure suspended observers do not flush, but do invalidate
+  obsB_invalidated <- FALSE
+  obsB$onInvalidate(function() {obsB_invalidated <<- TRUE})
+  obsB$suspend()
+  values$a <- 2
+  flushReact()
+  expect_equal(obsB_invalidated, TRUE)
+  expect_equal(execCount(funcA), 1)
+  expect_equal(execCount(obsB), 1)
+  
+  obsB$resume()
+  values$a <- 2.5
+  obsB$suspend()
+  flushReact()
+  expect_equal(execCount(funcA), 2)
+  expect_equal(execCount(obsB), 2)
+  
+  values$a <- 3
+  flushReact()
+
+  expect_equal(execCount(funcA), 2)
+  expect_equal(execCount(obsB), 2)
+  
+  # If onInvalidate() is added _after_ obsB is suspended and the values$a
+  # changes, then it shouldn't get run (onInvalidate runs on invalidation, not
+  # on flush)
+  values$a <- 4
+  obsB_invalidated2 <- FALSE
+  obsB$onInvalidate(function() {obsB_invalidated2 <<- TRUE})
+  obsB$resume()
+  flushReact()
+
+  expect_equal(execCount(funcA), 3)
+  expect_equal(execCount(obsB), 3)
+  expect_equal(obsB_invalidated2, FALSE)
+})
+
+test_that("suspended/resumed observers run at most once", {
+
+  values <- reactiveValues(A=1)
+  obs <- observe(function() {
+    values$A
+  })
+  expect_equal(execCount(obs), 0)
+  
+  # First flush should run obs once
+  flushReact()
+  expect_equal(execCount(obs), 1)
+
+  # Modify the dependency at each stage of suspend/resume/flush should still
+  # only result in one run of obs()
+  values$A <- 2
+  obs$suspend()
+  values$A <- 3
+  obs$resume()
+  values$A <- 4
+  flushReact()
+  expect_equal(execCount(obs), 2)
+
+})
+
+
+test_that("reactive() accepts quoted and unquoted expressions", {
+  vals <- reactiveValues(A=1)
+
+  # Unquoted expression, with curly braces
+  fun <- reactive({ vals$A + 1 })
+  expect_equal(isolate(fun()), 2)
+
+  # Unquoted expression, no curly braces
+  fun <- reactive(vals$A + 1)
+  expect_equal(isolate(fun()), 2)
+
+  # Quoted expression
+  fun <- reactive(quote(vals$A + 1), quoted = TRUE)
+  expect_equal(isolate(fun()), 2)
+
+  # Quoted expression, saved in a variable
+  q_expr <- quote(vals$A + 1)
+  fun <- reactive(q_expr, quoted = TRUE)
+  expect_equal(isolate(fun()), 2)
+
+  # If function is used, work, but print message
+  expect_message(fun <- reactive(function() { vals$A + 1 }))
+  expect_equal(isolate(fun()), 2)
+
+
+  # Check that environment is correct - parent environment should be this one
+  this_env <- environment()
+  fun <- reactive(environment())
+  expect_identical(isolate(parent.env(fun())), this_env)
+
+  # Sanity check: environment structure for a reactive() should be the same as for
+  # a normal function
+  fun <- function() environment()
+  expect_identical(parent.env(fun()), this_env)
+})
+
+test_that("observe() accepts quoted and unquoted expressions", {
+  vals <- reactiveValues(A=0)
+  valB <- 0
+
+  # Unquoted expression, with curly braces
+  observe({ valB <<- vals$A + 1})
+  flushReact()
+  expect_equal(valB, 1)
+
+  # Unquoted expression, no curly braces
+  observe({ valB <<- vals$A + 2})
+  flushReact()
+  expect_equal(valB, 2)
+
+  # Quoted expression
+  observe(quote(valB <<- vals$A + 3), quoted = TRUE)
+  flushReact()
+  expect_equal(valB, 3)
+
+  # Quoted expression, saved in a variable
+  q_expr <- quote(valB <<- vals$A + 4)
+  fun <- observe(q_expr, quoted = TRUE)
+  flushReact()
+  expect_equal(valB, 4)
+
+  # If function is used, work, but print message
+  expect_message(observe(function() { valB <<- vals$A + 5 }))
+  flushReact()
+  expect_equal(valB, 5)
+
+
+  # Check that environment is correct - parent environment should be this one
+  this_env <- environment()
+  inside_env <- NULL
+  fun <- observe(inside_env <<- environment())
+  flushReact()
+  expect_identical(parent.env(inside_env), this_env)
+})

inst/tests/test-tags.r

@@ -0,0 +1,23 @@
+context("tags")
+
+test_that("Basic tag writing works", {
+  expect_equal(as.character(tagList("hi")), HTML("hi"))
+  expect_equal(
+    as.character(tagList("one", "two", tagList("three"))),
+    HTML("one\ntwo\nthree"))
+  expect_equal(
+    as.character(tags$b("one")),
+    HTML("<b>one</b>"))
+  expect_equal(
+    as.character(tags$b("one", "two")),
+    HTML("<b>\n  one\n  two\n</b>"))
+  expect_equal(
+    as.character(tagList(list("one"))),
+    HTML("one"))
+  expect_equal(
+    as.character(tagList(list(tagList("one")))),
+    HTML("one"))
+  expect_equal(
+    as.character(tagList(tags$br(), "one")),
+    HTML("<br/>\none"))
+})

inst/tests/test-text.R

@@ -0,0 +1,56 @@
+context("text")
+
+test_that("renderPrint and renderText behavior is correct", {
+  expect_equal(isolate(renderPrint({ "foo" })()),
+               '[1] "foo"')
+  expect_equal(isolate(renderPrint({ invisible("foo") })()),
+               '')
+  expect_equal(isolate(renderPrint({ print("foo"); "bar"})()),
+               '[1] "foo"\n[1] "bar"')
+  expect_equal(isolate(renderPrint({ NULL })()),
+               'NULL')
+  expect_equal(isolate(renderPrint({ invisible() })()),
+               '')
+  expect_equal(isolate(renderPrint({ 1:5 })()),
+               '[1] 1 2 3 4 5')
+  
+  expect_equal(isolate(renderText({ "foo" })()),
+               'foo')
+  expect_equal(isolate(renderText({ invisible("foo") })()),
+               'foo')
+  # Capture the print output so it's not shown on console during test, and
+  # also check that it is correct
+  print_out <- capture.output(ret <- isolate(renderText({ print("foo"); "bar"})()))
+  expect_equal(ret, 'bar')
+  expect_equal(print_out, '[1] "foo"')
+  expect_equal(isolate(renderText({ NULL })()),
+               '')
+  expect_equal(isolate(renderText({ invisible() })()),
+               '')
+  expect_equal(isolate(renderText({ 1:5 })()),
+               '1 2 3 4 5')  
+})
+
+test_that("reactive functions save visibility state", {
+  # Call each function twice - should be no change in state with second call
+
+  # invisible NULL
+  f <- reactive({ invisible() })
+  expect_identical(withVisible(isolate(f())), list(value=NULL, visible=FALSE))
+  expect_identical(withVisible(isolate(f())), list(value=NULL, visible=FALSE))
+
+  # visible NULL
+  f <- reactive({ NULL })
+  expect_identical(withVisible(isolate(f())), list(value=NULL, visible=TRUE))
+  expect_identical(withVisible(isolate(f())), list(value=NULL, visible=TRUE))
+
+  # invisible non-NULL value
+  f <- reactive({ invisible(10)})
+  expect_identical(withVisible(isolate(f())), list(value=10, visible=FALSE))
+  expect_identical(withVisible(isolate(f())), list(value=10, visible=FALSE))
+
+  # visible non-NULL value
+  f <- reactive({ 10 })
+  expect_identical(withVisible(isolate(f())), list(value=10, visible=TRUE))
+  expect_identical(withVisible(isolate(f())), list(value=10, visible=TRUE))
+})

inst/www/index.html

@@ -0,0 +1,12 @@
+<!DOCTYPE html>
+<html>
+<head></head>
+<body>
+  <h1>No UI defined</h1>
+  <p>Shiny couldn't find any UI for this application. We looked in:</p>
+  <ul>
+    <li><code>www/index.html</code></li>
+    <li><code>ui.R</code></li>
+  </ul>
+</body>
+</html>

inst/www/shared/shiny.css

@@ -0,0 +1,60 @@
+body.disconnected {
+  background-color: #999;
+  opacity: 0.5;
+}
+
+table.data {
+  width: auto;
+}
+table.data td[align=right] {
+  font-family: monospace;
+  text-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 */
+  margin-top: 18px;
+}
+.jslider-value {
+  /* Remove box around jslider values on colored bg */
+  background-color: transparent !important;
+}
+
+.recalculating {
+  opacity: 0.3;
+  transition: opacity 250ms ease 500ms;
+  -moz-transition: opacity 250ms ease 500ms;
+  -webkit-transition: opacity 250ms ease 500ms;
+  -o-transition: opacity 250ms ease 500ms;
+}
+
+span.jslider {
+  margin-bottom: 12px;
+}
+.slider-animate-container {
+  text-align: right;
+  margin-top: -9px;
+}
+.slider-animate-button {
+  opacity: 0.5;
+}
+.slider-animate-button .pause {
+  display: none;
+}
+.slider-animate-button.playing .pause {
+  display: inline;
+}
+.slider-animate-button .play {
+  display: inline;
+}
+.slider-animate-button.playing .play {
+  display: none;
+}

inst/www/shared/slider/css/jquery.slider.min.css

@@ -0,0 +1 @@
+.jslider .jslider-bg i,.jslider .jslider-pointer{background:url(../img/jslider.png) no-repeat 0 0}.jslider{display:block;width:100%;height:1em;position:relative;top:.6em;font-family:Arial,sans-serif}.jslider table{width:100%;border-collapse:collapse;border:0}.jslider td,.jslider th{padding:0;vertical-align:top;text-align:left;border:0}.jslider table,.jslider table tr,.jslider table tr td{width:100%;vertical-align:top}.jslider .jslider-bg{position:relative}.jslider .jslider-bg i{height:5px;position:absolute;font-size:0;top:0}.jslider .jslider-bg .l{width:50%;background-position:0 0;left:0}.jslider .jslider-bg .r{width:50%;left:50%;background-position:right 0}.jslider .jslider-bg .v{position:absolute;width:60%;left:20%;top:0;height:5px;background-position:0 -20px}.jslider .jslider-pointer{width:13px;height:15px;background-position:0 -40px;position:absolute;left:20%;top:-4px;margin-left:-6px;cursor:pointer;cursor:hand}.jslider .jslider-pointer-hover{background-position:-20px -40px}.jslider .jslider-pointer-to{left:80%}.jslider .jslider-label{font-size:9px;line-height:12px;color:black;opacity:.4;white-space:nowrap;padding:0 2px;position:absolute;top:-18px;left:0}.jslider .jslider-label-to{left:auto;right:0}.jslider .jslider-value{font-size:9px;white-space:nowrap;padding:1px 2px 0;position:absolute;top:-19px;left:20%;background:white;line-height:12px;-moz-border-radius:2px;-webkit-border-radius:2px;-o-border-radius:2px;border-radius:2px}.jslider .jslider-value-to{left:80%}.jslider .jslider-label small,.jslider .jslider-value small{position:relative;top:-0.4em}.jslider .jslider-scale{position:relative;top:9px}.jslider .jslider-scale span{position:absolute;height:5px;border-left:1px solid #999;font-size:0}.jslider .jslider-scale ins{font-size:9px;text-decoration:none;position:absolute;left:0;top:5px;color:#999}.jslider-single .jslider-pointer-to,.jslider-single .jslider-value-to,.jslider-single .jslider-bg .v,.jslider-limitless .jslider-label{display:none}.jslider_blue .jslider-bg i,.jslider_blue .jslider-pointer{background-image:url(../img/jslider.blue.png)}.jslider_plastic .jslider-bg i,.jslider_plastic .jslider-pointer{background-image:url(../img/jslider.plastic.png)}.jslider_round .jslider-bg i,.jslider_round .jslider-pointer{background-image:url(../img/jslider.round.png)}.jslider_round .jslider-pointer{width:17px;height:17px;top:-6px;margin-left:-8px}.jslider_round_plastic .jslider-bg i,.jslider_round_plastic .jslider-pointer{background-image:url(../img/jslider.round.plastic.png)}.jslider_round_plastic .jslider-pointer{width:18px;height:18px;top:-7px;margin-left:-8px}

lib/react.rb

@@ -1,172 +0,0 @@
-module React
-
-  class Context
-
-    private
-
-      @@next_id = 0
-      @@current_context = nil
-      @@pending_invalidate = []
-
-    public
-
-      def self.current!
-        return current || raise("No current context")
-      end
-
-      def self.current
-        @@current_context
-      end
-
-      attr_reader :id
-
-      def initialize
-        # The ID can used to identify/sort/dedupe contexts
-        @id = @@next_id += 1
-
-        # Indicates whether this context is invalidated, i.e. its
-        # callbacks have been called or are about to be called
-        @invalidated = false
-
-        # List of callbacks to be called after invalidation
-        @callbacks = []
-      end
-
-      # Run a block with this context as the current context. The
-      # original current context will be restored after the block
-      # is executed.
-      def run
-        old_ctx = @@current_context
-        @@current_context = self
-        begin
-          return yield
-        ensure
-          @@current_context = old_ctx
-        end
-      end
-
-      def invalidate
-        return if @invalidated
-
-        @invalidated = true
-        @@pending_invalidate << self
-      end
-
-      # Register a callback to be called after this context is
-      # invalidated (or immediately if it's already invalidated).
-      # The callback takes one argument, the context.
-      def on_invalidate(&callback)
-        if @invalidated
-          callback.call(self)
-        else
-          @callbacks << callback
-        end
-      end
-
-      def execute_callbacks
-        @callbacks.each {|callback| callback.call(self)}
-      end
-
-      # Execute all callbacks on invalidated contexts. Will do this
-      # repeatedly if the callbacks themselves cause more invalidations.
-      def self.flush
-        while !@@pending_invalidate.empty?
-          contexts = @@pending_invalidate
-          @@pending_invalidate = []
-
-          contexts.each {|context| context.execute_callbacks}
-        end
-      end
-  end
-
-  class Session
-    def initialize
-      # Key is variable name, value is variable value
-      @values = Hash.new
-      # Key is variable name, value is { Context IDs => Contexts }
-      @dependencies = Hash.new
-    end
-
-    def get(name)
-      cur_ctx = React::Context.current!
-      @dependencies[name] = @dependencies[name] || Hash.new
-      if !@dependencies[name].has_key?(cur_ctx.id)
-        @dependencies[name][cur_ctx.id] = cur_ctx
-        cur_ctx.on_invalidate do
-          @dependencies[name].delete(cur_ctx.id)
-        end
-      end
-
-      return @values[name]
-    end
-
-    def set(name, value)
-      if @values.has_key?(name) && @values[name] == value
-        return
-      end
-
-      @values[name] = value
-      if @dependencies[name]
-        @dependencies[name].each_value {|ctx| ctx.invalidate}
-      end
-    end
-  end
-
-  # Stores (and caches) a single dependent value in a context
-  class ObservableValue
-    def initialize(&valueProc)
-      @valueProc = valueProc
-      
-      @dependencies = Hash.new
-      @initialized = false
-    end
-
-    def value
-      if !@initialized
-        @initialized = true
-        update_value
-      end
-
-      cur_ctx = React::Context.current!
-      @dependencies[cur_ctx.id] = cur_ctx
-      cur_ctx.on_invalidate do
-        @dependencies.delete cur_ctx.id
-      end
-      @value
-    end
-
-    private
-      def update_value
-        old_value = @value
-  
-        ctx = Context.new
-        ctx.on_invalidate do
-          update_value
-        end
-        ctx.run do
-          @value = @valueProc.call
-        end
-
-        if old_value != @value
-          @dependencies.each_value {|dep_ctx| dep_ctx.invalidate}
-        end
-      end
-  end
-
-  # Runs the given proc whenever its dependencies change
-  class Observer
-    def initialize(&proc)
-      @proc = proc
-      run
-    end
-
-    def run
-      ctx = React::Context.new
-      ctx.on_invalidate do
-        run
-      end
-      ctx.run &@proc
-    end
-  end
-
-end

lib/shiny.rb

@@ -1,156 +0,0 @@
-require 'eventmachine'
-require 'evma_httpserver'
-require 'em-websocket'
-require 'pathname'
-require 'json'
-require 'react'
-
-
-class WebServer < EM::Connection
-  include EM::HttpServer
-
-  def post_init
-    super
-    no_environment_strings
-
-    @basepath = File.join(Dir.pwd, 'www')
-  end
-
-  def resolve_path(path)
-    # It's not a valid path if it doesn't start with /
-    return nil if path !~ /^\//
-
-    abspath = File.join(@basepath, "./#{path}")
-    # Resolves '..', etc.
-    abspath = Pathname.new(abspath).cleanpath.to_s
-
-    return false if abspath[0...(@basepath.size + 1)] != @basepath + '/'
-    return false if !File.exist?(abspath)
-
-    return abspath
-  end
-
-  def process_http_request
-    # the http request details are available via the following instance variables:
-    #   @http_protocol
-    #   @http_request_method
-    #   @http_cookie
-    #   @http_if_none_match
-    #   @http_content_type
-    #   @http_path_info
-    #   @http_request_uri
-    #   @http_query_string
-    #   @http_post_content
-    #   @http_headers
-
-    response = EM::DelegatedHttpResponse.new(self)
-
-    path = @http_path_info
-    path = '/index.html' if path == '/'
-
-    resolved_path = resolve_path(path)
-
-    if !resolved_path
-      response.status = 404
-      response.content_type 'text/html'
-      response.content = '<h1>404 Not Found</h1>'
-    else
-      response.status = 200
-      response.content_type case resolved_path
-      when /\.html?$/
-        'text/html'
-      when /\.js$/
-        'text/javascript'
-      when /\.css$/
-        'text/css'
-      when /\.png$/
-        'image/png'
-      when /\.jpg$/
-        'image/jpeg'
-      when /\.gif$/
-        'image/gif'
-      end
-      response.content = File.read(resolved_path)
-    end
-    response.send_response
-  end
-end
-
-def run_shiny_app(shinyapp)
-  EventMachine.run do
-    EventMachine.start_server '0.0.0.0', 8100, WebServer
-    puts "Listening on port 8100"
-    
-    EventMachine::WebSocket.start(:host => '0.0.0.0', :port => 8101) do |ws|
-      shinyapp.websocket = ws
-      ws.onclose { exit(0) }
-      ws.onmessage do |msg|
-        begin
-          puts "RECV: #{msg}"
-
-          msg_obj = JSON.parse(msg)
-          case msg_obj['method']
-          when 'init'
-            msg_obj['data'].each do |k, v|
-              shinyapp.session.set(k, v)
-            end
-            React::Context.flush
-            shinyapp.instantiate_outputs
-          when 'update'
-            msg_obj['data'].each do |k, v|
-              shinyapp.session.set(k, v)
-            end
-          end
-
-          React::Context.flush
-          shinyapp.flush_output
-        rescue Exception => e
-          puts "ERROR: #{e}"
-          puts e.backtrace.collect {|x| "\t#{x}"}
-          raise
-        end
-      end
-    end
-  end
-end
-
-class ShinyApp
-  attr_reader :session
-
-  def initialize
-    @session = React::Session.new
-    @outputs = {}
-    @invalidated_output_values = Hash.new
-  end
-
-  def websocket=(value)
-    @websocket = value
-  end
-
-  def define_output(name, &proc)
-    @outputs[name] = proc
-  end
-
-  def instantiate_outputs
-    @outputs.keys.each do |name|
-      proc = @outputs.delete(name)
-      React::Observer.new do
-        value = proc.call
-        @invalidated_output_values[name] = value
-      end
-    end
-  end
-
-  def flush_output
-    return if @invalidated_output_values.empty?
-
-    data = @invalidated_output_values
-    @invalidated_output_values = Hash.new
-    puts "SEND: #{JSON.generate(data)}"
-    @websocket.send(JSON.generate(data))
-  end
-
-  def run
-    run_shiny_app self
-  end
-end

man/HTML.Rd

@@ -0,0 +1,24 @@
+\name{HTML}
+\alias{HTML}
+\title{Mark Characters as HTML}
+\usage{
+  HTML(text, ...)
+}
+\arguments{
+  \item{text}{The text value to mark with HTML}
+
+  \item{...}{Any additional values to be converted to
+  character and concatenated together}
+}
+\value{
+  The same value, but marked as HTML.
+}
+\description{
+  Marks the given text as HTML, which means the \link{tag}
+  functions will know not to perform HTML escaping on it.
+}
+\examples{
+el <- div(HTML("I like <u>turtles</u>"))
+cat(as.character(el))
+}
+

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

@@ -0,0 +1,28 @@
+\name{animationOptions}
+\alias{animationOptions}
+\title{Animation Options}
+\usage{
+  animationOptions(interval = 1000, loop = FALSE,
+    playButton = NULL, pauseButton = NULL)
+}
+\arguments{
+  \item{interval}{The interval, in milliseconds, between
+  each animation step.}
+
+  \item{loop}{\code{TRUE} to automatically restart the
+  animation when it reaches the end.}
+
+  \item{playButton}{Specifies the appearance of the play
+  button. Valid values are a one-element character vector
+  (for a simple text label), an HTML tag or list of tags
+  (using \code{\link{tag}} and friends), or raw HTML (using
+  \code{\link{HTML}}).}
+
+  \item{pauseButton}{Similar to \code{playButton}, but for
+  the pause button.}
+}
+\description{
+  Creates an options object for customizing animations for
+  \link{sliderInput}.
+}
+

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

@@ -0,0 +1,79 @@
+\name{builder}
+\alias{p}
+\alias{h1}
+\alias{h2}
+\alias{h3}
+\alias{h4}
+\alias{h5}
+\alias{h6}
+\alias{a}
+\alias{br}
+\alias{div}
+\alias{span}
+\alias{pre}
+\alias{code}
+\alias{img}
+\alias{strong}
+\alias{em}
+\alias{tags}
+
+\usage{
+  p(...)
+  h1(...)
+  h2(...)
+  h3(...)
+  h4(...)
+  h5(...)
+  h6(...)
+  a(...)
+  br(...)
+  div(...)
+  span(...)
+  pre(...)
+  code(...)
+  img(...)
+  strong(...)
+  em(...)
+  
+  tags
+}
+
+\title{HTML Builder Functions}
+
+\arguments{
+  \item{...}{Attributes and children of the element. Named arguments
+  become attributes, and positional arguments 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.}
+}
+\description{
+  Simple functions for constructing HTML documents.
+}
+\details{
+  The \code{tags} environment contains convenience functions for all
+  valid HTML5 tags. To generate tags that are not part of the HTML5
+  specification, you can use the \link{tag} function.
+  
+  Dedicated functions are available for the most common HTML tags
+  that do not conflict with common R functions.
+  
+  The result from these functions is a tag object, which can be
+  converted using \code{as.character}.
+}
+\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/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

@@ -0,0 +1,29 @@
+\name{checkboxInput}
+\alias{checkboxInput}
+\title{Checkbox Input Control}
+\usage{
+  checkboxInput(inputId, label, value = FALSE)
+}
+\arguments{
+  \item{inputId}{Input variable to assign the control's
+  value to.}
+
+  \item{label}{Display label for the control.}
+
+  \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.
+}
+\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{file} that is a file path (string) of a nonexistent
+  temp file, and writes the content to that file path.
+  (Reactive values and functions may be used from this
+  function.)}
+
+  \item{contentType}{A string of the download's
+  \href{http://en.wikipedia.org/wiki/Internet_media_type}{content
+  type}, for example \code{"text/csv"} or
+  \code{"image/png"}. If \code{NULL} or \code{NA}, the
+  content type will be guessed based on the filename
+  extension, or \code{application/octet-stream} if the
+  extension is unknown.}
+}
+\description{
+  Allows content from the Shiny application to be made
+  available to the user as file downloads (for example,
+  downloading the currently visible data as a CSV file).
+  Both filename and contents can be calculated dynamically
+  at the time the user initiates the download. Assign the
+  return value to a slot on \code{output} in your server
+  function, and in the UI use \code{\link{downloadButton}}
+  or \code{\link{downloadLink}} to make the download
+  available.
+}
+\examples{
+\dontrun{
+# In server.R:
+output$downloadData <- downloadHandler(
+  filename = function() {
+    paste('data-', Sys.Date(), '.csv', sep='')
+  },
+  content = function(file) {
+    write.csv(data, file)
+  }
+)
+
+# In ui.R:
+downloadLink('downloadData', 'Download')
+}
+}
+

man/exprToFunction.Rd

@@ -0,0 +1,63 @@
+\name{exprToFunction}
+\alias{exprToFunction}
+\title{Convert an expression or quoted expression to a function}
+\usage{
+  exprToFunction(expr, env = parent.frame(2),
+    quoted = FALSE)
+}
+\arguments{
+  \item{expr}{A quoted or unquoted expression, or a
+  function.}
+
+  \item{env}{The desired environment for the function.
+  Defaults to the calling environment two steps back.}
+
+  \item{quoted}{Is the expression quoted?}
+}
+\description{
+  This is to be called from another function, because it
+  will attempt to get an unquoted expression from two calls
+  back.
+}
+\details{
+  If expr is a quoted expression, then this just converts
+  it to a function. If expr is a function, then this simply
+  returns expr (and prints a deprecation message. If expr
+  was a non-quoted expression from two calls back, then
+  this will quote the original expression and convert it to
+  a function.
+}
+\examples{
+# Example of a new renderer, similar to renderText
+# This is something that toolkit authors will do
+renderTriple <- function(expr, env=parent.frame(), quoted=FALSE) {
+  # Convert expr to a function
+  func <- shiny::exprToFunction(expr, env, quoted)
+
+  function() {
+    value <- func()
+    paste(rep(value, 3), collapse=", ")
+  }
+}
+
+
+# Example of using the renderer.
+# This is something that app authors will do.
+values <- reactiveValues(A="text")
+
+\dontrun{
+# Create an output object
+output$tripleA <- renderTriple({
+  values$A
+})
+}
+
+# At the R console, you can experiment with the renderer using isolate()
+tripleA <- renderTriple({
+  values$A
+})
+
+isolate(tripleA())
+# "text, text, text"
+}
+

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

@@ -0,0 +1,24 @@
+\name{headerPanel}
+\alias{headerPanel}
+\title{Create a header panel}
+\usage{
+  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
+  \link{pageWithSidebar}
+}
+\description{
+  Create a header panel containing an application title.
+}
+\examples{
+headerPanel("Hello Shiny!")
+}
+

man/helpText.Rd

@@ -0,0 +1,23 @@
+\name{helpText}
+\alias{helpText}
+\title{Create a help text element}
+\usage{
+  helpText(...)
+}
+\arguments{
+  \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.
+}
+\description{
+  Create help text which can be added to an input form to
+  provide additional explanation or context.
+}
+\examples{
+helpText("Note: while the data view will show only",
+         "the specified number of observations, the",
+         "summary will be based on the full dataset.")
+}
+

man/htmlOutput.Rd

@@ -0,0 +1,30 @@
+\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}
+}
+\value{
+  An HTML output element that can be included in a panel
+}
+\description{
+  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.
+}
+\details{
+  \code{uiOutput} is intended to be used with
+  \code{renderUI} 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/invalidateLater.Rd

@@ -0,0 +1,15 @@
+\name{invalidateLater}
+\alias{invalidateLater}
+\title{Scheduled Invalidation}
+\usage{
+  invalidateLater(millis)
+}
+\arguments{
+  \item{millis}{Approximate milliseconds to wait before
+  invalidating the current reactive context.}
+}
+\description{
+  Schedules the current reactive context to be invalidated
+  in the given number of milliseconds.
+}
+

man/isolate.Rd

@@ -0,0 +1,84 @@
+\name{isolate}
+\alias{isolate}
+\title{Create a non-reactive scope for an expression}
+\usage{
+  isolate(expr)
+}
+\arguments{
+  \item{expr}{An expression that can access reactive values
+  or expressions.}
+}
+\description{
+  Executes the given expression in a scope where reactive
+  values or expression can be read, but they cannot cause
+  the reactive scope of the caller to be re-evaluated when
+  they change.
+}
+\details{
+  Ordinarily, the simple act of reading a reactive value
+  causes a relationship to be established between the
+  caller and the reactive value, where a change to the
+  reactive value will cause the caller to re-execute. (The
+  same applies for the act of getting a reactive
+  expression's value.) The \code{isolate} function lets you
+  read a reactive value or expression without establishing
+  this relationship.
+
+  The expression given to \code{isolate()} is evaluated in
+  the calling environment. This means that if you assign a
+  variable inside the \code{isolate()}, its value will be
+  visible outside of the \code{isolate()}. If you want to
+  avoid this, you can use \code{\link{local}()} inside the
+  \code{isolate()}.
+
+  This function can also be useful for calling reactive
+  expression at the console, which can be useful for
+  debugging. To do so, simply wrap the calls to the
+  reactive expression with \code{isolate()}.
+}
+\examples{
+\dontrun{
+observe({
+  input$saveButton  # Do take a dependency on input$saveButton
+
+  # isolate a simple expression
+  data <- get(isolate(input$dataset))  # No dependency on input$dataset
+  writeToDatabase(data)
+})
+
+observe({
+  input$saveButton  # Do take a dependency on input$saveButton
+
+  # isolate a whole block
+  data <- isolate({
+    a <- input$valueA   # No dependency on input$valueA or input$valueB
+    b <- input$valueB
+    c(a=a, b=b)
+  })
+  writeToDatabase(data)
+})
+
+observe({
+  x <- 1
+  # x outside of isolate() is affected
+  isolate(x <- 2)
+  print(x) # 2
+
+  y <- 1
+  # Use local() to avoid affecting calling environment
+  isolate(local(y <- 2))
+  print(y) # 1
+})
+
+}
+
+# Can also use isolate to call reactive expressions from the R console
+values <- reactiveValues(A=1)
+fun <- reactive({ as.character(values$A) })
+isolate(fun())
+# "1"
+
+# isolate also works if the reactive expression accesses values from the
+# input object, like input$x
+}
+

man/mainPanel.Rd

@@ -0,0 +1,24 @@
+\name{mainPanel}
+\alias{mainPanel}
+\title{Create a main panel}
+\usage{
+  mainPanel(...)
+}
+\arguments{
+  \item{...}{Ouput elements to include in the main panel}
+}
+\value{
+  A main panel that can be passed to \link{pageWithSidebar}
+}
+\description{
+  Create a main panel containing output elements that can
+  in turn be passed to \link{pageWithSidebar}.
+}
+\examples{
+# Show the caption and plot of the requested variable against mpg
+mainPanel(
+   h3(textOutput("caption")),
+   plotOutput("mpgPlot")
+)
+}
+

man/numericInput.Rd

@@ -0,0 +1,34 @@
+\name{numericInput}
+\alias{numericInput}
+\title{Create a numeric input control}
+\usage{
+  numericInput(inputId, label, value, min = NA, max = NA,
+    step = NA)
+}
+\arguments{
+  \item{inputId}{Input variable to assign the control's
+  value to}
+
+  \item{label}{Display label for the control}
+
+  \item{value}{Initial value}
+
+  \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
+  definition.
+}
+\description{
+  Create an input control for entry of numeric values
+}
+\examples{
+numericInput("obs", "Observations:", 10,
+             min = 1, max = 100)
+}
+

man/observe.Rd

@@ -0,0 +1,68 @@
+\name{observe}
+\alias{observe}
+\title{Create a reactive observer}
+\usage{
+  observe(x, env = parent.frame(), quoted = FALSE,
+    label = NULL, suspended = FALSE)
+}
+\arguments{
+  \item{x}{An expression (quoted or unquoted). Any return
+  value will be ignored.}
+
+  \item{env}{The parent environment for the reactive
+  expression. By default, this is the calling environment,
+  the same as when defining an ordinary non-reactive
+  expression.}
+
+  \item{quoted}{Is the expression quoted? By default, this
+  is \code{FALSE}.  This is useful when you want to use an
+  expression that is stored in a variable; to do so, it
+  must be quoted with `quote()`.}
+
+  \item{label}{A label for the observer, useful for
+  debugging.}
+
+  \item{suspended}{If \code{TRUE}, start the observer in a
+  suspended state.  If \code{FALSE} (the default), start in
+  a non-suspended state.}
+}
+\description{
+  Creates an observer from the given expression An observer
+  is like a reactive expression in that it can read
+  reactive values and call reactive expressions, and will
+  automatically re-execute when those dependencies change.
+  But unlike reactive expression, it doesn't yield a result
+  and can't be used as an input to other reactive
+  expressions. Thus, observers are only useful for their
+  side effects (for example, performing I/O).
+}
+\details{
+  Another contrast between reactive expressions and
+  observers is their execution strategy. Reactive
+  expressions 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.
+}
+\examples{
+values <- reactiveValues(A=1)
+
+obsB <- observe({
+  print(values$A + 1)
+})
+
+# Can use quoted expressions
+obsC <- observe(quote({ print(values$A + 2) }), quoted = TRUE)
+
+# To store expressions for later conversion to observe, use quote()
+expr_q <- quote({ print(values$A + 3) })
+obsD <- observe(expr_q, quoted = TRUE)
+
+# In a normal Shiny app, the web client will trigger flush events. If you
+# are at the console, you can force a flush with flushReact()
+shiny:::flushReact()
+}
+

man/outputOptions.Rd

@@ -0,0 +1,36 @@
+\name{outputOptions}
+\alias{outputOptions}
+\title{Set options for an output object.}
+\usage{
+  outputOptions(x, name, ...)
+}
+\arguments{
+  \item{x}{A shinyoutput object (typically \code{output}).}
+
+  \item{name}{The name of an output observer in the
+  shinyoutput object.}
+
+  \item{...}{Options to set for the output observer.}
+}
+\description{
+  These are the available options for an output object:
+  \itemize{ \item suspendWhenHidden. When \code{TRUE} (the
+  default), the output object will be suspended (not
+  execute) when it is hidden on the web page. When
+  \code{FALSE}, the output object will not suspend when
+  hidden, and if it was already hidden and suspended, then
+  it will resume immediately. }
+}
+\examples{
+\dontrun{
+# Get the list of options for all observers within output
+outputOptions(output)
+
+# Disable suspend for output$myplot
+outputOptions(output, "myplot", suspendWhenHidden = FALSE)
+
+# Get the list of options for output$myplot
+outputOptions(output, "myplot")
+}
+}
+

man/pageWithSidebar.Rd

@@ -0,0 +1,47 @@
+\name{pageWithSidebar}
+\alias{pageWithSidebar}
+\title{Create a page with a sidebar}
+\usage{
+  pageWithSidebar(headerPanel, sidebarPanel, mainPanel)
+}
+\arguments{
+  \item{headerPanel}{The \link{headerPanel} with the
+  application title}
+
+  \item{sidebarPanel}{The \link{sidebarPanel} containing
+  input controls}
+
+  \item{mainPanel}{The \link{mainPanel} containing outputs}
+}
+\value{
+  A UI defintion that can be passed to the \link{shinyUI}
+  function
+}
+\description{
+  Create a Shiny UI that contains a header with the
+  application title, a sidebar for input controls, and a
+  main area for output.
+}
+\examples{
+# Define UI
+shinyUI(pageWithSidebar(
+
+  # Application title
+  headerPanel("Hello Shiny!"),
+
+  # Sidebar with a slider input
+  sidebarPanel(
+    sliderInput("obs",
+                "Number of observations:",
+                min = 0,
+                max = 1000,
+                value = 500)
+  ),
+
+  # Show a plot of the generated distribution
+  mainPanel(
+    plotOutput("distPlot")
+  )
+))
+}
+

man/plotOutput.Rd

@@ -0,0 +1,29 @@
+\name{plotOutput}
+\alias{plotOutput}
+\title{Create a plot output element}
+\usage{
+  plotOutput(outputId, width = "100\%", height = "400px")
+}
+\arguments{
+  \item{outputId}{output variable to read the plot from}
+
+  \item{width}{Plot width. Must be a valid CSS unit (like
+  \code{"100\%"}, \code{"400px"}, \code{"auto"}) or a
+  number, which will be coerced to a string and have
+  \code{"px"} appended.}
+
+  \item{height}{Plot height}
+}
+\value{
+  A plot output element that can be included in a panel
+}
+\description{
+  Render a \link{renderPlot} within an application page.
+}
+\examples{
+# Show a plot of the generated distribution
+mainPanel(
+  plotOutput("distPlot")
+)
+}
+

man/radioButtons.Rd

@@ -0,0 +1,35 @@
+\name{radioButtons}
+\alias{radioButtons}
+\title{Create radio buttons}
+\usage{
+  radioButtons(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 select from (if elements
+  of the list are named then that name rather than the
+  value is displayed to the user)}
+
+  \item{selected}{Name of initially selected item (if not
+  specified then defaults to the first item)}
+}
+\value{
+  A set of radio buttons that can be added to a UI
+  definition.
+}
+\description{
+  Create a set of radio buttons used to select an item from
+  a list.
+}
+\examples{
+radioButtons("dist", "Distribution type:",
+             c("Normal" = "norm",
+               "Uniform" = "unif",
+               "Log-normal" = "lnorm",
+               "Exponential" = "exp"))
+}
+