Firefox compatibility; visual tweaks

Add workerID to upload, download, and file URLs.

.Rbuildignore

@@ -7,3 +7,5 @@
 ^shiny\.cmd$
 ^run\.R$
 ^\.gitignore$
+^res$
+^tools$

DESCRIPTION

@@ -1,27 +1,51 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.1.4
-Date: 2012-08-30
+Version: 0.6.0.99
+Date: 2013-01-23
 Author: RStudio, Inc.
-Maintainer: Joe Cheng <joe@rstudio.org>
-Description: Shiny makes it incredibly easy to build interactive web 
-    applications with R. Automatic "reactive" binding between inputs and 
-    outputs and extensive pre-built widgets make it possible to build 
+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), methods, websockets (>= 1.1.4), caTools, RJSONIO, xtable
-Imports: stats, tools, utils, datasets
-URL: https://github.com/rstudio/shiny, http://rstudio.github.com/shiny/tutorial
+Depends:
+    R (>= 2.14.1)
+Imports:
+    stats,
+    tools,
+    utils,
+    datasets,
+    methods,
+    httpuv (>= 1.0.6.2),
+    caTools,
+    RJSONIO,
+    xtable,
+    digest
+Suggests:
+    markdown,
+    Cairo,
+    testthat
+URL: http://www.rstudio.com/shiny/
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
     'map.R'
+    'priorityqueue.R'
+    'utils.R'
+    'tar.R'
     'timer.R'
     'tags.R'
+    'cache.R'
+    'graph.R'
     'react.R'
     'reactives.R'
+    'fileupload.R'
     'shiny.R'
     'shinywrappers.R'
     'shinyui.R'
     'slider.R'
     'bootstrap.R'
+    'run-url.R'
+    'imageutils.R'
+    'update-input.R'

NAMESPACE

@@ -1,12 +1,45 @@
+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(actionButton)
 export(addResourcePath)
 export(animationOptions)
+export(basicPage)
+export(bootstrapPage)
 export(br)
 export(checkboxGroupInput)
 export(checkboxInput)
 export(code)
+export(conditionalPanel)
+export(dateInput)
+export(dateRangeInput)
 export(div)
+export(downloadButton)
+export(downloadHandler)
+export(downloadLink)
 export(em)
+export(exprToFunction)
+export(fileInput)
 export(h1)
 export(h2)
 export(h3)
@@ -15,15 +48,25 @@ export(h5)
 export(h6)
 export(headerPanel)
 export(helpText)
-export(HTML)
 export(htmlOutput)
+export(imageOutput)
 export(img)
+export(includeCSS)
+export(includeHTML)
+export(includeMarkdown)
+export(includeScript)
+export(includeText)
 export(invalidateLater)
+export(isolate)
 export(mainPanel)
 export(numericInput)
+export(observe)
+export(outputOptions)
 export(p)
 export(pageWithSidebar)
+export(parseQueryString)
 export(plotOutput)
+export(plotPNG)
 export(pre)
 export(radioButtons)
 export(reactive)
@@ -32,32 +75,61 @@ export(reactivePrint)
 export(reactiveTable)
 export(reactiveText)
 export(reactiveTimer)
+export(reactiveUI)
+export(reactiveValues)
+export(reactiveValuesToList)
+export(renderImage)
+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(showReactLog)
 export(sidebarPanel)
 export(singleton)
 export(sliderInput)
 export(span)
+export(stopApp)
 export(strong)
 export(submitButton)
-export(tableOutput)
 export(tabPanel)
+export(tableOutput)
 export(tabsetPanel)
 export(tag)
 export(tagAppendChild)
+export(tagAppendChildren)
+export(tagList)
+export(tagSetChildren)
 export(tags)
 export(textInput)
 export(textOutput)
+export(uiOutput)
+export(updateCheckboxGroupInput)
+export(updateCheckboxInput)
+export(updateDateInput)
+export(updateDateRangeInput)
+export(updateNumericInput)
+export(updateRadioButtons)
+export(updateSelectInput)
+export(updateSliderInput)
+export(updateTabsetPanel)
+export(updateTextInput)
+export(validateCssUnit)
 export(verbatimTextOutput)
-S3method(as.character,shiny.tag)
-S3method(as.list,reactvaluesreader)
-S3method(format,shiny.tag)
-S3method(names,reactvaluesreader)
-S3method(print,shiny.tag)
-S3method(reactive,default)
-S3method(reactive,"function")
-S3method("$",reactvaluesreader)
-S3method("$<-",shinyoutput)
+export(wellPanel)
+export(withTags)
+export(writeReactLog)
+import(RJSONIO)
+import(caTools)
+import(digest)
+import(httpuv)
+import(xtable)

NEWS

@@ -1,3 +1,271 @@
+shiny 0.6.0.99
+--------------------------------------------------------------------------------
+
+
+shiny 0.6.0
+--------------------------------------------------------------------------------
+
+* `tabsetPanel()` can be directed to start with a specific tab selected.
+
+* Fix bug where multiple file uploads with 3 or more files result in incorrect
+  data.
+
+* Add `withTags()` function.
+
+* Add dateInput and dateRangeInput.
+
+* `shinyServer()` now takes an optional `session` argument, which is used for
+  communication with the session object.
+
+* Add functions to update values of existing inputs on a page, instead of
+  replacing them entirely.
+
+* Allow listening on domain sockets.
+
+* Added `actionButton()` to Shiny.
+
+* The server can now send custom JSON messages to the client. On the client
+  side, functions can be registered to handle these messages.
+
+* Callbacks can be registered to be called at the end of a client session.
+
+* Add ability to set priority of observers and outputs. Each priority level
+  gets its own queue.
+
+* Fix bug where the presence of a submit button would prevent sending of
+  metadata until the button was clicked.
+
+* `reactiveTimer()` and `invalidateLater()` by default no longer invalidate
+  reactive objects after the client session has closed.
+
+* Shiny apps can be run without a server.r and ui.r file.
+
+shiny 0.5.0
+--------------------------------------------------------------------------------
+
+* Switch from websockets package for handling websocket connections to httpuv.
+
+* New method for detecting hidden output objects. Instead of checking that
+  height and width are 0, it checks that the object or any ancestor in the DOM
+  has style display:none.
+
+* Add `clientData` reactive values object, which carries information about the
+  client. This includes the hidden status of output objects, height/width plot
+  output objects, and the URL of the browser.
+
+* Add `parseQueryString()` function.
+
+* Add `renderImage()` function for sending arbitrary image files to the client,
+  and its counterpart, `imageOutput()`.
+
+* Add support for high-resolution (Retina) displays.
+
+* Fix bug #55, where `renderTable()` would throw error with an empty data frame.
+
+shiny 0.4.1
+--------------------------------------------------------------------------------
+
+* Fix bug where width and height weren't passed along properly from
+  `reactivePlot` to `renderPlot`.
+
+* Fix bug where infinite recursion would happen when `reactivePlot` was passed
+  a function for width or height.
+
+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
 --------------------------------------------------------------------------------
 

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))
+    return()
+  
+  if (is.null(filepath) || is.na(filepath))
+    .currentCacheContext$cc$forceDirty()
+  else
+    .currentCacheContext$cc$addDependencyFile(filepath)
+}

R/fileupload.R

@@ -0,0 +1,109 @@
+# 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',
+    .pendingFileInfos = 'list'
+  ),
+  methods = list(
+    initialize = function(parent, id, dir, fileInfos) {
+      .parent <<- parent
+      .id <<- id
+      .files <<- data.frame(name=character(),
+                            size=numeric(),
+                            type=character(),
+                            datapath=character(),
+                            stringsAsFactors=FALSE)
+      .dir <<- dir
+      .pendingFileInfos <<- fileInfos
+    },
+    fileBegin = function() {
+      if (length(.pendingFileInfos) < 1)
+        stop("fileBegin called too many times")
+
+      file <- .pendingFileInfos[[1]]
+      .currentFileInfo <<- file
+      .pendingFileInfos <<- tail(.pendingFileInfos, -1)
+
+      filename <- file.path(.dir, as.character(length(.files$name)))
+      row <- data.frame(name=file$name, size=file$size, type=file$type,
+                        datapath=filename, stringsAsFactors=FALSE)
+      
+      if (length(.files$name) == 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() {
+      if (length(.pendingFileInfos) > 0)
+        stop("File upload job was stopped prematurely")
+      .parent$onJobFinished(.id)
+      return(.files)
+    }
+  )
+)
+
+FileUploadContext <- setRefClass(
+  'FileUploadContext',
+  fields = list(
+    .basedir = 'character',
+    .operations = 'Map'
+  ),
+  methods = list(
+    initialize = function(dir=tempdir()) {
+      .basedir <<- dir
+    },
+    createUploadOperation = function(fileInfos) {
+      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, fileInfos)
+        .operations$set(id, op)
+        return(id)
+      }
+    },
+    getUploadOperation = function(jobId) {
+      .operations$get(jobId)
+    },
+    onJobFinished = function(jobId) {
+      .operations$remove(jobId)
+    }
+  )
+)

R/graph.R

@@ -0,0 +1,73 @@
+#' @export
+writeReactLog <- function(file=stdout()) {
+  cat(RJSONIO::toJSON(.graphEnv$log, pretty=TRUE), file=file)
+}
+
+#' @export
+showReactLog <- function() {
+  browseURL(renderReactLog())
+}
+
+renderReactLog <- function() {
+  templateFile <- system.file('www/reactive-graph.html', package='shiny')
+  html <- paste(readLines(templateFile, warn=FALSE), collapse='\r\n')
+  tc <- textConnection(NULL, 'w')
+  on.exit(close(tc))
+  writeReactLog(tc)
+  cat('\n', file=tc)
+  flush(tc)
+  html <- sub('__DATA__', paste(textConnectionValue(tc), collapse='\r\n'), html, fixed=TRUE)
+  file <- tempfile(fileext = '.html')
+  writeLines(html, file)
+  return(file)
+}
+
+.graphAppend <- function(logEntry) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphEnv$log <- c(.graphEnv$log, list(logEntry))
+}
+
+.graphDependsOn <- function(id, label) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='dep', id=id, dependsOn=label))
+}
+
+.graphDependsOnId <- function(id, dependee) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='depId', id=id, dependsOn=dependee))
+}
+
+.graphCreateContext <- function(id, label, type, prevId) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(
+      action='ctx', id=id, label=paste(label, collapse='\n'), type=type, prevId=prevId
+    ))
+}
+
+.graphEnterContext <- function(id) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='enter', id=id))
+}
+
+.graphExitContext <- function(id) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='exit', id=id))
+}
+
+.graphValueChange <- function(label, value) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE))) {
+    .graphAppend(list(
+      action = 'valueChange',
+      id = label,
+      value = paste(capture.output(str(value)), collapse='\n')
+    ))
+  }
+}
+
+.graphInvalidate <- function(id) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='invalidate', id=id))
+}
+
+.graphEnv <- new.env()
+.graphEnv$log <- list()

R/imageutils.R

@@ -0,0 +1,56 @@
+#' Run a plotting function and save the output as a PNG
+#'
+#' This function returns the name of the PNG file that it generates. In
+#' essence, it calls \code{png()}, then \code{func()}, then \code{dev.off()}.
+#' So \code{func} must be a function that will generate a plot when used this
+#' way.
+#'
+#' 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.
+#'
+#' In some cases, \code{Cairo()} provides output that looks worse than
+#' \code{png()}. To disable Cairo output for an app, use
+#' \code{options(shiny.usecairo=FALSE)}.
+#'
+#' @param func A function that generates a plot.
+#' @param filename The name of the output file. Defaults to a temp file with
+#'   extension \code{.png}.
+#' @param width Width in pixels.
+#' @param height Height in pixels.
+#' @param res Resolution in pixels per inch. This value is passed to
+#'   \code{\link{png}}. Note that this affects the resolution of PNG rendering in
+#'   R; it won't change the actual ppi of the browser.
+#' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
+#'   These can be used to set the width, height, background color, etc.
+#'
+#' @export
+plotPNG <- function(func, filename=tempfile(fileext='.png'),
+                    width=400, height=400, res=72, ...) {
+  # 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 (getOption('shiny.usecairo', TRUE) &&
+             nchar(system.file(package = "Cairo"))) {
+    # Workaround for issue #140: Cairo ignores res and dpi settings. Need to
+    # use regular png function.
+    if (res == 72) {
+      pngfun <- Cairo::CairoPNG
+    } else {
+      pngfun <- png
+    }
+  } else {
+    pngfun <- png
+  }
+
+  do.call(pngfun, c(filename=filename, width=width, height=height, res=res, list(...)))
+  tryCatch(
+    func(),
+    finally=dev.off())
+
+  filename
+}

R/map.R

@@ -20,30 +20,36 @@ Map <- setRefClass(
     },
     get = function(key) {
       if (.self$containsKey(key))
-        return(base::get(key, pos=.env, inherits=F))
+        return(base::get(key, pos=.env, inherits=FALSE))
       else
         return(NULL)
     },
     set = function(key, value) {
-      assign(key, value, pos=.env, inherits=F)
+      assign(key, value, pos=.env, inherits=FALSE)
       return(value)
     },
+    mset = function(...) {
+      args <- list(...)
+      for (key in names(args))
+        set(key, args[[key]])
+      return()
+    },
     remove = function(key) {
       if (.self$containsKey(key)) {
         result <- .self$get(key)
-        rm(list = key, pos=.env, inherits=F)
+        rm(list = key, pos=.env, inherits=FALSE)
         return(result)
       }
       return(NULL)
     },
     containsKey = function(key) {
-      exists(key, where=.env, inherits=F)
+      exists(key, where=.env, inherits=FALSE)
     },
     keys = function() {
-      ls(envir=.env, all.names=T)
+      ls(envir=.env, all.names=TRUE)
     },
     values = function() {
-      mget(.self$keys(), envir=.env, inherits=F)
+      mget(.self$keys(), envir=.env, inherits=FALSE)
     },
     clear = function() {
       .env <<- new.env(parent=emptyenv())
@@ -55,19 +61,10 @@ Map <- setRefClass(
   )
 )
 
-`[.Map` <- function(map, name) {
-  map$get(name)
-}
-
-`[<-.Map` <- function(map, name, value) {
-  map$set(name, value)
-  return(map)
-}
-
 as.list.Map <- function(map) {
   sapply(map$keys(),
          map$get,
-         simplify=F)
+         simplify=FALSE)
 }
 length.Map <- function(map) {
   map$size()

R/priorityqueue.R

@@ -0,0 +1,110 @@
+# "...like a regular queue or stack data structure, but where additionally each
+# element has a "priority" associated with it. In a priority queue, an element
+# with high priority is served before an element with low priority. If two
+# elements have the same priority, they are served according to their order in
+# the queue." (http://en.wikipedia.org/wiki/Priority_queue)
+
+PriorityQueue <- setRefClass(
+  'PriorityQueue',
+  fields = list(
+    # Keys are priorities, values are subqueues (implemented as list)
+    .itemsByPriority = 'Map',
+    # Sorted vector (largest first)
+    .priorities = 'numeric'  
+  ),
+  methods = list(
+    # Enqueue an item, with the given priority level (must be integer). Higher 
+    # priority numbers are dequeued earlier than lower.
+    enqueue = function(item, priority) {
+      priority <- normalizePriority(priority)
+      
+      if (!(priority %in% .priorities)) {
+        .priorities <<- c(.priorities, priority)
+        .priorities <<- sort(.priorities, decreasing=TRUE)
+        .itemsByPriority$set(.key(priority), list(item))
+      } else {
+        .itemsByPriority$set(
+          .key(priority),
+          c(.itemsByPriority$get(.key(priority)), item)
+        )
+      }
+      return(invisible())
+    },
+    # Retrieve a single item by 1) priority number (highest first) and then 2) 
+    # insertion order (first in, first out). If there are no items to be 
+    # dequeued, then NULL is returned. If it is necessary to distinguish between
+    # a NULL value and the empty case, call isEmpty() before dequeue().
+    dequeue = function() {
+      if (length(.priorities) == 0)
+        return(NULL)
+      
+      maxPriority <- .priorities[[1]]
+      items <- .itemsByPriority$get(.key(maxPriority))
+      firstItem <- items[[1]]
+      if (length(items) == 1) {
+        # This is the last item at this priority. Remove both the list and the
+        # priority level.
+        .itemsByPriority$remove(.key(maxPriority))
+        .priorities <<- .priorities[-1]
+      } else {
+        # There are still items at this priority. Remove the current item from
+        # the list, and save it.
+        items <- items[-1]
+        .itemsByPriority$set(.key(maxPriority), items)
+      }
+      return(firstItem)
+    },
+    # Returns TRUE if no items are in the queue, otherwise FALSE.
+    isEmpty = function() {
+      length(.priorities) == 0
+    },
+    # Translates a priority integer to a character that is suitable for using as
+    # a key.
+    .key = function(priority) {
+      sprintf('%a', priority)
+    }
+  )
+)
+
+normalizePriority <- function(priority) {
+  
+  if (is.null(priority))
+    priority <- 0
+  
+  # Cast integers to numeric to prevent any inconsistencies
+  if (is.integer(priority))
+    priority <- as.numeric(priority)
+  
+  if (!is.numeric(priority))
+    stop('priority must be an integer or numeric')
+  
+  # Check length
+  if (length(priority) == 0) {
+    warning('Zero-length priority vector was passed; using 0')
+    priority <- 0
+  } else if (length(priority) > 1) {
+    warning('Priority has length > 1 and only the first element will be used')
+    priority <- priority[1]
+  }
+  
+  # NA == 0
+  if (is.na(priority))
+    priority <- 0
+
+  return(priority)
+}
+
+# pq <- PriorityQueue$new()
+# pq$enqueue('a', 1)
+# pq$enqueue('b', 1L)
+# pq$enqueue('c', 1)
+# pq$enqueue('A', 2)
+# pq$enqueue('B', 2L)
+# pq$enqueue('C', 2)
+# pq$enqueue('d', 1)
+# pq$enqueue('e', 1L)
+# pq$enqueue('f', 1)
+# pq$enqueue('D', 2)
+# pq$enqueue('E', 2L)
+# pq$enqueue('F', 2)
+# # Expect ABCDEFabcdef

R/react.R

@@ -2,38 +2,38 @@ Context <- setRefClass(
   'Context',
   fields = list(
     id = 'character',
+    .label = 'character',      # For debug purposes
     .invalidated = 'logical',
-    .callbacks = 'list',
-    .hintCallbacks = 'list'
+    .invalidateCallbacks = 'list',
+    .flushCallbacks = 'list'
   ),
   methods = list(
-    initialize = function() {
+    initialize = function(label='', type='other', prevId='') {
       id <<- .getReactiveEnvironment()$nextId()
-      .invalidated <<- F
-      .callbacks <<- list()
-      .hintCallbacks <<- list()
+      .invalidated <<- FALSE
+      .invalidateCallbacks <<- list()
+      .flushCallbacks <<- list()
+      .label <<- label
+      .graphCreateContext(id, label, type, prevId)
     },
     run = function(func) {
       "Run the provided function under this context."
       env <- .getReactiveEnvironment()
+      .graphEnterContext(id)
+      on.exit(.graphExitContext(id))
       env$runWith(.self, func)
     },
-    invalidateHint = function() {
-      "Let this context know it may or may not be invalidated very soon; that
-      is, something in its dependency graph has been invalidated but there's no
-      guarantee that the cascade of invalidations will reach all the way here.
-      This is used to show progress in the UI."
-      lapply(.hintCallbacks, function(func) {
-        func()
-      })
-    },
     invalidate = function() {
-      "Schedule this context for invalidation. It will not actually be
-        invalidated until the next call to \\code{\\link{flushReact}}."
+      "Invalidate this context. It will immediately call the callbacks
+        that have been registered with onInvalidate()."
       if (.invalidated)
         return()
-      .invalidated <<- T
-      .getReactiveEnvironment()$addPendingInvalidate(.self)
+      .invalidated <<- TRUE
+
+      .graphInvalidate(id)
+      lapply(.invalidateCallbacks, function(func) {
+        func()
+      })
       NULL
     },
     onInvalidate = function(func) {
@@ -43,23 +43,27 @@ Context <- setRefClass(
       if (.invalidated)
         func()
       else
-        .callbacks <<- c(.callbacks, func)
+        .invalidateCallbacks <<- c(.invalidateCallbacks, func)
       NULL
     },
-    onInvalidateHint = function(func) {
-      .hintCallbacks <<- c(.hintCallbacks, func)
+    addPendingFlush = function(priority) {
+      "Tell the reactive environment that this context should be flushed the
+        next time flushReact() called."
+      .getReactiveEnvironment()$addPendingFlush(.self, priority)
     },
-    executeCallbacks = function() {
+    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(.callbacks, function(func) {
-        tryCatch({
+      lapply(.flushCallbacks, function(func) {
+        withCallingHandlers({
           func()
         }, warning = function(e) {
           # TODO: Callbacks in app
-          print(e)
         }, error = function(e) {
           # TODO: Callbacks in app
-          print(e)
         })
       })
     }
@@ -68,22 +72,29 @@ Context <- setRefClass(
 
 ReactiveEnvironment <- setRefClass(
   'ReactiveEnvironment',
-  fields = c('.currentContext', '.nextId', '.pendingInvalidate'),
+  fields = list(
+    .currentContext = 'ANY',
+    .nextId = 'integer',
+    .pendingFlush = 'PriorityQueue',
+    .inFlush = 'logical'
+  ),
   methods = list(
     initialize = function() {
       .currentContext <<- NULL
       .nextId <<- 0L
-      .pendingInvalidate <<- list()
+      .pendingFlush <<- PriorityQueue$new()
+      .inFlush <<- FALSE
     },
     nextId = function() {
       .nextId <<- .nextId + 1L
       return(as.character(.nextId))
     },
     currentContext = function() {
-      if (is.null(.currentContext))
+      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)
     },
     runWith = function(ctx, func) {
@@ -92,27 +103,26 @@ ReactiveEnvironment <- setRefClass(
       on.exit(.currentContext <<- old.ctx)
       func()
     },
-    addPendingInvalidate = function(ctx) {
-      .pendingInvalidate <<- c(.pendingInvalidate, ctx)
+    addPendingFlush = function(ctx, priority) {
+      .pendingFlush$enqueue(ctx, priority)
     },
     flush = function() {
-      while (length(.pendingInvalidate) > 0) {
-        contexts <- .pendingInvalidate
-        .pendingInvalidate <<- list()
-        lapply(contexts, function(ctx) {
-          ctx$executeCallbacks()
-          NULL
-        })
+      # If already in a flush, don't start another one
+      if (.inFlush) return()
+      .inFlush <<- TRUE
+      on.exit(.inFlush <<- FALSE)
+
+      while (!.pendingFlush$isEmpty()) {
+        ctx <- .pendingFlush$dequeue()
+        ctx$executeFlushCallbacks()
       }
     }
   )
 )
 
+.reactiveEnvironment <- ReactiveEnvironment$new()
 .getReactiveEnvironment <- function() {
-  if (!exists('.ReactiveEnvironment', envir=.GlobalEnv, inherits=F)) {
-    assign('.ReactiveEnvironment', ReactiveEnvironment$new(), envir=.GlobalEnv)
-  }
-  get('.ReactiveEnvironment', envir=.GlobalEnv, inherits=F)
+  .reactiveEnvironment
 }
 
 # Causes any pending invalidations to run.

R/reactives.R

@@ -1,90 +1,106 @@
-Dependencies <- setRefClass(
-  'Dependencies',
+Dependents <- setRefClass(
+  'Dependents',
   fields = list(
-    .dependencies = 'Map'
+    .dependents = 'Map'
   ),
   methods = list(
-    register = function() {
+    register = function(depId=NULL, depLabel=NULL) {
       ctx <- .getReactiveEnvironment()$currentContext()
-      if (!.dependencies$containsKey(ctx$id)) {
-        .dependencies$set(ctx$id, ctx)
+      if (!.dependents$containsKey(ctx$id)) {
+        .dependents$set(ctx$id, ctx)
         ctx$onInvalidate(function() {
-          .dependencies$remove(ctx$id)
+          .dependents$remove(ctx$id)
         })
+        
+        if (!is.null(depId) && nchar(depId) > 0)
+          .graphDependsOnId(ctx$id, depId)
+        if (!is.null(depLabel))
+          .graphDependsOn(ctx$id, depLabel)
       }
     },
     invalidate = function() {
       lapply(
-        .dependencies$values(),
+        .dependents$values(),
         function(ctx) {
-          ctx$invalidateHint()
           ctx$invalidate()
           NULL
         }
       )
-    },
-    invalidateHint = function() {
-      lapply(
-        .dependencies$values(),
-        function(dep.ctx) {
-          dep.ctx$invalidateHint()
-          NULL
-        })
     }
   )
 )
 
-Values <- setRefClass(
-  'Values',
+
+# ReactiveValues ------------------------------------------------------------
+
+ReactiveValues <- setRefClass(
+  'ReactiveValues',
   fields = list(
+    # For debug purposes
+    .label = 'character',
     .values = 'environment',
-    .dependencies = 'environment',
-    # Dependencies for the list of names
-    .namesDeps = 'Dependencies',
-    # Dependencies for all values
-    .allDeps = 'Dependencies'
+    .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() {
+      .label <<- paste('reactiveValues', runif(1, min=1000, max=9999),
+                       sep="")
       .values <<- new.env(parent=emptyenv())
-      .dependencies <<- 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=.dependencies, inherits=F)) {
-        assign(dep.key, ctx, pos=.dependencies, inherits=F)
+      if (!exists(dep.key, where=.dependents, inherits=FALSE)) {
+        .graphDependsOn(ctx$id, sprintf('%s$%s', .label, key))
+        assign(dep.key, ctx, pos=.dependents, inherits=FALSE)
         ctx$onInvalidate(function() {
-          rm(list=dep.key, pos=.dependencies, inherits=F)
+          rm(list=dep.key, pos=.dependents, inherits=FALSE)
         })
       }
       
-      if (!exists(key, where=.values, inherits=F))
+      if (!exists(key, where=.values, inherits=FALSE))
         NULL
       else
-        base::get(key, pos=.values, inherits=F)
+        base::get(key, pos=.values, inherits=FALSE)
     },
     set = function(key, value) {
-      if (exists(key, where=.values, inherits=F)) {
-        if (identical(base::get(key, pos=.values, inherits=F), value)) {
+      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()
       }
-      .allDeps$invalidate()
-      
-      assign(key, value, pos=.values, inherits=F)
+
+      if (hidden)
+        .allValuesDeps$invalidate()
+      else
+        .valuesDeps$invalidate()
+
+      assign(key, value, pos=.values, inherits=FALSE)
+
+      .graphValueChange(sprintf('names(%s)', .label), ls(.values, all.names=TRUE))
+      .graphValueChange(sprintf('%s (all)', .label), as.list(.values))
+      .graphValueChange(sprintf('%s$%s', .label, key), value)
+
       dep.keys <- objects(
-        pos=.dependencies,
+        pos=.dependents,
         pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''),
-        all.names=T
+        all.names=TRUE
       )
       lapply(
-        mget(dep.keys, envir=.dependencies),
+        mget(dep.keys, envir=.dependents),
         function(ctx) {
-          ctx$invalidateHint()
           ctx$invalidate()
           NULL
         }
@@ -98,193 +114,503 @@ Values <- setRefClass(
              })
     },
     names = function() {
+      .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
+                      sprintf('names(%s)', .label))
       .namesDeps$register()
-      return(ls(.values, all.names=T))
+      return(ls(.values, all.names=TRUE))
     },
-    toList = function() {
-      .allDeps$register()
-      return(as.list(.values))
+    toList = function(all.names=FALSE) {
+      .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
+                      sprintf('%s (all)', .label))
+      if (all.names)
+        .allValuesDeps$register()
+
+      .valuesDeps$register()
+
+      return(as.list(.values, all.names=all.names))
+    },
+    .setLabel = function(label) {
+      .label <<- label
     }
   )
 )
 
-`[.Values` <- function(values, name) {
-  values$get(name)
+
+# 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
 }
 
-`[<-.Values` <- function(values, name, value) {
-  values$set(name, value)
-  return(values)
+# Register the S3 class so that it can be used for a field in a Reference Class
+setOldClass("reactivevalues")
+
+# 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)
 }
 
-.createValuesReader <- function(values) {
-  acc <- list(impl=values)
-  class(acc) <- 'reactvaluesreader'
-  return(acc)
+#' @S3method $ reactivevalues
+`$.reactivevalues` <- function(x, name) {
+  .subset2(x, 'impl')$get(name)
 }
 
-#' @S3method $ reactvaluesreader
-`$.reactvaluesreader` <- function(x, name) {
-  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 names reactvaluesreader
-names.reactvaluesreader <- function(x) {
-  x[['impl']]$names()
+#' @S3method [[<- reactivevalues
+`[[<-.reactivevalues` <- `$<-.reactivevalues`
+
+#' @S3method [ reactivevalues
+`[.reactivevalues` <- function(values, name) {
+  stop("Single-bracket indexing of reactivevalues object is not allowed.")
 }
 
-#' @S3method as.list reactvaluesreader
-as.list.reactvaluesreader <- function(x, ...) {
-  x[['impl']]$toList()
+#' @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)
+}
+
+# For debug purposes
+.setLabel <- function(x, label) {
+  .subset2(x, 'impl')$.setLabel(label)
+}
+
+#' 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',
-    .dependencies = 'Dependencies',
-    .initialized = 'logical',
-    .value = 'ANY'
+    .label = 'character',
+    .dependents = 'Dependents',
+    .invalidated = 'logical',
+    .running = 'logical',
+    .value = 'ANY',
+    .visible = 'logical',
+    .execCount = 'integer',
+    .mostRecentCtxId = 'character'
   ),
   methods = list(
-    initialize = function(func) {
+    initialize = function(func, label=deparse(substitute(func))) {
       if (length(formals(func)) > 0)
-        stop("Can't make a reactive function from a function that takes one ",
+        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
-      .initialized <<- F
+      .invalidated <<- TRUE
+      .running <<- FALSE
+      .label <<- label
+      .execCount <<- 0L
+      .mostRecentCtxId <<- ""
     },
     getValue = function() {
-      if (!.initialized) {
-        .initialized <<- T
+      .dependents$register()
+
+      if (.invalidated || .running) {
         .self$.updateValue()
       }
-      
-      .dependencies$register()
+
+      .graphDependsOnId(getCurrentContext()$id, .mostRecentCtxId)
       
       if (identical(class(.value), 'try-error'))
         stop(attr(.value, 'condition'))
-      return(.value)
+
+      if (.visible)
+        .value
+      else
+        invisible(.value)
     },
     .updateValue = function() {
-      old.value <- .value
-      
-      ctx <- Context$new()
+      ctx <- Context$new(.label, type='observable', prevId=.mostRecentCtxId)
+      .mostRecentCtxId <<- ctx$id
       ctx$onInvalidate(function() {
-        .self$.updateValue()
-      })
-      ctx$onInvalidateHint(function() {
-        .dependencies$invalidateHint()
+        .invalidated <<- TRUE
+        .dependents$invalidate()
       })
+      .execCount <<- .execCount + 1L
+
+      .invalidated <<- FALSE
+
+      wasRunning <- .running
+      .running <<- TRUE
+      on.exit(.running <<- wasRunning)
+
       ctx$run(function() {
-        .value <<- try(.func(), silent=F)
+        result <- withVisible(try(.func(), silent=FALSE))
+        .visible <<- result$visible
+        .value <<- result$value
       })
-      if (!identical(old.value, .value)) {
-        .dependencies$invalidate()
-      }
     }
   )
 )
 
-#' Create a Reactive Function
-#' 
-#' Wraps a normal function to create a reactive function. Conceptually, a 
-#' reactive function is a function whose result will change over time.
-#' 
-#' Reactive functions are functions that can read reactive values and call other
-#' reactive functions. Whenever a reactive value changes, any reactive functions
-#' that depended on it are marked as "invalidated" and will automatically 
-#' re-execute if necessary. If a reactive function is marked as invalidated, any
-#' other reactive functions that recently called it are also marked as 
-#' invalidated. In this way, invalidations ripple through the functions that 
+#' 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 functions.
-#' 
-#' @param x The value or function to make reactive. The function must not have 
-#'   any parameters.
-#' @return A reactive function. (Note that reactive functions can only be called
-#'   from within other reactive functions.)
-#'   
+#'
+#' 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) {
-  UseMethod("reactive")
+reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL) {
+  fun <- exprToFunction(x, env, quoted)
+  if (is.null(label))
+    label <- sprintf('reactive(%s)', paste(deparse(body(fun)), collapse='\n'))
+
+  Observable$new(fun, label)$getValue
 }
-#' @S3method reactive function
-reactive.function <- function(x) {
-  return(Observable$new(x)$getValue)
-}
-#' @S3method reactive default
-reactive.default <- function(x) {
-  stop("Don't know how to make this object reactive!")
+
+# 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',
-    .hintCallbacks = 'list'
+    .label = 'character',
+    .priority = 'numeric',
+    .invalidateCallbacks = 'list',
+    .execCount = 'integer',
+    .onResume = 'function',
+    .suspended = 'logical',
+    .prevId = 'character'
   ),
   methods = list(
-    initialize = function(func) {
+    initialize = function(func, label, suspended = FALSE, priority = 0) {
       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
+      .priority <<- normalizePriority(priority)
+      .execCount <<- 0L
+      .suspended <<- suspended
+      .onResume <<- function() NULL
+      .prevId <<- ''
 
       # Defer the first running of this until flushReact is called
-      ctx <- Context$new()
-      ctx$onInvalidate(function() {
-        run()
-      })
-      ctx$invalidate()
+      .createContext()$invalidate()
     },
-    run = function() {
-      ctx <- Context$new()
+    .createContext = function() {
+      ctx <- Context$new(.label, type='observer', prevId=.prevId)
+      .prevId <<- ctx$id
+
       ctx$onInvalidate(function() {
-        run()
-      })
-      ctx$onInvalidateHint(function() {
-        lapply(.hintCallbacks, function(func) {
+        lapply(.invalidateCallbacks, function(func) {
           func()
           NULL
         })
+
+        continue <- function() {
+          ctx$addPendingFlush(.priority)
+        }
+        
+        if (.suspended == FALSE)
+          continue()
+        else
+          .onResume <<- continue
       })
+      
+      ctx$onFlush(function() {
+        run()
+      })
+      
+      return(ctx)
+    },
+    run = function() {
+      ctx <- .createContext()
+      .execCount <<- .execCount + 1L
       ctx$run(.func)
     },
-    onInvalidateHint = function(func) {
-      .hintCallbacks <<- c(.hintCallbacks, func)
+    onInvalidate = function(callback) {
+      "Register a callback function to run when this observer is invalidated.
+      No arguments will be provided to the callback function when it is
+      invoked."
+      .invalidateCallbacks <<- c(.invalidateCallbacks, callback)
+    },
+    setPriority = function(priority = 0) {
+      "Change this observer's priority. Note that if the observer is currently
+      invalidated, then the change in priority will not take effect until the
+      next invalidation--unless the observer is also currently suspended, in
+      which case the priority change will be effective upon resume."
+      .priority <<- normalizePriority(priority)
+    },
+    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, because 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()
     }
   )
 )
 
-# NOTE: we de-roxygenized this comment because the function isn't exported
-# Observe
-# 
-# Creates an observer from the given function. An observer is like a reactive 
-# function in that it can read reactive values and call reactive functions, 
-# and will automatically re-execute when those dependencies change. But unlike
-# reactive functions, it doesn't yield a result and can't be used as an input 
-# to other reactive functions. Thus, observers are only useful for their side 
-# effects (for example, performing I/O).
-#
-# @param func The function to observe. It must not have any parameters. Any
-# return value from this function will be ignored.
-#
-observe <- function(func) {
-  Observer$new(func)
+#' 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 expressions, 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.
+#' @param priority An integer or numeric that controls the priority with which
+#'   this observer should be executed. An observer with a given priority level
+#'   will always execute sooner than all observers with a lower priority level. 
+#'   Positive, negative, and zero values are allowed.
+#' @return An observer reference class object. This object has the following 
+#'   methods:
+#'   \describe{
+#'     \item{\code{suspend()}}{
+#'       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 then that re-execution will
+#'       still occur, because the flush is already scheduled.
+#'     }
+#'     \item{\code{resume()}}{
+#'       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.
+#'     }
+#'     \item{\code{setPriority(priority = 0)}}{
+#'       Change this observer's priority. Note that if the observer is currently 
+#'       invalidated, then the change in priority will not take effect until the
+#'       next invalidation--unless the observer is also currently suspended, in 
+#'       which case the priority change will be effective upon resume.
+#'     }
+#'     \item{\code{onInvalidate(callback)}}{
+#'       Register a callback function to run when this observer is invalidated.
+#'       No arguments will be provided to the callback function when it is
+#'       invoked.
+#'     }
+#'   }
+#'
+#' @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, priority=0) {
+
+  fun <- exprToFunction(x, env, quoted)
+  if (is.null(label))
+    label <- sprintf('observe(%s)', paste(deparse(body(fun)), collapse='\n'))
+
+  invisible(Observer$new(
+    fun, label=label, suspended=suspended, priority=priority))
 }
 
+# ---------------------------------------------------------------------------
+
 #' 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 functions} and observers that want to be 
+#' \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.
@@ -292,18 +618,61 @@ observe <- function(func) {
 #' See \code{\link{invalidateLater}} as a safer and simpler alternative.
 #' 
 #' @param intervalMs How often to fire, in milliseconds
+#' @param session A session object. This is needed to cancel any scheduled
+#'   invalidations after a user has ended the session. If \code{NULL}, then
+#'   this invalidation will not be tied to any session, and so it will still
+#'   occur.
 #' @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
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   # Anything that calls autoInvalidate will automatically invalidate
+#'   # every 2 seconds.
+#'   autoInvalidate <- reactiveTimer(2000, session)
+#'
+#'   observe({
+#'     # Invalidate and re-execute this reactive expression every time the
+#'     # timer fires.
+#'     autoInvalidate()
+#'
+#'     # Do something each time this is invalidated.
+#'     # The isolate() makes this observer _not_ get invalidated and re-executed
+#'     # when input$n changes.
+#'     print(paste("The value of input$n is", isolate(input$n)))
+#'   })
+#'
+#'   # Generate a new histogram each time the timer fires, but not when
+#'   # input$n changes.
+#'   output$plot <- renderPlot({
+#'     autoInvalidate()
+#'     hist(isolate(input$n))
+#'   })
+#' })
+#' }
+#'
 #' @export
-reactiveTimer <- function(intervalMs=1000) {
-  dependencies <- Map$new()
+reactiveTimer <- function(intervalMs=1000, session) {
+  if (missing(session)) {
+    warning("reactiveTimer should be passed a session object or NULL")
+    session <- NULL
+  }
+
+  dependents <- Map$new()
   timerCallbacks$schedule(intervalMs, function() {
+    # Quit if the session is closed
+    if (!is.null(session) && session$isClosed()) {
+      return(invisible())
+    }
+
     timerCallbacks$schedule(intervalMs, sys.function())
     lapply(
-      dependencies$values(),
+      dependents$values(),
       function(dep.ctx) {
         dep.ctx$invalidate()
         NULL
@@ -311,10 +680,10 @@ reactiveTimer <- function(intervalMs=1000) {
   })
   return(function() {
     ctx <- .getReactiveEnvironment()$currentContext()
-    if (!dependencies$containsKey(ctx$id)) {
-      dependencies$set(ctx$id, ctx)
+    if (!dependents$containsKey(ctx$id)) {
+      dependents$set(ctx$id, ctx)
       ctx$onInvalidate(function() {
-        dependencies$remove(ctx$id)
+        dependents$remove(ctx$id)
       })
     }
     return(Sys.time())
@@ -327,11 +696,128 @@ reactiveTimer <- function(intervalMs=1000) {
 #' of milliseconds.
 #' @param millis Approximate milliseconds to wait before invalidating the
 #'   current reactive context.
+#' @param session A session object. This is needed to cancel any scheduled
+#'   invalidations after a user has ended the session. If \code{NULL}, then
+#'   this invalidation will not be tied to any session, and so it will still
+#'   occur.
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # Re-execute this reactive expression after 1000 milliseconds
+#'     invalidateLater(1000, session)
+#'
+#'     # Do something each time this is invalidated.
+#'     # The isolate() makes this observer _not_ get invalidated and re-executed
+#'     # when input$n changes.
+#'     print(paste("The value of input$n is", isolate(input$n)))
+#'   })
+#'
+#'   # Generate a new histogram at timed intervals, but not when
+#'   # input$n changes.
+#'   output$plot <- renderPlot({
+#'     # Re-execute this reactive expression after 2000 milliseconds
+#'     invalidateLater(2000, session)
+#'     hist(isolate(input$n))
+#'   })
+#' })
+#' }
+#'
 #' @export
-invalidateLater <- function(millis) {
+invalidateLater <- function(millis, session) {
+  if (missing(session)) {
+    warning("invalidateLater should be passed a session object or NULL")
+    session <- NULL
+  }
+
   ctx <- .getReactiveEnvironment()$currentContext()
   timerCallbacks$schedule(millis, function() {
+    # Quit if the session is closed
+    if (!is.null(session) && session$isClosed()) {
+      return(invisible())
+    }
     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]', type='isolate')
+  ctx$run(function() {
+    expr
+  })
+  ctx$invalidate()
+}

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

@@ -47,6 +47,76 @@ strong <- function(...) tags$strong(...)
 #' @export
 em <- function(...) tags$em(...)
 
+#' Include Content From a File
+#' 
+#' Include HTML, text, or rendered Markdown into a \link[=shinyUI]{Shiny UI}.
+#' 
+#' These functions provide a convenient way to include an extensive amount of 
+#' HTML, textual, Markdown, CSS, or JavaScript 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.
+#'   
+#' @param 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.
+#'   
+#' @rdname include
+#' @export
+includeHTML <- function(path) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  return(HTML(paste(lines, collapse='\r\n')))
+}
+
+#' @rdname include
+#' @export
+includeText <- function(path) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  return(paste(lines, collapse='\r\n'))
+}
+
+#' @rdname include
+#' @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))
+}
+
+#' @param ... Any additional attributes to be applied to the generated tag.
+#' @rdname include
+#' @export
+includeCSS <- function(path, ...) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  args <- list(...)
+  if (is.null(args$type))
+    args$type <- 'text/css'
+  return(do.call(tags$style,
+                 c(list(HTML(paste(lines, collapse='\r\n'))), args)))
+}
+
+#' @rdname include
+#' @export
+includeScript <- function(path, ...) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  return(tags$script(HTML(paste(lines, collapse='\r\n')), ...))
+}
+
 
 #' Include Content Only Once
 #' 
@@ -81,7 +151,7 @@ renderPage <- function(ui, connection) {
     if (isTag(content) && identical(content$name, "head")) {
       textConn <- textConnection(NULL, "w") 
       textConnWriter <- function(text) cat(text, file = textConn)
-      tagWriteChildren(content, textConnWriter, 1, context)
+      tagWrite(content$children, textConnWriter, 1, context)
       context$head <- append(context$head, textConnectionValue(textConn))
       close(textConn)
       return (FALSE)
@@ -101,10 +171,10 @@ renderPage <- function(ui, connection) {
   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"/>',
+               '  <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>', 
@@ -159,10 +229,15 @@ renderPage <- function(ui, connection) {
 #' @export
 shinyUI <- function(ui, path='/') {
   
+  force(ui)
+  
   registerClient({
     
-    function(ws, header) {
-      if (header$RESOURCE != path)
+    function(req) {
+      if (!identical(req$REQUEST_METHOD, 'GET'))
+        return(NULL)
+
+      if (req$PATH_INFO != path)
         return(NULL)
       
       textConn <- textConnection(NULL, "w") 
@@ -170,7 +245,7 @@ shinyUI <- function(ui, path='/') {
       
       renderPage(ui, textConn)
       html <- paste(textConnectionValue(textConn), collapse='\n')
-      return(http_response(ws, 200, content=html))
+      return(httpResponse(200, content=html))
     }
   })
 }

R/shinywrappers.R

@@ -5,53 +5,210 @@ suppressPackageStartupMessages({
 
 #' Plot Output
 #' 
-#' Creates a reactive plot that is suitable for assigning to an \code{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}.
-#' 
-#' @param func A function that generates a plot.
-#' @param width The width of the rendered plot, in pixels; or \code{'auto'} to use
-#'   the \code{offsetWidth} of the HTML element that is bound to this plot.
-#' @param height The height of the rendered plot, in pixels; or \code{'auto'} to use
-#'   the \code{offsetHeight} of the HTML element that is bound to this plot.
+#'
+#' @seealso For more details on how the plots are generated, and how to control
+#'   the output, see \code{\link{plotPNG}}.
+#'
+#' @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 res Resolution of resulting plot, in pixels per inch. This value is
+#'   passed to \code{\link{png}}. Note that this affects the resolution of PNG
+#'   rendering in R; it won't change the actual ppi of the browser.
 #' @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
-reactivePlot <- function(func, width='auto', height='auto', ...) {
+renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
+                       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(...)
   
-  return(function(shinyapp, name, ...) {
-    png.file <- tempfile(fileext='.png')
+  if (is.function(width))
+    widthWrapper <- reactive({ width() })
+  else
+    widthWrapper <- NULL
+
+  if (is.function(height))
+    heightWrapper <- reactive({ height() })
+  else
+    heightWrapper <- NULL
+
+  return(function(shinysession, name, ...) {
+    if (!is.null(widthWrapper))
+      width <- widthWrapper()
+    if (!is.null(heightWrapper))
+      height <- heightWrapper()
     
     # 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_'
+    prefix <- 'output_'
     if (width == 'auto')
-      width <- shinyapp$session$get(paste(prefix, name, '_width', sep=''));
+      width <- shinysession$clientData[[paste(prefix, name, '_width', sep='')]];
     if (height == 'auto')
-      height <- shinyapp$session$get(paste(prefix, name, '_height', sep=''));
+      height <- shinysession$clientData[[paste(prefix, name, '_height', sep='')]];
     
-    if (width <= 0 || height <= 0)
+    if (is.null(width) || is.null(height) || width <= 0 || height <= 0)
       return(NULL)
+
+    # Resolution multiplier
+    pixelratio <- shinysession$clientData$pixelratio
+    if (is.null(pixelratio))
+      pixelratio <- 1
+
+    outfile <- do.call(plotPNG, c(func, width=width*pixelratio,
+                                  height=height*pixelratio, res=res*pixelratio, args))
+    on.exit(unlink(outfile))
     
-    do.call(png, c(args, filename=png.file, width=width, height=height))
-    tryCatch(
-      func(),
-      finally=dev.off())
-    
-    bytes <- file.info(png.file)$size
-    if (is.na(bytes))
-      return(NULL)
-    
-    b64 <- base64encode(readBin(png.file, 'raw', n=bytes))
-    return(paste("data:image/png;base64,", b64, sep=''))
+    # Return a list of attributes for the img
+    return(list(
+      src=shinysession$fileUrl(name, outfile, contentType='image/png'),
+      width=width, height=height))
   })
 }
 
+#' Image file output
+#'
+#' Renders a reactive image that is suitable for assigning to an \code{output} 
+#' slot.
+#'
+#' The expression \code{expr} must return a list containing the attributes for
+#' the \code{img} object on the client web page. For the image to display,
+#' properly, the list must have at least one entry, \code{src}, which is the
+#' path to the image file. It may also useful to have a \code{contentType}
+#' entry specifying the MIME type of the image. If one is not provided,
+#' \code{renderImage} will try to autodetect the type, based on the file
+#' extension.
+#'
+#' Other elements such as \code{width}, \code{height}, \code{class}, and
+#' \code{alt}, can also be added to the list, and they will be used as
+#' attributes in the \code{img} object.
+#'
+#' The corresponding HTML output tag should be \code{div} or \code{img} and have
+#' the CSS class name \code{shiny-image-output}.
+#'
+#' @seealso For more details on how the images are generated, and how to control
+#'   the output, see \code{\link{plotPNG}}.
+#'
+#' @param expr An expression that returns a list.
+#' @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 deleteFile Should the file in \code{func()$src} be deleted after
+#'   it is sent to the client browser? Genrrally speaking, if the image is a
+#'   temp file generated within \code{func}, then this should be \code{TRUE};
+#'   if the image is not a temp file, this should be \code{FALSE}.
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#'
+#' shinyServer(function(input, output, clientData) {
+#'
+#'   # A plot of fixed size
+#'   output$plot1 <- renderImage({
+#'     # A temp file to save the output. It will be deleted after renderImage
+#'     # sends it, because deleteFile=TRUE.
+#'     outfile <- tempfile(fileext='.png')
+#'
+#'     # Generate a png
+#'     png(outfile, width=400, height=400)
+#'     hist(rnorm(input$n))
+#'     dev.off()
+#'
+#'     # Return a list
+#'     list(src = outfile,
+#'          alt = "This is alternate text")
+#'   }, deleteFile = TRUE)
+#'
+#'   # A dynamically-sized plot
+#'   output$plot2 <- renderImage({
+#'     # Read plot2's width and height. These are reactive values, so this
+#'     # expression will re-run whenever these values change.
+#'     width  <- clientData$output_plot2_width
+#'     height <- clientData$output_plot2_height
+#'
+#'     # A temp file to save the output.
+#'     outfile <- tempfile(fileext='.png')
+#'
+#'     png(outfile, width=width, height=height)
+#'     hist(rnorm(input$obs))
+#'     dev.off()
+#'
+#'     # Return a list containing the filename
+#'     list(src = outfile,
+#'          width = width,
+#'          height = height,
+#'          alt = "This is alternate text")
+#'   }, deleteFile = TRUE)
+#'
+#'   # Send a pre-rendered image, and don't delete the image after sending it
+#'   output$plot3 <- renderImage({
+#'     # When input$n is 1, filename is ./images/image1.jpeg
+#'     filename <- normalizePath(file.path('./images',
+#'                               paste('image', input$n, '.jpeg', sep='')))
+#'
+#'     # Return a list containing the filename
+#'     list(src = filename)
+#'   }, deleteFile = FALSE)
+#' })
+#'
+#' }
+renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
+                        deleteFile=TRUE) {
+  func <- exprToFunction(expr, env, quoted)
+
+  return(function(shinysession, name, ...) {
+    imageinfo <- func()
+    # Should the file be deleted after being sent? If .deleteFile not set or if
+    # TRUE, then delete; otherwise don't delete.
+    if (deleteFile) {
+      on.exit(unlink(imageinfo$src))
+    }
+
+    # If contentType not specified, autodetect based on extension
+    if (is.null(imageinfo$contentType)) {
+      contentType <- getContentType(sub('^.*\\.', '', basename(imageinfo$src)))
+    } else {
+      contentType <- imageinfo$contentType
+    }
+
+    # Extra values are everything in imageinfo except 'src' and 'contentType'
+    extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
+
+    # Return a list with src, and other img attributes
+    c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
+      extra_attr)
+  })
+}
+
+
 #' Table Output
 #' 
 #' Creates a reactive table that is suitable for assigning to an \code{output} 
@@ -60,32 +217,49 @@ reactivePlot <- function(func, width='auto', height='auto', ...) {
 #' The corresponding HTML output tag should be \code{div} and have the CSS class
 #' name \code{shiny-html-output}.
 #' 
-#' @param func A function that returns an R object that can be used with 
+#' @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}}.
+#' @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
-reactiveTable <- function(func, ...) {
-  reactive(function() {
+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) || identical(data, data.frame()))
+      return("")
+    
     return(paste(
       capture.output(
         print(xtable(data, ...), 
               type='html', 
               html.table.attributes=paste('class="',
-                                          htmlEscape(classNames, T),
+                                          htmlEscape(classNames, TRUE),
                                           '"',
-                                          sep=''))),
+                                          sep=''), ...)),
       collapse="\n"))
-  })
+  }
 }
 
 #' Printable Output
 #' 
-#' Makes a reactive version of the given function that also turns its printable
-#' result into a string. The reactive function is suitable for assigning to an 
-#' \code{output} slot.
+#' 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
@@ -94,13 +268,37 @@ reactiveTable <- function(func, ...) {
 #' The result of executing \code{func} will be printed inside a 
 #' \code{\link[utils]{capture.output}} call.
 #' 
-#' @param func A function that returns a printable R object.
+#' 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
-reactivePrint <- function(func) {
-  reactive(function() {
-    return(paste(capture.output(print(func())), collapse="\n"))
-  })
+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
@@ -116,12 +314,176 @@ reactivePrint <- function(func) {
 #' The result of executing \code{func} will passed to \code{cat}, inside a 
 #' \code{\link[utils]{capture.output}} call.
 #' 
-#' @param func A function that returns an R object that can be used as an
+#' @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
-reactiveText <- function(func) {
-  reactive(function() {
-    return(paste(capture.output(cat(func())), collapse="\n"))
+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(shinysession, name, ...) {
+    shinysession$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=width, height=height, ...)
+}
+
+#' 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

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

R/tags.R

@@ -16,7 +16,7 @@ htmlEscape <- local({
   )
   .htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse='|')
   
-  function(text, attribute=T) {
+  function(text, attribute=TRUE) {
     pattern <- if(attribute)
       .htmlSpecialsPatternAttrib 
     else
@@ -32,7 +32,7 @@ htmlEscape <- local({
       .htmlSpecials
     
     for (chr in names(specials)) {
-      text <- gsub(chr, specials[[chr]], text, fixed=T)
+      text <- gsub(chr, specials[[chr]], text, fixed=TRUE)
     }
     
     return(text)
@@ -61,9 +61,18 @@ as.character.shiny.tag <- function(x, ...) {
     cat(text, file=f)
   }
   tagWrite(x, textWriter)
-  return(HTML(paste(readLines(f), collapse='\n')))
+  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
@@ -72,95 +81,57 @@ normalizeText <- function(text) {
   
 }
 
+#' @export
+tagList <- function(...) {
+  lst <- list(...)
+  class(lst) <- c("shiny.tag.list", "list")
+  return(lst)
+}
+
 #' @export
 tagAppendChild <- function(tag, child) {
   tag$children[[length(tag$children)+1]] <- child
   tag
 }
 
+#' @export
+tagAppendChildren <- function(tag, ..., list = NULL) {
+  tag$children <- c(tag$children, c(list(...), list))
+  tag
+}
+
+#' @export
+tagSetChildren <- function(tag, ..., list = NULL) {
+  tag$children <- c(list(...), list)
+  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
+  # Get arg names; if not a named list, use vector of empty strings
   varArgsNames <- names(varArgs)
   if (is.null(varArgsNames))
     varArgsNames <- character(length=length(varArgs))
+
+  # Named arguments become attribs, dropping NULL values
+  named_idx <- nzchar(varArgsNames)
+  attribs <- dropNulls(varArgs[named_idx])
   
-  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)
+  # Unnamed arguments are flattened and added as children.
+  # Use unname() to remove the names attribute from the list, which would
+  # consist of empty strings anyway.
+  children <- flattenTags(unname(varArgs[!named_idx]))
+
+  # Return tag data structure
+  structure(
+    list(name = `_tag_name`,
+         attribs = attribs,
+         children = children),
+    class = "shiny.tag"
+  )
 }
 
-tagWriteChildren <- function(tag, textWriter, indent, context) {
-  for (child in tag$children) {
-    if (isTag(child)) {
-      tagWrite(child, textWriter, indent, context)
-    }
-    else {
-      # first call optional filter -- exit function if it returns false
-      if (is.null(context) || is.null(context$filter) || context$filter(child)) {
-        child <- normalizeText(child)
-        indentText <- paste(rep(" ", indent*3), collapse="")
-        textWriter(paste(indentText, child, "\n", sep=""))
-      }
-    }
-  }
-}
-
-tagWrite <- function(tag, textWriter, indent=0, context = NULL) {
+tagWrite <- function(tag, textWriter, indent=0, context = NULL, eol = "\n") {
   
   # optionally process a list of tags
   if (!isTag(tag) && is.list(tag)) {
@@ -173,7 +144,13 @@ tagWrite <- function(tag, textWriter, indent=0, context = NULL) {
     return (NULL)
   
   # compute indent text
-  indentText <- paste(rep(" ", indent*3), collapse="")
+  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=""))
@@ -194,19 +171,18 @@ tagWrite <- function(tag, textWriter, indent=0, context = NULL) {
   
   # 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]]) ) {
-      if (is.null(context) || is.null(context$filter) 
-          || context$filter(tag$children[[1]])) {
-        text <- normalizeText(tag$children[[1]])
-        textWriter(paste(">", text, "</", tag$name, ">\n", sep=""))
-      }
+      tagWrite(tag$children[[1]], textWriter, 0, context, "")
+      textWriter(paste("</", tag$name, ">", eol, sep=""))
     }
     else {
-      textWriter(">\n")
-      tagWriteChildren(tag, textWriter, indent+1, context)
-      textWriter(paste(indentText, "</", tag$name, ">\n", sep=""))
+      textWriter("\n")
+      for (child in tag$children)
+        tagWrite(child, textWriter, indent+1, context)
+      textWriter(paste(indentText, "</", tag$name, ">", eol, sep=""))
     }
   }
   else {
@@ -215,129 +191,129 @@ tagWrite <- function(tag, textWriter, indent=0, context = NULL) {
     if (tag$name %in% c("area", "base", "br", "col", "command", "embed", "hr", 
                         "img", "input", "keygen", "link", "meta", "param",
                         "source", "track", "wbr")) {
-      textWriter("/>\n")
+      textWriter(paste("/>", eol, sep=""))
     }
     else {
-      textWriter(paste("></", tag$name, ">\n", sep=""))
+      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(...))
+tags <- list(
+  a = function(...) tag("a", list(...)),
+  abbr = function(...) tag("abbr", list(...)),
+  address = function(...) tag("address", list(...)),
+  area = function(...) tag("area", list(...)),
+  article = function(...) tag("article", list(...)),
+  aside = function(...) tag("aside", list(...)),
+  audio = function(...) tag("audio", list(...)),
+  b = function(...) tag("b", list(...)),
+  base = function(...) tag("base", list(...)),
+  bdi = function(...) tag("bdi", list(...)),
+  bdo = function(...) tag("bdo", list(...)),
+  blockquote = function(...) tag("blockquote", list(...)),
+  body = function(...) tag("body", list(...)),
+  br = function(...) tag("br", list(...)),
+  button = function(...) tag("button", list(...)),
+  canvas = function(...) tag("canvas", list(...)),
+  caption = function(...) tag("caption", list(...)),
+  cite = function(...) tag("cite", list(...)),
+  code = function(...) tag("code", list(...)),
+  col = function(...) tag("col", list(...)),
+  colgroup = function(...) tag("colgroup", list(...)),
+  command = function(...) tag("command", list(...)),
+  data = function(...) tag("data", list(...)),
+  datalist = function(...) tag("datalist", list(...)),
+  dd = function(...) tag("dd", list(...)),
+  del = function(...) tag("del", list(...)),
+  details = function(...) tag("details", list(...)),
+  dfn = function(...) tag("dfn", list(...)),
+  div = function(...) tag("div", list(...)),
+  dl = function(...) tag("dl", list(...)),
+  dt = function(...) tag("dt", list(...)),
+  em = function(...) tag("em", list(...)),
+  embed = function(...) tag("embed", list(...)),
+  eventsource = function(...) tag("eventsource", list(...)),
+  fieldset = function(...) tag("fieldset", list(...)),
+  figcaption = function(...) tag("figcaption", list(...)),
+  figure = function(...) tag("figure", list(...)),
+  footer = function(...) tag("footer", list(...)),
+  form = function(...) tag("form", list(...)),
+  h1 = function(...) tag("h1", list(...)),
+  h2 = function(...) tag("h2", list(...)),
+  h3 = function(...) tag("h3", list(...)),
+  h4 = function(...) tag("h4", list(...)),
+  h5 = function(...) tag("h5", list(...)),
+  h6 = function(...) tag("h6", list(...)),
+  head = function(...) tag("head", list(...)),
+  header = function(...) tag("header", list(...)),
+  hgroup = function(...) tag("hgroup", list(...)),
+  hr = function(...) tag("hr", list(...)),
+  html = function(...) tag("html", list(...)),
+  i = function(...) tag("i", list(...)),
+  iframe = function(...) tag("iframe", list(...)),
+  img = function(...) tag("img", list(...)),
+  input = function(...) tag("input", list(...)),
+  ins = function(...) tag("ins", list(...)),
+  kbd = function(...) tag("kbd", list(...)),
+  keygen = function(...) tag("keygen", list(...)),
+  label = function(...) tag("label", list(...)),
+  legend = function(...) tag("legend", list(...)),
+  li = function(...) tag("li", list(...)),
+  link = function(...) tag("link", list(...)),
+  mark = function(...) tag("mark", list(...)),
+  map = function(...) tag("map", list(...)),
+  menu = function(...) tag("menu", list(...)),
+  meta = function(...) tag("meta", list(...)),
+  meter = function(...) tag("meter", list(...)),
+  nav = function(...) tag("nav", list(...)),
+  noscript = function(...) tag("noscript", list(...)),
+  object = function(...) tag("object", list(...)),
+  ol = function(...) tag("ol", list(...)),
+  optgroup = function(...) tag("optgroup", list(...)),
+  option = function(...) tag("option", list(...)),
+  output = function(...) tag("output", list(...)),
+  p = function(...) tag("p", list(...)),
+  param = function(...) tag("param", list(...)),
+  pre = function(...) tag("pre", list(...)),
+  progress = function(...) tag("progress", list(...)),
+  q = function(...) tag("q", list(...)),
+  ruby = function(...) tag("ruby", list(...)),
+  rp = function(...) tag("rp", list(...)),
+  rt = function(...) tag("rt", list(...)),
+  s = function(...) tag("s", list(...)),
+  samp = function(...) tag("samp", list(...)),
+  script = function(...) tag("script", list(...)),
+  section = function(...) tag("section", list(...)),
+  select = function(...) tag("select", list(...)),
+  small = function(...) tag("small", list(...)),
+  source = function(...) tag("source", list(...)),
+  span = function(...) tag("span", list(...)),
+  strong = function(...) tag("strong", list(...)),
+  style = function(...) tag("style", list(...)),
+  sub = function(...) tag("sub", list(...)),
+  summary = function(...) tag("summary", list(...)),
+  sup = function(...) tag("sup", list(...)),
+  table = function(...) tag("table", list(...)),
+  tbody = function(...) tag("tbody", list(...)),
+  td = function(...) tag("td", list(...)),
+  textarea = function(...) tag("textarea", list(...)),
+  tfoot = function(...) tag("tfoot", list(...)),
+  th = function(...) tag("th", list(...)),
+  thead = function(...) tag("thead", list(...)),
+  time = function(...) tag("time", list(...)),
+  title = function(...) tag("title", list(...)),
+  tr = function(...) tag("tr", list(...)),
+  track = function(...) tag("track", list(...)),
+  u = function(...) tag("u", list(...)),
+  ul = function(...) tag("ul", list(...)),
+  var = function(...) tag("var", list(...)),
+  video = function(...) tag("video", list(...)),
+  wbr = function(...) tag("wbr", list(...))
+)
 
 #' Mark Characters as HTML
 #' 
@@ -361,4 +337,66 @@ HTML <- function(text, ...) {
   htmlText
 }
 
+#' Evaluate an expression using the \code{tags}
+#'
+#' This function makes it simpler to write HTML-generating code. Instead of
+#' needing to specify \code{tags} each time a tag function is used, as in
+#' \code{tags$div()} and \code{tags$p()}, code inside \code{withTags} is
+#' evaluated with \code{tags} searched first, so you can simply use
+#' \code{div()} and \code{p()}.
+#'
+#' If your code uses an object which happens to have the same name as an
+#' HTML tag function, such as \code{source()} or \code{summary()}, it will call
+#' the tag function. To call the intended (non-tags function), specify the
+#' namespace, as in \code{base::source()} or \code{base::summary()}.
+#'
+#' @param code A set of tags.
+#'
+#' @examples
+#' # Using tags$ each time
+#' tags$div(class = "myclass",
+#'   tags$h3("header"),
+#'   tags$p("text")
+#' )
+#'
+#' # Equivalent to above, but using withTags
+#' withTags(
+#'   div(class = "myclass",
+#'     h3("header"),
+#'     p("text")
+#'   )
+#' )
+#'
+#'
+#' @export
+withTags <- function(code) {
+  eval(substitute(code), envir = as.list(tags), enclos = parent.frame())
+}
 
+
+# Given a list of tags, lists, and other items, return a flat list, where the
+# items from the inner, nested lists are pulled to the top level, recursively.
+flattenTags <- function(x) {
+  if (isTag(x)) {
+    # For tags, wrap them into a list (which will be unwrapped by caller)
+    list(x)
+  } else if (is.list(x)) {
+    if (length(x) == 0) {
+      # Empty lists are simply returned
+      x
+    } else {
+      # For items that are lists (but not tags), recurse
+      unlist(lapply(x, flattenTags), recursive = FALSE)
+    }
+
+  } else if (is.character(x)){
+    # This will preserve attributes if x is a character with attribute,
+    # like what HTML() produces
+    list(x)
+
+  } else {
+    # For other items, coerce to character and wrap them into a list (which
+    # will be unwrapped by caller). Note that this will strip attributes.
+    list(as.character(x))
+  }
+}

R/tar.R

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

R/timer.R

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

R/update-input.R

@@ -0,0 +1,405 @@
+#' Change the value of a text input on the client
+#'
+#' @template update-input
+#' @param value The value to set for the input object.
+#'
+#' @seealso \code{\link{textInput}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     # This will change the value of input$inText, based on x
+#'     updateTextInput(session, "inText", value = paste("New text", x))
+#'
+#'     # Can also set the label, this time for input$inText2
+#'     updateTextInput(session, "inText2",
+#'       label = paste("New label", x),
+#'       value = paste("New text", x))
+#'   })
+#' })
+#' }
+#' @export
+updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
+  message <- dropNulls(list(label=label, value=value))
+  session$sendInputMessage(inputId, message)
+}
+
+
+#' Change the value of a checkbox input on the client
+#'
+#' @template update-input
+#' @param value The value to set for the input object.
+#'
+#' @seealso \code{\link{checkboxInput}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # TRUE if input$controller is even, FALSE otherwise.
+#'     x_even <- input$controller %% 2 == 0
+#'
+#'     updateCheckboxInput(session, "inCheckbox", value = x_even)
+#'   })
+#' })
+#' }
+#' @export
+updateCheckboxInput <- updateTextInput
+
+
+#' Change the value of a slider input on the client
+#'
+#' @template update-input
+#' @param value The value to set for the input object.
+#'
+#' @seealso \code{\link{sliderInput}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     # Similar to number and text. only label and value can be set for slider
+#'     updateSliderInput(session, "inSlider",
+#'       label = paste("Slider label", x),
+#'       value = x)
+#'
+#'     # For sliders that pick out a range, pass in a vector of 2 values.
+#'     updateSliderInput(session, "inSlider2", value = c(x-1, x+1))
+#'
+#'     # An NA means to not change that value (the low or high one)
+#'     updateSliderInput(session, "inSlider3", value = c(NA, x+2))
+#'   })
+#' })
+#' }
+#' @export
+updateSliderInput <- updateTextInput
+
+#' Change the value of a date input on the client
+#'
+#' @template update-input
+#' @param value The desired date value. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format.
+#' @param min The minimum allowed date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format.
+#' @param max The maximum allowed date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format.
+#'
+#' @seealso \code{\link{dateInput}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     updateDateInput(session, "inDate",
+#'       label = paste("Date label", x),
+#'       value = paste("2013-04-", x, sep=""),
+#'       min   = paste("2013-04-", x-1, sep=""),
+#'       max   = paste("2013-04-", x+1, sep="")
+#'     )
+#'   })
+#' })
+#' }
+#' @export
+updateDateInput <- function(session, inputId, label = NULL, value = NULL,
+    min = NULL, max = NULL) {
+
+  # If value is a date object, convert it to a string with yyyy-mm-dd format
+  # Same for min and max
+  if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
+  if (inherits(min, "Date"))    min   <- format(min,   "%Y-%m-%d")
+  if (inherits(max, "Date"))    max   <- format(max,   "%Y-%m-%d")
+
+  message <- dropNulls(list(label=label, value=value, min=min, max=max))
+  session$sendInputMessage(inputId, message)
+}
+
+
+#' Change the start and end values of a date range input on the client
+#'
+#' @template update-input
+#' @param start The start date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format.
+#' @param end The end date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format.
+#' @param min The minimum allowed date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format.
+#' @param max The maximum allowed date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format.
+#'
+#' @seealso \code{\link{dateRangeInput}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     updateDateRangeInput(session, "inDateRange",
+#'       label = paste("Date range label", x),
+#'       start = paste("2013-01-", x, sep=""))
+#'       end = paste("2013-12-", x, sep=""))
+#'   })
+#' })
+#' }
+#' @export
+updateDateRangeInput <- function(session, inputId, label = NULL,
+    start = NULL, end = NULL, min = NULL, max = NULL) {
+
+  # Make sure start and end are strings, not date objects. This is for
+  # consistency across different locales.
+  if (inherits(start, "Date"))  start <- format(start, '%Y-%m-%d')
+  if (inherits(end, "Date"))    end <- format(end, '%Y-%m-%d')
+  if (inherits(min, "Date"))    min <- format(min, '%Y-%m-%d')
+  if (inherits(max, "Date"))    max <- format(max, '%Y-%m-%d')
+
+  message <- dropNulls(list(
+    label = label,
+    value = c(start, end),
+    min = min,
+    max = max
+  ))
+
+  session$sendInputMessage(inputId, message)
+}
+
+#' Change the selected tab on the client
+#'
+#' @param session The \code{session} object passed to function given to
+#'   \code{shinyServer}.
+#' @param inputId The id of the tabset panel object.
+#' @param selected The name of the tab to make active.
+#'
+#' @seealso \code{\link{tabsetPanel}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # TRUE if input$controller is even, FALSE otherwise.
+#'     x_even <- input$controller %% 2 == 0
+#'
+#'     # Change the selected tab.
+#'     # Note that the tabsetPanel must have been created with an 'id' argument
+#'     if (x_even) {
+#'       updateTabsetPanel(session, "inTabset", selected = "panel2")
+#'     } else {
+#'       updateTabsetPanel(session, "inTabset", selected = "panel1")
+#'     }
+#'   })
+#' })
+#' }
+#' @export
+updateTabsetPanel <- function(session, inputId, selected = NULL) {
+  message <- dropNulls(list(value = selected))
+  session$sendInputMessage(inputId, message)
+}
+
+
+#' Change the value of a number input on the client
+#'
+#' @template update-input
+#' @param value The value to set for the input object.
+#' @param min Minimum value.
+#' @param max Maximum value.
+#' @param step Step size.
+#'
+#' @seealso \code{\link{numericInput}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     updateNumericInput(session, "inNumber", value = x)
+#'
+#'     updateNumericInput(session, "inNumber2",
+#'       label = paste("Number label ", x),
+#'       value = x, min = x-10, max = x+10, step = 5)
+#'   })
+#' })
+#' }
+#' @export
+updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
+    min = NULL, max = NULL, step = NULL) {
+
+  message <- dropNulls(list(label=label, value=value, min=min, max=max, step=step))
+  session$sendInputMessage(inputId, message)
+}
+
+
+#' Change the value of a checkbox group input on the client
+#'
+#' @template update-input
+#' @param choices A named vector or named list of options. For each item, the
+#'   name will be used as the label, and the value will be used as the value.
+#' @param selected A vector or list of options which will be selected.
+#'
+#' @seealso \code{\link{checkboxGroupInput}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     # Create a list of new options, where the name of the items is something
+#'     # like 'option label x 1', and the values are 'option-x-1'.
+#'     cb_options <- list()
+#'     cb_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
+#'     cb_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
+#'
+#'     # Change values for input$inCheckboxGroup
+#'     updateCheckboxGroupInput(session, "inCheckboxGroup", choices = cb_options)
+#'
+#'     # Can also set the label and select items
+#'     updateCheckboxGroupInput(session, "inCheckboxGroup2",
+#'       label = paste("checkboxgroup label", x),
+#'       choices = cb_options,
+#'       selected = sprintf("option label %d 2", x)
+#'     )
+#'   })
+#' })
+#' }
+#' @export
+updateCheckboxGroupInput <- function(session, inputId, label = NULL,
+  choices = NULL, selected = NULL) {
+
+  choices <- choicesWithNames(choices)
+
+  options <- mapply(choices, names(choices),
+    SIMPLIFY = FALSE, USE.NAMES = FALSE,
+    FUN = function(value, name) {
+      list(value = value,
+           label = name,
+           checked = name %in% selected)
+    }
+  )
+
+  message <- dropNulls(list(label = label, options = options))
+
+  session$sendInputMessage(inputId, message)
+}
+
+
+#' Change the value of a radio input on the client
+#'
+#' @template update-input
+#' @param choices A named vector or named list of options. For each item, the
+#'   name will be used as the label, and the value will be used as the value.
+#' @param selected A vector or list of options which will be selected.
+#'
+#' @seealso \code{\link{radioButtons}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     r_options <- list()
+#'     r_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
+#'     r_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
+#'
+#'     # Change values for input$inRadio
+#'     updateRadioButtons(session, "inRadio", choices = r_options)
+#'
+#'     # Can also set the label and select an item
+#'     updateRadioButtons(session, "inRadio2",
+#'       label = paste("Radio label", x),
+#'       choices = r_options,
+#'       selected = sprintf("option label %d 2", x)
+#'     )
+#'   })
+#' })
+#' }
+#' @export
+updateRadioButtons <- updateCheckboxGroupInput
+
+
+#' Change the value of a select input on the client
+#'
+#' @template update-input
+#' @param choices A named vector or named list of options. For each item, the
+#'   name will be used as the label, and the value will be used as the value.
+#' @param selected A vector or list of options which will be selected.
+#'
+#' @seealso \code{\link{selectInput}}
+#'
+#' @examples
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
+#'
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     # Create a list of new options, where the name of the items is something
+#'     # like 'option label x 1', and the values are 'option-x-1'.
+#'     s_options <- list()
+#'     s_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
+#'     s_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
+#'
+#'     # Change values for input$inSelect
+#'     updateSelectInput(session, "inSelect", choices = s_options)
+#'
+#'     # Can also set the label and select an item (or more than one if it's a
+#'     # multi-select)
+#'     updateSelectInput(session, "inSelect2",
+#'       label = paste("Select label", x),
+#'       choices = s_options,
+#'       selected = sprintf("option label %d 2", x)
+#'     )
+#'   })
+#' })
+#' }
+#' @export
+updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
+    selected = NULL) {
+
+  choices <- choicesWithNames(choices)
+
+  options <- mapply(choices, names(choices),
+    SIMPLIFY = FALSE, USE.NAMES = FALSE,
+    FUN = function(value, name) {
+      list(value = value,
+           label = name,
+           selected = name %in% selected)
+    }
+  )
+
+  message <- dropNulls(list(label = label, options = options))
+
+  session$sendInputMessage(inputId, message)
+}

R/utils.R

@@ -0,0 +1,310 @@
+#' 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='')
+}
+
+# Given a vector or list, drop all the NULL items in it
+dropNulls <- function(x) {
+  x[!vapply(x, is.null, FUN.VALUE=logical(1))]
+}
+
+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)
+  }
+}
+
+#' Parse a GET query string from a URL
+#'
+#' Returns a named character vector of key-value pairs.
+#'
+#' @param str The query string. It can have a leading \code{"?"} or not.
+#' @export
+#' @examples
+#' parseQueryString("?foo=1&bar=b%20a%20r")
+#'
+#' \dontrun{
+#' # Example of usage within a Shiny app
+#' shinyServer(function(input, output, clientData) {
+#'
+#'   output$queryText <- renderText({
+#'     query <- parseQueryString(clientData$url_search)
+#'
+#'     # Ways of accessing the values
+#'     if (as.numeric(query$foo) == 1) {
+#'       # Do something
+#'     }
+#'     if (query[["bar"]] == "targetstring") {
+#'       # Do something else
+#'     }
+#'
+#'     # Return a string with key-value pairs
+#'     paste(names(query), query, sep = "=", collapse=", ")
+#'   })
+#' })
+#' }
+#'
+parseQueryString <- function(str) {
+  if (is.null(str) || nchar(str) == 0)
+    return(list())
+
+  # Remove leading ?
+  if (substr(str, 1, 1) == '?')
+    str <- substr(str, 2, nchar(str))
+
+  pairs <- strsplit(str, '&', fixed = TRUE)[[1]]
+  pairs <- strsplit(pairs, '=', fixed = TRUE)
+
+  keys   <- vapply(pairs, function(x) x[1], FUN.VALUE = character(1))
+  values <- vapply(pairs, function(x) x[2], FUN.VALUE = character(1))
+  # Replace NA with '', so they don't get converted to 'NA' by URLdecode
+  values[is.na(values)] <- ''
+
+  # Convert "+" to " ", since URLdecode doesn't do it
+  keys   <- gsub('+', ' ', keys,   fixed = TRUE)
+  values <- gsub('+', ' ', values, fixed = TRUE)
+
+  keys   <- vapply(keys,   function(x) URLdecode(x), FUN.VALUE = character(1))
+  values <- vapply(values, function(x) URLdecode(x), FUN.VALUE = character(1))
+
+  setNames(as.list(values), keys)
+}
+
+#' 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)
+}
+
+Callbacks <- setRefClass(
+  'Callbacks',
+  fields = list(
+    .nextId = 'integer',
+    .callbacks = 'Map'
+  ),
+  methods = list(
+    initialize = function() {
+      .nextId <<- as.integer(.Machine$integer.max)
+    },
+    register = function(callback) {
+      id <- as.character(.nextId)
+      .nextId <<- .nextId - 1L
+      .callbacks$set(id, callback)
+      return(function() {
+        .callbacks$remove(id)
+      })
+    },
+    invoke = function(..., onError=NULL) {
+      for (callback in .callbacks$values()) {
+        tryCatch(
+          do.call(callback, list(...)),
+          error = function(e) {
+            if (is.null(onError))
+              stop(e)
+            else
+              onError(e)
+          }
+        )
+      }
+    },
+    count = function() {
+      .callbacks$size()
+    }
+  )
+)

README.md

@@ -2,6 +2,8 @@
 
 Shiny is a new package from RStudio that makes it incredibly easy to build interactive web applications with R.
 
+For an introduction and examples, visit the [Shiny homepage](http://www.rstudio.com/shiny/).
+
 ## Features
 
 * Build useful web applications with only a few lines of code—no JavaScript required.
@@ -20,7 +22,6 @@ Shiny is a new package from RStudio that makes it incredibly easy to build inter
 From an R console:
 
 ```r
-options(repos=c(RStudio="http://rstudio.org/_packages", getOption("repos")))
 install.packages("shiny")
 ```
 

inst/NOTICE

@@ -4,6 +4,7 @@ these components are included below):
 
 - jQuery
 - Bootstrap
+- bootstrap-datepicker, from https://github.com/eternicode/bootstrap-datepicker
 - jslider
 
 
@@ -33,7 +34,7 @@ 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
+Bootstrap and bootstrap-datepicker License
 ----------------------------------------------------------------------   
 
                                  Apache License

inst/examples/01_hello/server.R

@@ -3,14 +3,14 @@ library(shiny)
 # Define server logic required to generate and plot a random distribution
 shinyServer(function(input, output) {
    
-  # Function that generates a plot of the distribution. The function
-  # is wrapped in a call to reactivePlot to indicate that:
+  # 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 <- reactivePlot(function() {
+  output$distPlot <- renderPlot({
         
     # generate an rnorm distribution and plot it
     dist <- rnorm(input$obs)

inst/examples/02_text/server.R

@@ -5,7 +5,7 @@ library(datasets)
 shinyServer(function(input, output) {
   
   # Return the requested dataset
-  datasetInput <- reactive(function() {
+  datasetInput <- reactive({
     switch(input$dataset,
            "rock" = rock,
            "pressure" = pressure,
@@ -13,13 +13,13 @@ shinyServer(function(input, output) {
   })
   
   # Generate a summary of the dataset
-  output$summary <- reactivePrint(function() {
+  output$summary <- renderPrint({
     dataset <- datasetInput()
     summary(dataset)
   })
   
   # Show the first "n" observations
-  output$view <- reactiveTable(function() {
+  output$view <- renderTable({
     head(datasetInput(), n = input$obs)
   })
 })

inst/examples/03_reactivity/server.R

@@ -4,47 +4,47 @@ library(datasets)
 # Define server logic required to summarize and view the selected dataset
 shinyServer(function(input, output) {
 
-  # By declaring databaseInput as a reactive function we ensure that:
+  # 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 function is re-executed, the
+  #  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(function() {
+  datasetInput <- reactive({
     switch(input$dataset,
            "rock" = rock,
            "pressure" = pressure,
            "cars" = cars)
   })
   
-  # The output$caption is computed based on a reactive function that
+  # 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 functions below don't 
-  # depend on input$caption, those functions are NOT called when 
+  # 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 <- reactiveText(function() {
+  output$caption <- renderText({
     input$caption
   })
   
-  # The output$summary depends on the datasetInput reactive function, 
+  # 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 <- reactivePrint(function() {
+  output$summary <- renderPrint({
     dataset <- datasetInput()
     summary(dataset)
   })
   
-  # The output$view depends on both the databaseInput reactive function
+  # 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 <- reactiveTable(function() {
+  output$view <- renderTable({
     head(datasetInput(), n = input$obs)
   })
 })

inst/examples/04_mpg/server.R

@@ -11,20 +11,20 @@ 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 function since it is 
+  # Compute the forumla text in a reactive expression since it is 
   # shared by the output$caption and output$mpgPlot functions
-  formulaText <- reactive(function() {
+  formulaText <- reactive({
     paste("mpg ~", input$variable)
   })
    
   # Return the formula text for printing as a caption
-  output$caption <- reactiveText(function() {
+  output$caption <- renderText({
     formulaText()
   })
   
   # Generate a plot of the requested variable against mpg and only 
   # include outliers if requested
-  output$mpgPlot <- reactivePlot(function() {
+  output$mpgPlot <- renderPlot({
     boxplot(as.formula(formulaText()), 
             data = mpgData,
             outline = input$outliers)

inst/examples/04_mpg/ui.R

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

inst/examples/05_sliders/server.R

@@ -3,8 +3,8 @@ library(shiny)
 # Define server logic for slider examples
 shinyServer(function(input, output) {
   
-  # Reactive function to compose a data frame containing all of the values
-  sliderValues <- reactive(function() {
+  # Reactive expression to compose a data frame containing all of the values
+  sliderValues <- reactive({
     
     # Compose data frame
     data.frame(
@@ -22,7 +22,7 @@ shinyServer(function(input, output) {
   }) 
   
   # Show the values using an HTML table
-  output$values <- reactiveTable(function() {
+  output$values <- renderTable({
     sliderValues()
   })
 })

inst/examples/05_sliders/ui.R

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

inst/examples/06_tabsets/server.R

@@ -3,10 +3,10 @@ library(shiny)
 # Define server logic for random distribution application
 shinyServer(function(input, output) {
   
-  # Reactive function to generate the requested distribution. This is 
+  # 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 function
-  data <- reactive(function() {  
+  # below then all use the value computed from this expression
+  data <- reactive({
     dist <- switch(input$dist,
                    norm = rnorm,
                    unif = runif,
@@ -19,9 +19,9 @@ shinyServer(function(input, output) {
   
   # 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 function are both tracked, and all functions 
+  # the data reactive expression are both tracked, and all expressions 
   # are called in the sequence implied by the dependency graph
-  output$plot <- reactivePlot(function() {
+  output$plot <- renderPlot({
     dist <- input$dist
     n <- input$n
     
@@ -30,12 +30,12 @@ shinyServer(function(input, output) {
   })
   
   # Generate a summary of the data
-  output$summary <- reactivePrint(function() {
+  output$summary <- renderPrint({
     summary(data())
   })
   
   # Generate an HTML table view of the data
-  output$table <- reactiveTable(function() {
+  output$table <- renderTable({
     data.frame(x=data())
   })
   

inst/examples/06_tabsets/ui.R

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

inst/examples/07_widgets/server.R

@@ -5,7 +5,7 @@ library(datasets)
 shinyServer(function(input, output) {
   
   # Return the requested dataset
-  datasetInput <- reactive(function() {
+  datasetInput <- reactive({
     switch(input$dataset,
            "rock" = rock,
            "pressure" = pressure,
@@ -13,13 +13,13 @@ shinyServer(function(input, output) {
   })
   
   # Generate a summary of the dataset
-  output$summary <- reactivePrint(function() {
+  output$summary <- renderPrint({
     dataset <- datasetInput()
     summary(dataset)
   })
   
   # Show the first "n" observations
-  output$view <- reactiveTable(function() {
+  output$view <- renderTable({
     head(datasetInput(), n = input$obs)
   })
 })

inst/examples/08_html/server.R

@@ -3,10 +3,10 @@ library(shiny)
 # Define server logic for random distribution application
 shinyServer(function(input, output) {
   
-  # Reactive function to generate the requested distribution. This is 
-  # called whenever the inputs change. The output functions defined 
-  # below then all used the value computed from this function
-  data <- reactive(function() {  
+  # 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,
@@ -19,9 +19,9 @@ shinyServer(function(input, output) {
   
   # 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 function are both tracked, and all functions 
+  # the data reactive expression are both tracked, and all expressions 
   # are called in the sequence implied by the dependency graph
-  output$plot <- reactivePlot(function() {
+  output$plot <- renderPlot({
     dist <- input$dist
     n <- input$n
     
@@ -30,12 +30,12 @@ shinyServer(function(input, output) {
   })
   
   # Generate a summary of the data
-  output$summary <- reactivePrint(function() {
+  output$summary <- renderPrint({
     summary(data())
   })
   
   # Generate an HTML table view of the data
-  output$table <- reactiveTable(function() {
+  output$table <- renderTable({
     data.frame(x=data())
   })
   

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 'datapath' 
+    # columns. The 'datapath' column will contain the local filenames where the 
+    # data can be found.
+
+    inFile <- input$file1
+
+    if (is.null(inFile))
+      return(NULL)
+    
+    read.csv(inFile$datapath, header=input$header, sep=input$sep, quote=input$quote)
+  })
+})

inst/examples/09_upload/ui.R

@@ -0,0 +1,24 @@
+library(shiny)
+
+shinyUI(pageWithSidebar(
+  headerPanel("Uploading Files"),
+  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/examples/11_timer/server.R

@@ -0,0 +1,6 @@
+shinyServer(function(input, output) {
+  output$currentTime <- renderText({
+    invalidateLater(1000)
+    paste("The current time is", Sys.time())
+  })
+})

inst/examples/11_timer/ui.R

@@ -0,0 +1,3 @@
+shinyUI(bootstrapPage(
+  textOutput("currentTime")
+))

inst/tests-js/SpecRunner.html

@@ -0,0 +1,95 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+  "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+  <title>Jasmine Spec Runner</title>
+
+  <link rel="shortcut icon" type="image/png" href="lib/jasmine-1.3.1/jasmine_favicon.png">
+  <link rel="stylesheet" type="text/css" href="lib/jasmine-1.3.1/jasmine.css">
+  <script type="text/javascript" src="lib/jasmine-1.3.1/jasmine.js"></script>
+  <script type="text/javascript" src="lib/jasmine-1.3.1/jasmine-html.js"></script>
+
+  <!-- include source files here... -->
+
+  <!-- All of these includes are copied out of the HTML file generated by
+  shinyUI() -->
+  <script src="../www/shared/jquery.js" type="text/javascript"></script>
+  <script src="../www/shared/shiny.js" type="text/javascript"></script>
+  <link rel="stylesheet" type="text/css" href="../www/shared/shiny.css"/>
+  <link rel="stylesheet" type="text/css" href="../www/shared/slider/css/jquery.slider.min.css"/>
+  <script src="../www/shared/slider/js/jquery.slider.min.js"></script>
+  <link rel="stylesheet" type="text/css" href="../www/shared/bootstrap/css/bootstrap.min.css"/>
+  <script src="../www/shared/bootstrap/js/bootstrap.min.js"></script>
+  <!-- <meta name="viewport" content="width=device-width, initial-scale=1.0"/> -->
+  <link rel="stylesheet" type="text/css" href="../www/shared/bootstrap/css/bootstrap-responsive.min.css"/>
+
+  <script src="../www/shared/datepicker/js/bootstrap-datepicker.min.js"></script>
+  <link rel="stylesheet" type="text/css" href="../www/shared/datepicker/css/datepicker.css"/>
+
+  <script src="../www/shared/bootstrap-daterangepicker/date.js"></script>
+  <script src="../www/shared/bootstrap-daterangepicker/daterangepicker.js"></script>
+  <link rel="stylesheet" type="text/css" href="../www/shared/bootstrap-daterangepicker/daterangepicker.css"/>
+
+  <!-- include spec files here... -->
+ <!-- <script type="text/javascript" src="spec/SpecHelper.js"></script>
+  <script type="text/javascript" src="spec/PlayerSpec.js"></script>
+ -->
+  <script type="text/javascript" src="spec/inputBindingSpec.js"></script>
+
+  <script type="text/javascript">
+    (function() {
+      var jasmineEnv = jasmine.getEnv();
+      jasmineEnv.updateInterval = 1000;
+
+      var htmlReporter = new jasmine.HtmlReporter();
+
+      jasmineEnv.addReporter(htmlReporter);
+
+      jasmineEnv.specFilter = function(spec) {
+        return htmlReporter.specFilter(spec);
+      };
+
+      // var currentWindowOnload = window.onload;
+
+      // window.onload = function() {
+      //   if (currentWindowOnload) {
+      //     currentWindowOnload();
+      //   }
+      //   execJasmine();
+      // };
+
+      // Add a slight delay before running tests, so that Shiny has time to
+      // do setup stuff.
+      $(document).ready(function() {
+        setTimeout(function() {
+            execJasmine();
+          },
+          50
+        )
+      });
+
+
+      function execJasmine() {
+        jasmineEnv.execute();
+      }
+
+    })();
+
+
+    // Clear the Shiny disconnected gray screen shortly after loading
+    $(document).ready(function() {
+      setTimeout(function() {
+          $('body').removeClass('disconnected');
+        },
+        100
+      )
+    });
+
+  </script>
+
+</head>
+
+<body>
+
+</body>
+</html>

inst/tests-js/fixtures/textInputBinding.html

@@ -0,0 +1,2 @@
+<label>Text input:</label>
+<input id="in_text" type="text" value="starting value"/>

inst/tests-js/lib/jasmine-1.3.1/MIT.LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2008-2011 Pivotal Labs
+
+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/tests-js/lib/jasmine-1.3.1/jasmine-html.js

@@ -0,0 +1,681 @@
+jasmine.HtmlReporterHelpers = {};
+
+jasmine.HtmlReporterHelpers.createDom = function(type, attrs, childrenVarArgs) {
+  var el = document.createElement(type);
+
+  for (var i = 2; i < arguments.length; i++) {
+    var child = arguments[i];
+
+    if (typeof child === 'string') {
+      el.appendChild(document.createTextNode(child));
+    } else {
+      if (child) {
+        el.appendChild(child);
+      }
+    }
+  }
+
+  for (var attr in attrs) {
+    if (attr == "className") {
+      el[attr] = attrs[attr];
+    } else {
+      el.setAttribute(attr, attrs[attr]);
+    }
+  }
+
+  return el;
+};
+
+jasmine.HtmlReporterHelpers.getSpecStatus = function(child) {
+  var results = child.results();
+  var status = results.passed() ? 'passed' : 'failed';
+  if (results.skipped) {
+    status = 'skipped';
+  }
+
+  return status;
+};
+
+jasmine.HtmlReporterHelpers.appendToSummary = function(child, childElement) {
+  var parentDiv = this.dom.summary;
+  var parentSuite = (typeof child.parentSuite == 'undefined') ? 'suite' : 'parentSuite';
+  var parent = child[parentSuite];
+
+  if (parent) {
+    if (typeof this.views.suites[parent.id] == 'undefined') {
+      this.views.suites[parent.id] = new jasmine.HtmlReporter.SuiteView(parent, this.dom, this.views);
+    }
+    parentDiv = this.views.suites[parent.id].element;
+  }
+
+  parentDiv.appendChild(childElement);
+};
+
+
+jasmine.HtmlReporterHelpers.addHelpers = function(ctor) {
+  for(var fn in jasmine.HtmlReporterHelpers) {
+    ctor.prototype[fn] = jasmine.HtmlReporterHelpers[fn];
+  }
+};
+
+jasmine.HtmlReporter = function(_doc) {
+  var self = this;
+  var doc = _doc || window.document;
+
+  var reporterView;
+
+  var dom = {};
+
+  // Jasmine Reporter Public Interface
+  self.logRunningSpecs = false;
+
+  self.reportRunnerStarting = function(runner) {
+    var specs = runner.specs() || [];
+
+    if (specs.length == 0) {
+      return;
+    }
+
+    createReporterDom(runner.env.versionString());
+    doc.body.appendChild(dom.reporter);
+    setExceptionHandling();
+
+    reporterView = new jasmine.HtmlReporter.ReporterView(dom);
+    reporterView.addSpecs(specs, self.specFilter);
+  };
+
+  self.reportRunnerResults = function(runner) {
+    reporterView && reporterView.complete();
+  };
+
+  self.reportSuiteResults = function(suite) {
+    reporterView.suiteComplete(suite);
+  };
+
+  self.reportSpecStarting = function(spec) {
+    if (self.logRunningSpecs) {
+      self.log('>> Jasmine Running ' + spec.suite.description + ' ' + spec.description + '...');
+    }
+  };
+
+  self.reportSpecResults = function(spec) {
+    reporterView.specComplete(spec);
+  };
+
+  self.log = function() {
+    var console = jasmine.getGlobal().console;
+    if (console && console.log) {
+      if (console.log.apply) {
+        console.log.apply(console, arguments);
+      } else {
+        console.log(arguments); // ie fix: console.log.apply doesn't exist on ie
+      }
+    }
+  };
+
+  self.specFilter = function(spec) {
+    if (!focusedSpecName()) {
+      return true;
+    }
+
+    return spec.getFullName().indexOf(focusedSpecName()) === 0;
+  };
+
+  return self;
+
+  function focusedSpecName() {
+    var specName;
+
+    (function memoizeFocusedSpec() {
+      if (specName) {
+        return;
+      }
+
+      var paramMap = [];
+      var params = jasmine.HtmlReporter.parameters(doc);
+
+      for (var i = 0; i < params.length; i++) {
+        var p = params[i].split('=');
+        paramMap[decodeURIComponent(p[0])] = decodeURIComponent(p[1]);
+      }
+
+      specName = paramMap.spec;
+    })();
+
+    return specName;
+  }
+
+  function createReporterDom(version) {
+    dom.reporter = self.createDom('div', { id: 'HTMLReporter', className: 'jasmine_reporter' },
+      dom.banner = self.createDom('div', { className: 'banner' },
+        self.createDom('span', { className: 'title' }, "Jasmine "),
+        self.createDom('span', { className: 'version' }, version)),
+
+      dom.symbolSummary = self.createDom('ul', {className: 'symbolSummary'}),
+      dom.alert = self.createDom('div', {className: 'alert'},
+        self.createDom('span', { className: 'exceptions' },
+          self.createDom('label', { className: 'label', 'for': 'no_try_catch' }, 'No try/catch'),
+          self.createDom('input', { id: 'no_try_catch', type: 'checkbox' }))),
+      dom.results = self.createDom('div', {className: 'results'},
+        dom.summary = self.createDom('div', { className: 'summary' }),
+        dom.details = self.createDom('div', { id: 'details' }))
+    );
+  }
+
+  function noTryCatch() {
+    return window.location.search.match(/catch=false/);
+  }
+
+  function searchWithCatch() {
+    var params = jasmine.HtmlReporter.parameters(window.document);
+    var removed = false;
+    var i = 0;
+
+    while (!removed && i < params.length) {
+      if (params[i].match(/catch=/)) {
+        params.splice(i, 1);
+        removed = true;
+      }
+      i++;
+    }
+    if (jasmine.CATCH_EXCEPTIONS) {
+      params.push("catch=false");
+    }
+
+    return params.join("&");
+  }
+
+  function setExceptionHandling() {
+    var chxCatch = document.getElementById('no_try_catch');
+
+    if (noTryCatch()) {
+      chxCatch.setAttribute('checked', true);
+      jasmine.CATCH_EXCEPTIONS = false;
+    }
+    chxCatch.onclick = function() {
+      window.location.search = searchWithCatch();
+    };
+  }
+};
+jasmine.HtmlReporter.parameters = function(doc) {
+  var paramStr = doc.location.search.substring(1);
+  var params = [];
+
+  if (paramStr.length > 0) {
+    params = paramStr.split('&');
+  }
+  return params;
+}
+jasmine.HtmlReporter.sectionLink = function(sectionName) {
+  var link = '?';
+  var params = [];
+
+  if (sectionName) {
+    params.push('spec=' + encodeURIComponent(sectionName));
+  }
+  if (!jasmine.CATCH_EXCEPTIONS) {
+    params.push("catch=false");
+  }
+  if (params.length > 0) {
+    link += params.join("&");
+  }
+
+  return link;
+};
+jasmine.HtmlReporterHelpers.addHelpers(jasmine.HtmlReporter);
+jasmine.HtmlReporter.ReporterView = function(dom) {
+  this.startedAt = new Date();
+  this.runningSpecCount = 0;
+  this.completeSpecCount = 0;
+  this.passedCount = 0;
+  this.failedCount = 0;
+  this.skippedCount = 0;
+
+  this.createResultsMenu = function() {
+    this.resultsMenu = this.createDom('span', {className: 'resultsMenu bar'},
+      this.summaryMenuItem = this.createDom('a', {className: 'summaryMenuItem', href: "#"}, '0 specs'),
+      ' | ',
+      this.detailsMenuItem = this.createDom('a', {className: 'detailsMenuItem', href: "#"}, '0 failing'));
+
+    this.summaryMenuItem.onclick = function() {
+      dom.reporter.className = dom.reporter.className.replace(/ showDetails/g, '');
+    };
+
+    this.detailsMenuItem.onclick = function() {
+      showDetails();
+    };
+  };
+
+  this.addSpecs = function(specs, specFilter) {
+    this.totalSpecCount = specs.length;
+
+    this.views = {
+      specs: {},
+      suites: {}
+    };
+
+    for (var i = 0; i < specs.length; i++) {
+      var spec = specs[i];
+      this.views.specs[spec.id] = new jasmine.HtmlReporter.SpecView(spec, dom, this.views);
+      if (specFilter(spec)) {
+        this.runningSpecCount++;
+      }
+    }
+  };
+
+  this.specComplete = function(spec) {
+    this.completeSpecCount++;
+
+    if (isUndefined(this.views.specs[spec.id])) {
+      this.views.specs[spec.id] = new jasmine.HtmlReporter.SpecView(spec, dom);
+    }
+
+    var specView = this.views.specs[spec.id];
+
+    switch (specView.status()) {
+      case 'passed':
+        this.passedCount++;
+        break;
+
+      case 'failed':
+        this.failedCount++;
+        break;
+
+      case 'skipped':
+        this.skippedCount++;
+        break;
+    }
+
+    specView.refresh();
+    this.refresh();
+  };
+
+  this.suiteComplete = function(suite) {
+    var suiteView = this.views.suites[suite.id];
+    if (isUndefined(suiteView)) {
+      return;
+    }
+    suiteView.refresh();
+  };
+
+  this.refresh = function() {
+
+    if (isUndefined(this.resultsMenu)) {
+      this.createResultsMenu();
+    }
+
+    // currently running UI
+    if (isUndefined(this.runningAlert)) {
+      this.runningAlert = this.createDom('a', { href: jasmine.HtmlReporter.sectionLink(), className: "runningAlert bar" });
+      dom.alert.appendChild(this.runningAlert);
+    }
+    this.runningAlert.innerHTML = "Running " + this.completeSpecCount + " of " + specPluralizedFor(this.totalSpecCount);
+
+    // skipped specs UI
+    if (isUndefined(this.skippedAlert)) {
+      this.skippedAlert = this.createDom('a', { href: jasmine.HtmlReporter.sectionLink(), className: "skippedAlert bar" });
+    }
+
+    this.skippedAlert.innerHTML = "Skipping " + this.skippedCount + " of " + specPluralizedFor(this.totalSpecCount) + " - run all";
+
+    if (this.skippedCount === 1 && isDefined(dom.alert)) {
+      dom.alert.appendChild(this.skippedAlert);
+    }
+
+    // passing specs UI
+    if (isUndefined(this.passedAlert)) {
+      this.passedAlert = this.createDom('span', { href: jasmine.HtmlReporter.sectionLink(), className: "passingAlert bar" });
+    }
+    this.passedAlert.innerHTML = "Passing " + specPluralizedFor(this.passedCount);
+
+    // failing specs UI
+    if (isUndefined(this.failedAlert)) {
+      this.failedAlert = this.createDom('span', {href: "?", className: "failingAlert bar"});
+    }
+    this.failedAlert.innerHTML = "Failing " + specPluralizedFor(this.failedCount);
+
+    if (this.failedCount === 1 && isDefined(dom.alert)) {
+      dom.alert.appendChild(this.failedAlert);
+      dom.alert.appendChild(this.resultsMenu);
+    }
+
+    // summary info
+    this.summaryMenuItem.innerHTML = "" + specPluralizedFor(this.runningSpecCount);
+    this.detailsMenuItem.innerHTML = "" + this.failedCount + " failing";
+  };
+
+  this.complete = function() {
+    dom.alert.removeChild(this.runningAlert);
+
+    this.skippedAlert.innerHTML = "Ran " + this.runningSpecCount + " of " + specPluralizedFor(this.totalSpecCount) + " - run all";
+
+    if (this.failedCount === 0) {
+      dom.alert.appendChild(this.createDom('span', {className: 'passingAlert bar'}, "Passing " + specPluralizedFor(this.passedCount)));
+    } else {
+      showDetails();
+    }
+
+    dom.banner.appendChild(this.createDom('span', {className: 'duration'}, "finished in " + ((new Date().getTime() - this.startedAt.getTime()) / 1000) + "s"));
+  };
+
+  return this;
+
+  function showDetails() {
+    if (dom.reporter.className.search(/showDetails/) === -1) {
+      dom.reporter.className += " showDetails";
+    }
+  }
+
+  function isUndefined(obj) {
+    return typeof obj === 'undefined';
+  }
+
+  function isDefined(obj) {
+    return !isUndefined(obj);
+  }
+
+  function specPluralizedFor(count) {
+    var str = count + " spec";
+    if (count > 1) {
+      str += "s"
+    }
+    return str;
+  }
+
+};
+
+jasmine.HtmlReporterHelpers.addHelpers(jasmine.HtmlReporter.ReporterView);
+
+
+jasmine.HtmlReporter.SpecView = function(spec, dom, views) {
+  this.spec = spec;
+  this.dom = dom;
+  this.views = views;
+
+  this.symbol = this.createDom('li', { className: 'pending' });
+  this.dom.symbolSummary.appendChild(this.symbol);
+
+  this.summary = this.createDom('div', { className: 'specSummary' },
+    this.createDom('a', {
+      className: 'description',
+      href: jasmine.HtmlReporter.sectionLink(this.spec.getFullName()),
+      title: this.spec.getFullName()
+    }, this.spec.description)
+  );
+
+  this.detail = this.createDom('div', { className: 'specDetail' },
+      this.createDom('a', {
+        className: 'description',
+        href: '?spec=' + encodeURIComponent(this.spec.getFullName()),
+        title: this.spec.getFullName()
+      }, this.spec.getFullName())
+  );
+};
+
+jasmine.HtmlReporter.SpecView.prototype.status = function() {
+  return this.getSpecStatus(this.spec);
+};
+
+jasmine.HtmlReporter.SpecView.prototype.refresh = function() {
+  this.symbol.className = this.status();
+
+  switch (this.status()) {
+    case 'skipped':
+      break;
+
+    case 'passed':
+      this.appendSummaryToSuiteDiv();
+      break;
+
+    case 'failed':
+      this.appendSummaryToSuiteDiv();
+      this.appendFailureDetail();
+      break;
+  }
+};
+
+jasmine.HtmlReporter.SpecView.prototype.appendSummaryToSuiteDiv = function() {
+  this.summary.className += ' ' + this.status();
+  this.appendToSummary(this.spec, this.summary);
+};
+
+jasmine.HtmlReporter.SpecView.prototype.appendFailureDetail = function() {
+  this.detail.className += ' ' + this.status();
+
+  var resultItems = this.spec.results().getItems();
+  var messagesDiv = this.createDom('div', { className: 'messages' });
+
+  for (var i = 0; i < resultItems.length; i++) {
+    var result = resultItems[i];
+
+    if (result.type == 'log') {
+      messagesDiv.appendChild(this.createDom('div', {className: 'resultMessage log'}, result.toString()));
+    } else if (result.type == 'expect' && result.passed && !result.passed()) {
+      messagesDiv.appendChild(this.createDom('div', {className: 'resultMessage fail'}, result.message));
+
+      if (result.trace.stack) {
+        messagesDiv.appendChild(this.createDom('div', {className: 'stackTrace'}, result.trace.stack));
+      }
+    }
+  }
+
+  if (messagesDiv.childNodes.length > 0) {
+    this.detail.appendChild(messagesDiv);
+    this.dom.details.appendChild(this.detail);
+  }
+};
+
+jasmine.HtmlReporterHelpers.addHelpers(jasmine.HtmlReporter.SpecView);jasmine.HtmlReporter.SuiteView = function(suite, dom, views) {
+  this.suite = suite;
+  this.dom = dom;
+  this.views = views;
+
+  this.element = this.createDom('div', { className: 'suite' },
+    this.createDom('a', { className: 'description', href: jasmine.HtmlReporter.sectionLink(this.suite.getFullName()) }, this.suite.description)
+  );
+
+  this.appendToSummary(this.suite, this.element);
+};
+
+jasmine.HtmlReporter.SuiteView.prototype.status = function() {
+  return this.getSpecStatus(this.suite);
+};
+
+jasmine.HtmlReporter.SuiteView.prototype.refresh = function() {
+  this.element.className += " " + this.status();
+};
+
+jasmine.HtmlReporterHelpers.addHelpers(jasmine.HtmlReporter.SuiteView);
+
+/* @deprecated Use jasmine.HtmlReporter instead
+ */
+jasmine.TrivialReporter = function(doc) {
+  this.document = doc || document;
+  this.suiteDivs = {};
+  this.logRunningSpecs = false;
+};
+
+jasmine.TrivialReporter.prototype.createDom = function(type, attrs, childrenVarArgs) {
+  var el = document.createElement(type);
+
+  for (var i = 2; i < arguments.length; i++) {
+    var child = arguments[i];
+
+    if (typeof child === 'string') {
+      el.appendChild(document.createTextNode(child));
+    } else {
+      if (child) { el.appendChild(child); }
+    }
+  }
+
+  for (var attr in attrs) {
+    if (attr == "className") {
+      el[attr] = attrs[attr];
+    } else {
+      el.setAttribute(attr, attrs[attr]);
+    }
+  }
+
+  return el;
+};
+
+jasmine.TrivialReporter.prototype.reportRunnerStarting = function(runner) {
+  var showPassed, showSkipped;
+
+  this.outerDiv = this.createDom('div', { id: 'TrivialReporter', className: 'jasmine_reporter' },
+      this.createDom('div', { className: 'banner' },
+        this.createDom('div', { className: 'logo' },
+            this.createDom('span', { className: 'title' }, "Jasmine"),
+            this.createDom('span', { className: 'version' }, runner.env.versionString())),
+        this.createDom('div', { className: 'options' },
+            "Show ",
+            showPassed = this.createDom('input', { id: "__jasmine_TrivialReporter_showPassed__", type: 'checkbox' }),
+            this.createDom('label', { "for": "__jasmine_TrivialReporter_showPassed__" }, " passed "),
+            showSkipped = this.createDom('input', { id: "__jasmine_TrivialReporter_showSkipped__", type: 'checkbox' }),
+            this.createDom('label', { "for": "__jasmine_TrivialReporter_showSkipped__" }, " skipped")
+            )
+          ),
+
+      this.runnerDiv = this.createDom('div', { className: 'runner running' },
+          this.createDom('a', { className: 'run_spec', href: '?' }, "run all"),
+          this.runnerMessageSpan = this.createDom('span', {}, "Running..."),
+          this.finishedAtSpan = this.createDom('span', { className: 'finished-at' }, ""))
+      );
+
+  this.document.body.appendChild(this.outerDiv);
+
+  var suites = runner.suites();
+  for (var i = 0; i < suites.length; i++) {
+    var suite = suites[i];
+    var suiteDiv = this.createDom('div', { className: 'suite' },
+        this.createDom('a', { className: 'run_spec', href: '?spec=' + encodeURIComponent(suite.getFullName()) }, "run"),
+        this.createDom('a', { className: 'description', href: '?spec=' + encodeURIComponent(suite.getFullName()) }, suite.description));
+    this.suiteDivs[suite.id] = suiteDiv;
+    var parentDiv = this.outerDiv;
+    if (suite.parentSuite) {
+      parentDiv = this.suiteDivs[suite.parentSuite.id];
+    }
+    parentDiv.appendChild(suiteDiv);
+  }
+
+  this.startedAt = new Date();
+
+  var self = this;
+  showPassed.onclick = function(evt) {
+    if (showPassed.checked) {
+      self.outerDiv.className += ' show-passed';
+    } else {
+      self.outerDiv.className = self.outerDiv.className.replace(/ show-passed/, '');
+    }
+  };
+
+  showSkipped.onclick = function(evt) {
+    if (showSkipped.checked) {
+      self.outerDiv.className += ' show-skipped';
+    } else {
+      self.outerDiv.className = self.outerDiv.className.replace(/ show-skipped/, '');
+    }
+  };
+};
+
+jasmine.TrivialReporter.prototype.reportRunnerResults = function(runner) {
+  var results = runner.results();
+  var className = (results.failedCount > 0) ? "runner failed" : "runner passed";
+  this.runnerDiv.setAttribute("class", className);
+  //do it twice for IE
+  this.runnerDiv.setAttribute("className", className);
+  var specs = runner.specs();
+  var specCount = 0;
+  for (var i = 0; i < specs.length; i++) {
+    if (this.specFilter(specs[i])) {
+      specCount++;
+    }
+  }
+  var message = "" + specCount + " spec" + (specCount == 1 ? "" : "s" ) + ", " + results.failedCount + " failure" + ((results.failedCount == 1) ? "" : "s");
+  message += " in " + ((new Date().getTime() - this.startedAt.getTime()) / 1000) + "s";
+  this.runnerMessageSpan.replaceChild(this.createDom('a', { className: 'description', href: '?'}, message), this.runnerMessageSpan.firstChild);
+
+  this.finishedAtSpan.appendChild(document.createTextNode("Finished at " + new Date().toString()));
+};
+
+jasmine.TrivialReporter.prototype.reportSuiteResults = function(suite) {
+  var results = suite.results();
+  var status = results.passed() ? 'passed' : 'failed';
+  if (results.totalCount === 0) { // todo: change this to check results.skipped
+    status = 'skipped';
+  }
+  this.suiteDivs[suite.id].className += " " + status;
+};
+
+jasmine.TrivialReporter.prototype.reportSpecStarting = function(spec) {
+  if (this.logRunningSpecs) {
+    this.log('>> Jasmine Running ' + spec.suite.description + ' ' + spec.description + '...');
+  }
+};
+
+jasmine.TrivialReporter.prototype.reportSpecResults = function(spec) {
+  var results = spec.results();
+  var status = results.passed() ? 'passed' : 'failed';
+  if (results.skipped) {
+    status = 'skipped';
+  }
+  var specDiv = this.createDom('div', { className: 'spec '  + status },
+      this.createDom('a', { className: 'run_spec', href: '?spec=' + encodeURIComponent(spec.getFullName()) }, "run"),
+      this.createDom('a', {
+        className: 'description',
+        href: '?spec=' + encodeURIComponent(spec.getFullName()),
+        title: spec.getFullName()
+      }, spec.description));
+
+
+  var resultItems = results.getItems();
+  var messagesDiv = this.createDom('div', { className: 'messages' });
+  for (var i = 0; i < resultItems.length; i++) {
+    var result = resultItems[i];
+
+    if (result.type == 'log') {
+      messagesDiv.appendChild(this.createDom('div', {className: 'resultMessage log'}, result.toString()));
+    } else if (result.type == 'expect' && result.passed && !result.passed()) {
+      messagesDiv.appendChild(this.createDom('div', {className: 'resultMessage fail'}, result.message));
+
+      if (result.trace.stack) {
+        messagesDiv.appendChild(this.createDom('div', {className: 'stackTrace'}, result.trace.stack));
+      }
+    }
+  }
+
+  if (messagesDiv.childNodes.length > 0) {
+    specDiv.appendChild(messagesDiv);
+  }
+
+  this.suiteDivs[spec.suite.id].appendChild(specDiv);
+};
+
+jasmine.TrivialReporter.prototype.log = function() {
+  var console = jasmine.getGlobal().console;
+  if (console && console.log) {
+    if (console.log.apply) {
+      console.log.apply(console, arguments);
+    } else {
+      console.log(arguments); // ie fix: console.log.apply doesn't exist on ie
+    }
+  }
+};
+
+jasmine.TrivialReporter.prototype.getLocation = function() {
+  return this.document.location;
+};
+
+jasmine.TrivialReporter.prototype.specFilter = function(spec) {
+  var paramMap = {};
+  var params = this.getLocation().search.substring(1).split('&');
+  for (var i = 0; i < params.length; i++) {
+    var p = params[i].split('=');
+    paramMap[decodeURIComponent(p[0])] = decodeURIComponent(p[1]);
+  }
+
+  if (!paramMap.spec) {
+    return true;
+  }
+  return spec.getFullName().indexOf(paramMap.spec) === 0;
+};

inst/tests-js/lib/jasmine-1.3.1/jasmine.css

@@ -0,0 +1,82 @@
+body { background-color: #eeeeee; padding: 0; margin: 5px; overflow-y: scroll; }
+
+#HTMLReporter { font-size: 11px; font-family: Monaco, "Lucida Console", monospace; line-height: 14px; color: #333333; }
+#HTMLReporter a { text-decoration: none; }
+#HTMLReporter a:hover { text-decoration: underline; }
+#HTMLReporter p, #HTMLReporter h1, #HTMLReporter h2, #HTMLReporter h3, #HTMLReporter h4, #HTMLReporter h5, #HTMLReporter h6 { margin: 0; line-height: 14px; }
+#HTMLReporter .banner, #HTMLReporter .symbolSummary, #HTMLReporter .summary, #HTMLReporter .resultMessage, #HTMLReporter .specDetail .description, #HTMLReporter .alert .bar, #HTMLReporter .stackTrace { padding-left: 9px; padding-right: 9px; }
+#HTMLReporter #jasmine_content { position: fixed; right: 100%; }
+#HTMLReporter .version { color: #aaaaaa; }
+#HTMLReporter .banner { margin-top: 14px; }
+#HTMLReporter .duration { color: #aaaaaa; float: right; }
+#HTMLReporter .symbolSummary { overflow: hidden; *zoom: 1; margin: 14px 0; }
+#HTMLReporter .symbolSummary li { display: block; float: left; height: 7px; width: 14px; margin-bottom: 7px; font-size: 16px; }
+#HTMLReporter .symbolSummary li.passed { font-size: 14px; }
+#HTMLReporter .symbolSummary li.passed:before { color: #5e7d00; content: "\02022"; }
+#HTMLReporter .symbolSummary li.failed { line-height: 9px; }
+#HTMLReporter .symbolSummary li.failed:before { color: #b03911; content: "x"; font-weight: bold; margin-left: -1px; }
+#HTMLReporter .symbolSummary li.skipped { font-size: 14px; }
+#HTMLReporter .symbolSummary li.skipped:before { color: #bababa; content: "\02022"; }
+#HTMLReporter .symbolSummary li.pending { line-height: 11px; }
+#HTMLReporter .symbolSummary li.pending:before { color: #aaaaaa; content: "-"; }
+#HTMLReporter .exceptions { color: #fff; float: right; margin-top: 5px; margin-right: 5px; }
+#HTMLReporter .bar { line-height: 28px; font-size: 14px; display: block; color: #eee; }
+#HTMLReporter .runningAlert { background-color: #666666; }
+#HTMLReporter .skippedAlert { background-color: #aaaaaa; }
+#HTMLReporter .skippedAlert:first-child { background-color: #333333; }
+#HTMLReporter .skippedAlert:hover { text-decoration: none; color: white; text-decoration: underline; }
+#HTMLReporter .passingAlert { background-color: #a6b779; }
+#HTMLReporter .passingAlert:first-child { background-color: #5e7d00; }
+#HTMLReporter .failingAlert { background-color: #cf867e; }
+#HTMLReporter .failingAlert:first-child { background-color: #b03911; }
+#HTMLReporter .results { margin-top: 14px; }
+#HTMLReporter #details { display: none; }
+#HTMLReporter .resultsMenu, #HTMLReporter .resultsMenu a { background-color: #fff; color: #333333; }
+#HTMLReporter.showDetails .summaryMenuItem { font-weight: normal; text-decoration: inherit; }
+#HTMLReporter.showDetails .summaryMenuItem:hover { text-decoration: underline; }
+#HTMLReporter.showDetails .detailsMenuItem { font-weight: bold; text-decoration: underline; }
+#HTMLReporter.showDetails .summary { display: none; }
+#HTMLReporter.showDetails #details { display: block; }
+#HTMLReporter .summaryMenuItem { font-weight: bold; text-decoration: underline; }
+#HTMLReporter .summary { margin-top: 14px; }
+#HTMLReporter .summary .suite .suite, #HTMLReporter .summary .specSummary { margin-left: 14px; }
+#HTMLReporter .summary .specSummary.passed a { color: #5e7d00; }
+#HTMLReporter .summary .specSummary.failed a { color: #b03911; }
+#HTMLReporter .description + .suite { margin-top: 0; }
+#HTMLReporter .suite { margin-top: 14px; }
+#HTMLReporter .suite a { color: #333333; }
+#HTMLReporter #details .specDetail { margin-bottom: 28px; }
+#HTMLReporter #details .specDetail .description { display: block; color: white; background-color: #b03911; }
+#HTMLReporter .resultMessage { padding-top: 14px; color: #333333; }
+#HTMLReporter .resultMessage span.result { display: block; }
+#HTMLReporter .stackTrace { margin: 5px 0 0 0; max-height: 224px; overflow: auto; line-height: 18px; color: #666666; border: 1px solid #ddd; background: white; white-space: pre; }
+
+#TrivialReporter { padding: 8px 13px; position: absolute; top: 0; bottom: 0; left: 0; right: 0; overflow-y: scroll; background-color: white; font-family: "Helvetica Neue Light", "Lucida Grande", "Calibri", "Arial", sans-serif; /*.resultMessage {*/ /*white-space: pre;*/ /*}*/ }
+#TrivialReporter a:visited, #TrivialReporter a { color: #303; }
+#TrivialReporter a:hover, #TrivialReporter a:active { color: blue; }
+#TrivialReporter .run_spec { float: right; padding-right: 5px; font-size: .8em; text-decoration: none; }
+#TrivialReporter .banner { color: #303; background-color: #fef; padding: 5px; }
+#TrivialReporter .logo { float: left; font-size: 1.1em; padding-left: 5px; }
+#TrivialReporter .logo .version { font-size: .6em; padding-left: 1em; }
+#TrivialReporter .runner.running { background-color: yellow; }
+#TrivialReporter .options { text-align: right; font-size: .8em; }
+#TrivialReporter .suite { border: 1px outset gray; margin: 5px 0; padding-left: 1em; }
+#TrivialReporter .suite .suite { margin: 5px; }
+#TrivialReporter .suite.passed { background-color: #dfd; }
+#TrivialReporter .suite.failed { background-color: #fdd; }
+#TrivialReporter .spec { margin: 5px; padding-left: 1em; clear: both; }
+#TrivialReporter .spec.failed, #TrivialReporter .spec.passed, #TrivialReporter .spec.skipped { padding-bottom: 5px; border: 1px solid gray; }
+#TrivialReporter .spec.failed { background-color: #fbb; border-color: red; }
+#TrivialReporter .spec.passed { background-color: #bfb; border-color: green; }
+#TrivialReporter .spec.skipped { background-color: #bbb; }
+#TrivialReporter .messages { border-left: 1px dashed gray; padding-left: 1em; padding-right: 1em; }
+#TrivialReporter .passed { background-color: #cfc; display: none; }
+#TrivialReporter .failed { background-color: #fbb; }
+#TrivialReporter .skipped { color: #777; background-color: #eee; display: none; }
+#TrivialReporter .resultMessage span.result { display: block; line-height: 2em; color: black; }
+#TrivialReporter .resultMessage .mismatch { color: black; }
+#TrivialReporter .stackTrace { white-space: pre; font-size: .8em; margin-left: 10px; max-height: 5em; overflow: auto; border: 1px inset red; padding: 1em; background: #eef; }
+#TrivialReporter .finished-at { padding-left: 1em; font-size: .6em; }
+#TrivialReporter.show-passed .passed, #TrivialReporter.show-skipped .skipped { display: block; }
+#TrivialReporter #jasmine_content { position: fixed; right: 100%; }
+#TrivialReporter .runner { border: 1px solid gray; display: block; margin: 5px 0; padding: 2px 0 2px 10px; }

inst/tests/test-bootstrap.r

@@ -0,0 +1,60 @@
+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")
+})
+
+
+test_that("Repeated names for selectInput and radioButtons choices", {
+  # These test might be a bit too closely tied to the exact structure of the
+  # tag object, but they get the job done for now.
+
+  # Select input
+  x <- selectInput('id','label', choices = c(a='x1', a='x2', b='x3'))
+  choices <- x[[2]]$children
+
+  expect_equal(choices[[1]]$children[[1]], 'a')
+  expect_equal(choices[[1]]$attribs$value, 'x1')
+  expect_equal(choices[[1]]$attribs$selected, 'selected')
+
+  expect_equal(choices[[2]]$children[[1]], 'a')
+  expect_equal(choices[[2]]$attribs$value, 'x2')
+  # This one actually should be NULL, but with the syntax of selectInput, it
+  # must be 'selected'.
+  expect_equal(choices[[2]]$attribs$selected, 'selected')
+
+  expect_equal(choices[[3]]$children[[1]], 'b')
+  expect_equal(choices[[3]]$attribs$value, 'x3')
+  expect_equal(choices[[3]]$attribs$selected, NULL)
+
+
+  # Radio buttons
+  x <- radioButtons('id','label', choices = c(a='x1', a='x2', b='x3'))
+  choices <- x$children
+
+  expect_equal(choices[[2]]$children[[2]]$children[[1]], 'a')
+  expect_equal(choices[[2]]$children[[1]]$attribs$value, 'x1')
+  expect_equal(choices[[2]]$children[[1]]$attribs$checked, 'checked')
+
+  expect_equal(choices[[3]]$children[[2]]$children[[1]], 'a')
+  expect_equal(choices[[3]]$children[[1]]$attribs$value, 'x2')
+  # This one actually should be NULL, but with the syntax of radioButtons, it
+  # must be 'checked'.
+  expect_equal(choices[[3]]$children[[1]]$attribs$checked, 'checked')
+
+  expect_equal(choices[[4]]$children[[2]]$children[[1]], 'b')
+  expect_equal(choices[[4]]$children[[1]]$attribs$value, 'x3')
+  expect_equal(choices[[4]]$children[[1]]$attribs$checked, NULL)
+})

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,665 @@
+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)
+})
+
+test_that("Observer priorities are respected", {
+  results <- c()
+  observe(results <<- c(results, 10), priority=10)
+  observe(results <<- c(results, 30), priority=30)
+  observe(results <<- c(results, 20), priority=20L)
+  observe(results <<- c(results, 21), priority=20)
+  observe(results <<- c(results, 22), priority=20L)
+  
+  flushReact()
+  
+  expect_identical(results, c(30, 20, 21, 22, 10))
+})

inst/tests/test-tags.r

@@ -0,0 +1,300 @@
+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"))
+})
+
+
+test_that("withTags works", {
+  output_tags <- tags$div(class = "myclass",
+    tags$h3("header"),
+    tags$p("text here")
+  )
+  output_withhtml <- withTags(
+    div(class = "myclass",
+      h3("header"),
+      p("text here")
+    )
+  )
+  expect_identical(output_tags, output_withhtml)
+
+
+  # Check that current environment is searched
+  x <- 100
+  expect_identical(tags$p(x), withTags(p(x)))
+
+  # Just to make sure, run it in a function, which has its own environment
+  foo <- function() {
+    y <- 100
+    withTags(p(y))
+  }
+  expect_identical(tags$p(100), foo())
+})
+
+
+test_that("HTML escaping in tags", {
+  # Regular text is escaped
+  expect_equivalent(format(div("<a&b>")), "<div>&lt;a&amp;b&gt;</div>")
+
+  # Text in HTML() isn't escaped
+  expect_equivalent(format(div(HTML("<a&b>"))), "<div><a&b></div>")
+
+  # Text in a property is escaped
+  expect_equivalent(format(div(class = "<a&b>", "text")),
+                    '<div class="&lt;a&amp;b&gt;">text</div>')
+
+  # HTML() has no effect in a property like 'class'
+  expect_equivalent(format(div(class = HTML("<a&b>"), "text")),
+                    '<div class="&lt;a&amp;b&gt;">text</div>')
+})
+
+
+test_that("Adding child tags", {
+  tag_list <- list(tags$p("tag1"), tags$b("tag2"), tags$i("tag3"))
+
+  # Creating nested tags by calling the tag$div function and passing a list
+  t1 <- tags$div(class="foo", tag_list)
+  expect_equal(length(t1$children), 3)
+  expect_equal(t1$children[[1]]$name, "p")
+  expect_equal(t1$children[[1]]$children[[1]], "tag1")
+  expect_equal(t1$children[[2]]$name, "b")
+  expect_equal(t1$children[[2]]$children[[1]], "tag2")
+  expect_equal(t1$children[[3]]$name, "i")
+  expect_equal(t1$children[[3]]$children[[1]], "tag3")
+
+
+  # div tag used as starting point for tests below
+  div_tag <- tags$div(class="foo")
+
+  # Appending each child
+  t2 <- tagAppendChild(div_tag, tag_list[[1]])
+  t2 <- tagAppendChild(t2, tag_list[[2]])
+  t2 <- tagAppendChild(t2, tag_list[[3]])
+  expect_identical(t1, t2)
+
+
+  # tagSetChildren, using list argument
+  t2 <- tagSetChildren(div_tag, list = tag_list)
+  expect_identical(t1, t2)
+
+  # tagSetChildren, using ... arguments
+  t2 <- tagSetChildren(div_tag, tag_list[[1]], tag_list[[2]], tag_list[[3]])
+  expect_identical(t1, t2)
+
+  # tagSetChildren, using ... and list arguments
+  t2 <- tagSetChildren(div_tag, tag_list[[1]], list = tag_list[2:3])
+  expect_identical(t1, t2)
+
+  # tagSetChildren overwrites existing children
+  t2 <- tagAppendChild(div_tag, p("should replace this tag"))
+  t2 <- tagSetChildren(div_tag, list = tag_list)
+  expect_identical(t1, t2)
+
+
+  # tagAppendChildren, using list argument
+  t2 <- tagAppendChild(div_tag, tag_list[[1]])
+  t2 <- tagAppendChildren(t2, list = tag_list[2:3])
+  expect_identical(t1, t2)
+
+  # tagAppendChildren, using ... arguments
+  t2 <- tagAppendChild(div_tag, tag_list[[1]])
+  t2 <- tagAppendChildren(t2, tag_list[[2]], tag_list[[3]])
+  expect_identical(t1, t2)
+
+  # tagAppendChildren, using ... and list arguments
+  t2 <- tagAppendChild(div_tag, tag_list[[1]])
+  t2 <- tagAppendChildren(t2, tag_list[[2]], list = list(tag_list[[3]]))
+  expect_identical(t1, t2)
+
+  # tagAppendChildren can start with no children
+  t2 <- tagAppendChildren(div_tag, list = tag_list)
+  expect_identical(t1, t2)
+
+
+  # tagSetChildren preserves attributes
+  x <- tagSetChildren(div(), HTML("text"))
+  expect_identical(attr(x$children[[1]], "html"), TRUE)
+
+  # tagAppendChildren preserves attributes
+  x <- tagAppendChildren(div(), HTML("text"))
+  expect_identical(attr(x$children[[1]], "html"), TRUE)
+})
+
+
+test_that("Creating simple tags", {
+  # Empty tag
+  expect_identical(
+    div(),
+    structure(
+      list(name = "div", attribs = list(), children = list()),
+      .Names = c("name", "attribs", "children"),
+      class = "shiny.tag"
+    )
+  )
+
+  # Tag with text
+  expect_identical(
+    div("text"),
+    structure(
+      list(name = "div", attribs = list(), children = list("text")),
+      .Names = c("name", "attribs", "children"),
+      class = "shiny.tag"
+    )
+  )
+
+  # NULL attributes are dropped
+  expect_identical(
+    div(a = NULL, b = "value"),
+    div(b = "value")
+  )
+
+  # Numbers are coerced to strings
+  expect_identical(
+    div(1234),
+    structure(
+      list(name = "div", attribs = list(), children = list("1234")),
+      .Names = c("name", "attribs", "children"),
+      class = "shiny.tag"
+    )
+  )
+})
+
+
+test_that("Creating nested tags", {
+  # Simple version
+  # Note that the $children list should not have a names attribute
+  expect_identical(
+    div(class="foo", list("a", "b")),
+    structure(
+      list(name = "div",
+           attribs = structure(list(class = "foo"), .Names = "class"),
+           children = list("a", "b")),
+      .Names = c("name", "attribs", "children"),
+      class = "shiny.tag"
+    )
+  )
+
+  # More complex version
+  t1 <- withTags(
+    div(class = "foo",
+      p("child tag"),
+      list(
+        p("in-list child tag 1"),
+        "in-list character string",
+        p(),
+        p("in-list child tag 2")
+      ),
+      "character string",
+      1234
+    )
+  )
+
+  # t1 should be identical to this data structure.
+  # The nested list should be flattened, and non-tag, non-strings should be
+  # converted to strings
+  t1_full <- structure(
+    list(
+      name = "div",
+      attribs = list(class = "foo"),
+      children = list(
+        structure(list(name = "p",
+                       attribs = list(),
+                       children = list("child tag")),
+                  class = "shiny.tag"
+        ),
+        structure(list(name = "p",
+                       attribs = list(),
+                       children = list("in-list child tag 1")),
+                  class = "shiny.tag"
+        ),
+        "in-list character string",
+        structure(list(name = "p",
+                       attribs = list(),
+                       children = list()),
+                  class = "shiny.tag"
+        ),
+        structure(list(name = "p",
+                       attribs = list(),
+                       children = list("in-list child tag 2")),
+                  class = "shiny.tag"
+        ),
+        "character string",
+        "1234"
+      )
+    ),
+    class = "shiny.tag"
+  )
+
+  expect_identical(t1, t1_full)
+})
+
+test_that("Attributes are preserved", {
+  # HTML() adds an attribute to the data structure (note that this is
+  # different from the 'attribs' field in the list)
+  x <- HTML("<tag>&&</tag>")
+  expect_identical(attr(x, "html"), TRUE)
+  expect_equivalent(format(x), "<tag>&&</tag>")
+
+  # Make sure attributes are preserved when wrapped in other tags
+  x <- div(HTML("<tag>&&</tag>"))
+  expect_equivalent(x$children[[1]], "<tag>&&</tag>")
+  expect_identical(attr(x$children[[1]], "html"), TRUE)
+  expect_equivalent(format(x), "<div><tag>&&</tag></div>")
+
+  # Deeper nesting
+  x <- div(p(HTML("<tag>&&</tag>")))
+  expect_equivalent(x$children[[1]]$children[[1]], "<tag>&&</tag>")
+  expect_identical(attr(x$children[[1]]$children[[1]], "html"), TRUE)
+  expect_equivalent(format(x), "<div>\n  <p><tag>&&</tag></p>\n</div>")
+})
+
+
+test_that("Flattening a list of tags", {
+  # Flatten a nested list
+  nested <- list(
+    "a1",
+    list(
+      "b1",
+      list("c1", "c2"),
+      list(),
+      "b2",
+      list("d1", "d2")
+    ),
+    "a2"
+  )
+  flat <- list("a1", "b1", "c1", "c2", "b2", "d1", "d2", "a2")
+  expect_identical(flattenTags(nested), flat)
+
+  # no-op for flat lists
+  expect_identical(flattenTags(list(a="1", "b")), list(a="1", "b"))
+
+  # numbers are coerced to character
+  expect_identical(flattenTags(list(a=1, "b")), list(a="1", "b"))
+
+  # empty list results in empty list
+  expect_identical(flattenTags(list()), list())
+
+  # preserve attributes
+  nested <- list("txt1", list(structure("txt2", prop="prop2")))
+  flat <- list("txt1",
+               structure("txt2", prop="prop2"))
+  expect_identical(flattenTags(nested), flat)
+})

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/tests/test-url.R

@@ -0,0 +1,20 @@
+context("URL")
+
+test_that("Query string parsing", {
+  expect_identical(
+    parseQueryString("?foo=1&bar=b+a%20r&b+a%20z=baz&=nokey&novalue=&=&noequal&end=end"),
+    list(
+      foo     = '1',
+      bar     = 'b a r',
+      `b a z` = 'baz',
+                'nokey',
+      novalue = '',
+                '',
+      noequal = '',
+      end     = 'end'
+    )
+  )
+
+  # Should be the same with or without leading question mark
+  expect_identical(parseQueryString("?foo=1&bar=b"), parseQueryString("foo=1&bar=b"))
+})

inst/www/reactive-graph.html

@@ -0,0 +1,570 @@
+<!DOCTYPE html>
+<html>
+<script src="http://ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
+<script src="http://d3js.org/d3.v3.min.js" charset="utf-8"></script>
+<link href='http://fonts.googleapis.com/css?family=Source+Sans+Pro:200,400,600' rel='stylesheet' type='text/css'>
+<style type="text/css">
+html, body {
+  font-family: 'Source Sans Pro', sans-serif;
+  font-weight: 400;
+  overflow: hidden;
+  height: 100%;
+  width: 100%;
+  margin: 0;
+  padding: 0;
+}
+div {
+  -moz-user-select: none; 
+  -khtml-user-select: none; 
+  -webkit-user-select: none; 
+  -o-user-select: none;
+  cursor: default;
+}
+#instructions, #ended {
+  position: relative;
+  font-weight: 200;
+  color: #444;
+  top: 20px;
+  font-size: 30px;
+  text-align: center;
+}
+#ended strong {
+  font-weight: 600;
+}
+svg {
+  position: absolute;
+  left: 0;
+  top: 0;
+  width: 100%;
+  height: 100%;
+}
+.node {
+  cursor: pointer;
+}
+.node text {
+  font-family: 'Source Code Pro', monospace;
+  font-weight: normal;
+  text-anchor: start;
+  fill: #999;
+  user-select: none;
+  transition: fill 0.75s ease;
+}
+.node.running text {
+  fill: black;
+}
+.node.changed text {
+  fill: red;
+}
+.node text tspan {
+  white-space: pre;
+}
+.node path {
+  fill: white;
+  stroke: #777;
+  stroke-width: 7.5px;
+  transition: fill 0.75s ease;
+}
+.node.observer path {
+}
+.node.observable path {
+}
+.node.value path {
+}
+.node.invalidated path {
+  fill: #E0E0E0;
+  /*fill: url(#diagonalHatch);*/
+}
+.node.running path {
+  fill: #61B97E;
+}
+#legend {
+  font-size: 22px;
+  position: fixed;
+  bottom: 10px;
+  right: 20px;
+}
+.color {
+  display: inline-block;
+  border: 1px solid #777;
+  height: 14px;
+  width: 14px;
+}
+.color.normal {
+  background-color: #white;
+}
+.color.invalidated {
+  background-color: #E0E0E0;
+}
+.color.running {
+  background-color: #61B97E;
+}
+#triangle {
+  fill: #CCC;
+}
+.link {
+  fill: none;
+  stroke: #CCC;
+  stroke-width: 0.5px;
+}
+#description {
+  position: fixed;
+  width: 300px;
+  left: 630px;
+  top: 36px;
+  height: auto;
+  display: none;
+}
+</style>
+<script>
+var log = [
+  { "action" : "valueChange", "id" : "names(input)", "value" : " chr \"dataset\"" },
+  { "action" : "valueChange", "id" : "input (all)", "value" : "List of 1\n $ dataset: chr \"rock\"" },
+  { "action" : "valueChange", "id" : "input$dataset", "value" : " chr \"rock\"" },
+  { "action" : "valueChange", "id" : "names(input)", "value" : " chr [1:2] \"caption\" \"dataset\"" },
+  { "action" : "valueChange", "id" : "input (all)", "value" : "List of 2\n $ caption: chr \"Data Summary\"\n $ dataset: chr \"rock\"" },
+  { "action" : "valueChange", "id" : "input$caption", "value" : " chr \"Data Summary\"" },
+  { "action" : "valueChange", "id" : "names(input)", "value" : " chr [1:3] \"caption\" \"dataset\" \"obs\"" },
+  { "action" : "valueChange", "id" : "input (all)", "value" : "List of 3\n $ caption: chr \"Data Summary\"\n $ obs    : num 10\n $ dataset: chr \"rock\"" },
+  { "action" : "valueChange", "id" : "input$obs", "value" : " num 10" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr \"output_caption_hidden\"" },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 1\n $ output_caption_hidden: logi FALSE" },
+  { "action" : "valueChange", "id" : "clientData$output_caption_hidden", "value" : " logi FALSE" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:2] \"output_caption_hidden\" \"output_summary_hidden\"" },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 2\n $ output_caption_hidden: logi FALSE\n $ output_summary_hidden: logi FALSE" },
+  { "action" : "valueChange", "id" : "clientData$output_summary_hidden", "value" : " logi FALSE" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:3] \"output_caption_hidden\" \"output_summary_hidden\" \"output_view_hidden\"" },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 3\n $ output_view_hidden   : logi FALSE\n $ output_caption_hidden: logi FALSE\n $ output_summary_hidden: logi FALSE" },
+  { "action" : "valueChange", "id" : "clientData$output_view_hidden", "value" : " logi FALSE" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:4] \"output_caption_hidden\" \"output_summary_hidden\" \"output_view_hidden\" ..." },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 4\n $ output_view_hidden   : logi FALSE\n $ output_caption_hidden: logi FALSE\n $ pixelratio           : num 2\n $ output_summary_hidden: logi FALSE" },
+  { "action" : "valueChange", "id" : "clientData$pixelratio", "value" : " num 2" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:5] \"output_caption_hidden\" \"output_summary_hidden\" \"output_view_hidden\" ..." },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 5\n $ output_view_hidden   : logi FALSE\n $ output_caption_hidden: logi FALSE\n $ pixelratio           : num 2\n $ output_summary_hidden: logi FALSE\n $ url_protocol         : chr \"http:\"" },
+  { "action" : "valueChange", "id" : "clientData$url_protocol", "value" : " chr \"http:\"" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:6] \"output_caption_hidden\" \"output_summary_hidden\" \"output_view_hidden\" ..." },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 6\n $ output_view_hidden   : logi FALSE\n $ output_caption_hidden: logi FALSE\n $ pixelratio           : num 2\n $ url_hostname         : chr \"localhost\"\n $ output_summary_hidden: logi FALSE\n $ url_protocol         : chr \"http:\"" },
+  { "action" : "valueChange", "id" : "clientData$url_hostname", "value" : " chr \"localhost\"" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:7] \"output_caption_hidden\" \"output_summary_hidden\" \"output_view_hidden\" ..." },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 7\n $ output_view_hidden   : logi FALSE\n $ url_port             : chr \"8100\"\n $ output_caption_hidden: logi FALSE\n $ pixelratio           : num 2\n $ url_hostname         : chr \"localhost\"\n $ output_summary_hidden: logi FALSE\n $ url_protocol         : chr \"http:\"" },
+  { "action" : "valueChange", "id" : "clientData$url_port", "value" : " chr \"8100\"" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:8] \"output_caption_hidden\" \"output_summary_hidden\" \"output_view_hidden\" ..." },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 8\n $ url_pathname         : chr \"/\"\n $ output_view_hidden   : logi FALSE\n $ url_port             : chr \"8100\"\n $ output_caption_hidden: logi FALSE\n $ pixelratio           : num 2\n $ url_hostname         : chr \"localhost\"\n $ output_summary_hidden: logi FALSE\n $ url_protocol         : chr \"http:\"" },
+  { "action" : "valueChange", "id" : "clientData$url_pathname", "value" : " chr \"/\"" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:9] \"output_caption_hidden\" \"output_summary_hidden\" \"output_view_hidden\" ..." },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 9\n $ url_pathname         : chr \"/\"\n $ output_view_hidden   : logi FALSE\n $ url_port             : chr \"8100\"\n $ output_caption_hidden: logi FALSE\n $ pixelratio           : num 2\n $ url_hostname         : chr \"localhost\"\n $ output_summary_hidden: logi FALSE\n $ url_search           : chr \"\"\n $ url_protocol         : chr \"http:\"" },
+  { "action" : "valueChange", "id" : "clientData$url_search", "value" : " chr \"\"" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:10] \"output_caption_hidden\" \"output_summary_hidden\" \"output_view_hidden\" ..." },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 10\n $ url_pathname         : chr \"/\"\n $ output_view_hidden   : logi FALSE\n $ url_port             : chr \"8100\"\n $ output_caption_hidden: logi FALSE\n $ url_hash_initial     : chr \"\"\n $ pixelratio           : num 2\n $ url_hostname         : chr \"localhost\"\n $ output_summary_hidden: logi FALSE\n $ url_search           : chr \"\"\n $ url_protocol         : chr \"http:\"" },
+  { "action" : "valueChange", "id" : "clientData$url_hash_initial", "value" : " chr \"\"" },
+  { "action" : "valueChange", "id" : "names(clientData)", "value" : " chr [1:11] \"allowDataUriScheme\" \"output_caption_hidden\" \"output_summary_hidden\" ..." },
+  { "action" : "valueChange", "id" : "clientData (all)", "value" : "List of 11\n $ allowDataUriScheme   : logi TRUE\n $ url_pathname         : chr \"/\"\n $ output_view_hidden   : logi FALSE\n $ url_port             : chr \"8100\"\n $ output_caption_hidden: logi FALSE\n $ url_hash_initial     : chr \"\"\n $ pixelratio           : num 2\n $ url_hostname         : chr \"localhost\"\n $ output_summary_hidden: logi FALSE\n $ url_search           : chr \"\"\n $ url_protocol         : chr \"http:\"" },
+  { "action" : "valueChange", "id" : "clientData$allowDataUriScheme", "value" : " logi TRUE" },
+  { "action" : "ctx", "id" : "1", "label" : "output$caption <- renderText({ \n    input$caption\n})", "type" : "observer", "prevId" : "" },
+  { "action" : "invalidate", "id" : "1" },
+  { "action" : "ctx", "id" : "2", "label" : "output$summary <- renderPrint({ \n    dataset <- datasetInput()\n    summary(dataset)\n})", "type" : "observer", "prevId" : "" },
+  { "action" : "invalidate", "id" : "2" },
+  { "action" : "ctx", "id" : "3", "label" : "output$view <- renderTable({ \n    head(datasetInput(), n = input$obs)\n})", "type" : "observer", "prevId" : "" },
+  { "action" : "invalidate", "id" : "3" },
+  { "action" : "ctx", "id" : "4", "label" : "output$caption <- renderText({ \n    input$caption\n})", "type" : "observer", "prevId" : "1" },
+  { "action" : "enter", "id" : "4" },
+  { "action" : "dep", "id" : "4", "dependsOn" : "input$caption" },
+  { "action" : "exit", "id" : "4" },
+  { "action" : "ctx", "id" : "5", "label" : "output$summary <- renderPrint({ \n    dataset <- datasetInput()\n    summary(dataset)\n})", "type" : "observer", "prevId" : "2" },
+  { "action" : "enter", "id" : "5" },
+  { "action" : "ctx", "id" : "6", "label" : "reactive({ \n    switch(input$dataset, rock = rock, pressure = pressure, cars = cars)\n})", "type" : "observable", "prevId" : "" },
+  { "action" : "enter", "id" : "6" },
+  { "action" : "dep", "id" : "6", "dependsOn" : "input$dataset" },
+  { "action" : "exit", "id" : "6" },
+  { "action" : "depId", "id" : "5", "dependsOn" : "6" },
+  { "action" : "exit", "id" : "5" },
+  { "action" : "ctx", "id" : "7", "label" : "output$view <- renderTable({ \n    head(datasetInput(), n = input$obs)\n})", "type" : "observer", "prevId" : "3" },
+  { "action" : "enter", "id" : "7" },
+  { "action" : "depId", "id" : "7", "dependsOn" : "6" },
+  { "action" : "dep", "id" : "7", "dependsOn" : "input$obs" },
+  { "action" : "exit", "id" : "7" },
+  { "action" : "valueChange", "id" : "names(input)", "value" : " chr [1:3] \"caption\" \"dataset\" \"obs\"" },
+  { "action" : "valueChange", "id" : "input (all)", "value" : "List of 3\n $ caption: chr \"Pressure Summary\"\n $ obs    : num 10\n $ dataset: chr \"rock\"" },
+  { "action" : "valueChange", "id" : "input$caption", "value" : " chr \"Pressure Summary\"" },
+  { "action" : "invalidate", "id" : "4" },
+  { "action" : "ctx", "id" : "8", "label" : "output$caption <- renderText({ \n    input$caption\n})", "type" : "observer", "prevId" : "4" },
+  { "action" : "enter", "id" : "8" },
+  { "action" : "dep", "id" : "8", "dependsOn" : "input$caption" },
+  { "action" : "exit", "id" : "8" },
+  { "action" : "valueChange", "id" : "names(input)", "value" : " chr [1:3] \"caption\" \"dataset\" \"obs\"" },
+  { "action" : "valueChange", "id" : "input (all)", "value" : "List of 3\n $ caption: chr \"Pressure Summary\"\n $ obs    : num 10\n $ dataset: chr \"pressure\"" },
+  { "action" : "valueChange", "id" : "input$dataset", "value" : " chr \"pressure\"" },
+  { "action" : "invalidate", "id" : "6" },
+  { "action" : "invalidate", "id" : "5" },
+  { "action" : "invalidate", "id" : "7" },
+  { "action" : "ctx", "id" : "9", "label" : "output$summary <- renderPrint({ \n    dataset <- datasetInput()\n    summary(dataset)\n})", "type" : "observer", "prevId" : "5" },
+  { "action" : "enter", "id" : "9" },
+  { "action" : "ctx", "id" : "10", "label" : "reactive({ \n    switch(input$dataset, rock = rock, pressure = pressure, cars = cars)\n})", "type" : "observable", "prevId" : "6" },
+  { "action" : "enter", "id" : "10" },
+  { "action" : "dep", "id" : "10", "dependsOn" : "input$dataset" },
+  { "action" : "exit", "id" : "10" },
+  { "action" : "depId", "id" : "9", "dependsOn" : "10" },
+  { "action" : "exit", "id" : "9" },
+  { "action" : "ctx", "id" : "11", "label" : "output$view <- renderTable({ \n    head(datasetInput(), n = input$obs)\n})", "type" : "observer", "prevId" : "7" },
+  { "action" : "enter", "id" : "11" },
+  { "action" : "depId", "id" : "11", "dependsOn" : "10" },
+  { "action" : "dep", "id" : "11", "dependsOn" : "input$obs" },
+  { "action" : "exit", "id" : "11" },
+  { "action" : "valueChange", "id" : "names(input)", "value" : " chr [1:3] \"caption\" \"dataset\" \"obs\"" },
+  { "action" : "valueChange", "id" : "input (all)", "value" : "List of 3\n $ caption: chr \"Pressure Summary\"\n $ obs    : num 15\n $ dataset: chr \"pressure\"" },
+  { "action" : "valueChange", "id" : "input$obs", "value" : " num 15" },
+  { "action" : "invalidate", "id" : "11" },
+  { "action" : "ctx", "id" : "12", "label" : "output$view <- renderTable({ \n    head(datasetInput(), n = input$obs)\n})", "type" : "observer", "prevId" : "11" },
+  { "action" : "enter", "id" : "12" },
+  { "action" : "depId", "id" : "12", "dependsOn" : "10" },
+  { "action" : "dep", "id" : "12", "dependsOn" : "input$obs" },
+  { "action" : "exit", "id" : "12" }
+];
+try {
+  log = __DATA__;
+} catch (e) {}
+
+var nodes = {};
+var nodeList = [];
+var nodeSelection = null;
+var links = [];
+var linkSelection = null;
+
+var node, link;  // d3 selections
+
+var MAX_LINES = 6;
+
+var force = d3.layout.force()
+    .charge(-100)
+    .nodes(nodeList)
+    .links(links);
+force.on('tick', onTick);
+
+function pathDataForNode(node) {
+/*
+d="m 58,2  c -75,0 -75,100 0,100  l 60,0  l 50,-50  l -50,-50  Z"
+d="m 58,2  c -75,0 -75,100 0,100  l 100,0  l 0,-100 Z"
+d="m 2,0 l 0,100 l 100,0  l 50,-50  l -50,-50  Z"
+*/
+  switch (node.type) {
+    case 'observer':
+      return 'M -25,-50  c -75,0 -75,100 0,100  l 100,0  l 0,-100 Z';
+    case 'observable':
+      return 'M -25,-50  c -75,0 -75,100 0,100  l 60,0  l 50,-50  l -50,-50  Z';
+    case 'value':
+      return 'M -50,-50 l 0,100 l 100,0  l 50,-50  l -50,-50  Z';
+  }
+}
+
+function getSourceCoords(node) {
+  switch (node.type) {
+    case 'observer':
+    case 'observable':
+      return {x: node.x - 5, y: node.y};
+    default:
+      return {x: node.x, y: node.y};
+  }
+}
+
+function getTargetCoords(node) {
+  switch (node.type) {
+    case 'observable':
+      return {x: node.x + 7, y: node.y};
+    case 'value':
+      return {x: node.x + 8, y: node.y};
+    default:
+      return {x: node.x, y: node.y};
+  }
+}
+
+function multilineTextNode(node) {
+  var MAX_LINES = 6;
+  var fade = false;
+  var el = d3.select(this);
+  var lines = el.text().split('\n');
+  if (lines.length > MAX_LINES) {
+    lines.splice(MAX_LINES);
+    fade = true;
+  }
+  el.text('');
+  var tspan = el.selectAll('tspan').data(lines);
+  tspan.enter().append('tspan');
+  tspan
+      .attr('x', 8)
+      .attr('dy', function(line, i) { return i > 0 ? '1em' : 0})
+      .attr('opacity', function(line, i) {
+        if (!fade)
+          return 1;
+        return Math.min(1, (MAX_LINES - i) * 0.25 - 0.15);
+      })
+      .text(function(line) { return line; });
+}
+
+function update() {
+  force.size([document.documentElement.clientWidth / 4,
+              document.documentElement.clientHeight / 4]);
+
+  var layoutDirty = true;
+
+  node = d3.select('#nodes').selectAll('.node').data(nodeList);
+  //layoutDirty = layoutDirty || !node.enter().empty() || !node.exit().empty();
+  var newG = node.enter().append('g')
+      .attr('class', function(n) {return 'node ' + n.type;})
+      .attr('r', 5)
+      // don't show until next tick
+      .style('display', 'none')
+      .on('mousedown', function() {
+        d3.event.stopPropagation();
+      })
+      .on('mouseover', function(n) {
+        $('#description').text(n.label);
+      })
+      .on('mouseout', function(d, i) {
+        $('#description').html('');
+      })
+      .call(force.drag);
+  newG.append('path')
+      .attr('transform', 'scale(0.08)')
+      .attr('stroke', 'black')
+      .attr('stroke-width', 4)
+      .attr('fill', 'white')
+      .attr('d', pathDataForNode);
+  newG.append('text')
+      .attr('x', 3)
+      .attr('y', 0)
+      .attr('font-size', 2.5)
+      .attr('transform', function(n) {
+        if (n.type !== 'observer')
+          return 'translate(1.5, 0)';
+        else
+          return null;
+      })
+  node.exit().remove();
+  node
+      .classed('invalidated', function(n) { return n.invalidated; })
+      .classed('running', function(n) { return n.running; })
+      .classed('changed', function(n) { return n.changed; })
+      .attr('fill', function(n) {
+        if (n.invalidated)
+          return "url(#diagonalHatch)";
+        else
+          return null;
+      });
+  var tspan = node.selectAll('text').filter(function(n) {
+    // This filter is used to disregard all nodes whose labels have
+    // not changed since the last time we updated them.
+    var changed = n.label !== this.label;
+    this.label = n.label;
+    return changed;
+  }).selectAll('tspan')
+    .data(function(n) {
+      var lines = n.label.split('\n');
+      if (lines.length > MAX_LINES) {
+        lines.splice(MAX_LINES);
+      }
+      return lines;
+    });
+  tspan.enter().append('tspan');
+  tspan.exit().remove();
+  tspan
+      .attr('x', 8)
+      .attr('dy', function(line, i) { return i > 0 ? '1em' : 0})
+      .attr('opacity', function(line, i) {
+        return Math.min(1, (MAX_LINES - i) * 0.25 - 0.15);
+      })
+      .text(function(line) { return line; });
+
+  link = d3.select('#links').selectAll('.link').data(links);
+  //layoutDirty = layoutDirty || !link.enter().empty() || !link.exit().empty();
+  link.enter().append('path')
+      .attr('class', 'link')
+      .attr('marker-mid', 'url(#triangle)');
+  link.exit().remove();
+
+  if (layoutDirty) {
+    force
+      .nodes(nodeList.filter(function(n) {return !n.hide;}))
+      .start();
+    layoutDirty = false;
+  }
+}
+
+function onTick() {
+  node
+      .style('display', null)
+      .attr('transform', function(n) {
+        return 'translate(' + n.x + ' ' + n.y + ')';
+      });
+  link
+      .attr('d', function(link) {
+        var source = getSourceCoords(link.source);
+        var target = getTargetCoords(link.target)
+        var mid = {
+          x: (source.x + target.x) / 2,
+          y: (source.y + target.y) / 2
+        }
+        return 'M' + source.x + ',' + source.y +
+          ' L' + mid.x + ',' + mid.y +
+          ' L' + target.x + ',' + target.y;
+      });
+}
+
+function createNode(data) {
+  var node;
+  if (!data.prevId) {
+    node = {
+      label: data.label,
+      type: data.type,
+      hide: data.hide
+    };
+    nodes[data.id] = node;
+    if (!node.hide)
+      nodeList.push(node);
+  } else {
+    node = nodes[data.prevId];
+    delete nodes[data.prevId];
+    nodes[data.id] = node;
+    node.label = data.label;
+    node.invalidated = false;
+  }
+}
+
+var callbacks = {
+  ctx: function(data) {
+    createNode(data);
+    return true;
+  },
+  dep: function(data) {
+    var dependsOn = nodes[data.dependsOn];
+    if (!dependsOn) {
+      createNode({id: data.dependsOn, label: data.dependsOn, type: 'value'});
+      dependsOn = nodes[data.dependsOn];
+    }
+    if (dependsOn.hide) {
+      dependsOn.hide = false;
+      nodeList.push(dependsOn);
+    }
+    links.push({
+      source: nodes[data.id],
+      target: nodes[data.dependsOn]
+    });
+  },
+  depId: function(data) {
+    links.push({
+      source: nodes[data.id],
+      target: nodes[data.dependsOn]
+    });
+  },
+  invalidate: function(data) {
+    var node = nodes[data.id];
+    node.invalidated = true;
+    links = links.filter(function(link) {
+      return link.source !== node;
+    });
+  },
+  valueChange: function(data) {
+    var existed = !!nodes[data.id];
+    createNode({
+      id: data.id,
+      label: data.id + ' = ' + data.value,
+      type: 'value',
+      prevId: nodes[data.id] ? data.id : null,
+      hide: existed ? nodes[data.id].hide : true
+    });
+    if (!existed || nodes[data.id].hide)
+      return true;
+    nodes[data.id].changed = true;
+    executeBeforeNextCommand.push(function() {
+      nodes[data.id].changed = false;
+    });
+  },
+  enter: function(data) {
+    var node = nodes[data.id];
+    node.running = true;
+  },
+  exit: function(data) {
+    var node = nodes[data.id];
+    node.running = false;
+  }
+};
+
+function processMessage(data) {
+  console.log(JSON.stringify(data));
+  if (!callbacks.hasOwnProperty(data.action))
+    throw new Error('Unknown action ' + data.action);
+  var result = callbacks[data.action].call(callbacks, data);
+  update();
+  return result;
+}
+
+var executeBeforeNextCommand = [];
+function doNext() {
+  while (executeBeforeNextCommand.length)
+    executeBeforeNextCommand.shift()();
+  while (log.length)
+    if (!processMessage(log.shift()))
+      break;
+  if (!log.length)
+    $('#ended').fadeIn(1500);
+}
+
+function zoom() {
+  var scale = d3.event.scale;
+  var x = d3.event.translate[0];
+  var y = d3.event.translate[1];
+  d3.select('#viz').attr('transform', 'scale(' + scale + ') translate(' + x/scale + ' ' + y/scale + ')');
+}
+$(function() {
+  d3.select('svg').call(d3.behavior.zoom().scale(4).on('zoom', zoom));
+  $(document.body).on('keydown', function(e) {
+    if (e.which === 39 || e.which === 32)
+      doNext();
+    if (e.which === 35) {
+      while (log.length) {
+        doNext();
+      }
+    }
+  });
+  doNext();
+  executeBeforeNextCommand.push(function() {
+    $('#instructions').fadeOut(1000);
+  });
+});
+</script>
+<body>
+  <svg>
+    <defs>
+      <marker id="triangle"
+              viewBox="0 0 10 10" 
+              refX="5" refY="5"
+              markerWidth="6" 
+              markerHeight="6"
+              orient="auto">
+          <path d="M 10 0 L 0 5 L 10 10 z" />
+      </marker>
+      <pattern id="diagonalHatch" patternUnits="userSpaceOnUse" width="1" height="1">
+        <path stroke="black" stroke-width="0.25" fill="none"
+          d="M-1,1 l2,-2
+             M0,4 l4,-4
+             M3,5 l2,-2" />
+      </pattern>
+    </defs>
+    <g id="viz" transform="scale(4)">
+      <g id="links"></g>
+      <g id="nodes"></g>
+    </g>
+  </svg>
+  <div id="instructions">
+    Press right-arrow to advance
+  </div>
+  <div id="ended" style="display: none;">
+    <strong>You&rsquo;ve reached the end</strong><br/>Reload the page to start over
+  </div>
+  <div id="legend">
+    <div class="color normal"></div> Normal<br/>
+    <div class="color invalidated"></div> Invalidated<br/>
+    <div class="color running"></div> Running<br/>
+  </div>
+  <br/>
+  <pre id="description"><br/></pre>
+</body>
+</html>

inst/www/shared/datepicker/css/datepicker.css

@@ -0,0 +1,442 @@
+/*!
+ * Datepicker for Bootstrap
+ *
+ * Copyright 2012 Stefan Petre
+ * Improvements by Andrew Rowls
+ * Licensed under the Apache License v2.0
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ */
+.datepicker {
+  padding: 4px;
+  -webkit-border-radius: 4px;
+  -moz-border-radius: 4px;
+  border-radius: 4px;
+  direction: ltr;
+  /*.dow {
+		border-top: 1px solid #ddd !important;
+	}*/
+
+}
+.datepicker-inline {
+  width: 220px;
+}
+.datepicker.datepicker-rtl {
+  direction: rtl;
+}
+.datepicker.datepicker-rtl table tr td span {
+  float: right;
+}
+.datepicker-dropdown {
+  top: 0;
+  left: 0;
+}
+.datepicker-dropdown:before {
+  content: '';
+  display: inline-block;
+  border-left: 7px solid transparent;
+  border-right: 7px solid transparent;
+  border-bottom: 7px solid #ccc;
+  border-bottom-color: rgba(0, 0, 0, 0.2);
+  position: absolute;
+  top: -7px;
+  left: 6px;
+}
+.datepicker-dropdown:after {
+  content: '';
+  display: inline-block;
+  border-left: 6px solid transparent;
+  border-right: 6px solid transparent;
+  border-bottom: 6px solid #ffffff;
+  position: absolute;
+  top: -6px;
+  left: 7px;
+}
+.datepicker > div {
+  display: none;
+}
+.datepicker.days div.datepicker-days {
+  display: block;
+}
+.datepicker.months div.datepicker-months {
+  display: block;
+}
+.datepicker.years div.datepicker-years {
+  display: block;
+}
+.datepicker table {
+  margin: 0;
+}
+.datepicker td,
+.datepicker th {
+  text-align: center;
+  width: 20px;
+  height: 20px;
+  -webkit-border-radius: 4px;
+  -moz-border-radius: 4px;
+  border-radius: 4px;
+  border: none;
+}
+.table-striped .datepicker table tr td,
+.table-striped .datepicker table tr th {
+  background-color: transparent;
+}
+.datepicker table tr td.day:hover {
+  background: #eeeeee;
+  cursor: pointer;
+}
+.datepicker table tr td.old,
+.datepicker table tr td.new {
+  color: #999999;
+}
+.datepicker table tr td.disabled,
+.datepicker table tr td.disabled:hover {
+  background: none;
+  color: #999999;
+  cursor: default;
+}
+.datepicker table tr td.today,
+.datepicker table tr td.today:hover,
+.datepicker table tr td.today.disabled,
+.datepicker table tr td.today.disabled:hover {
+  background-color: #fde19a;
+  background-image: -moz-linear-gradient(top, #fdd49a, #fdf59a);
+  background-image: -ms-linear-gradient(top, #fdd49a, #fdf59a);
+  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#fdd49a), to(#fdf59a));
+  background-image: -webkit-linear-gradient(top, #fdd49a, #fdf59a);
+  background-image: -o-linear-gradient(top, #fdd49a, #fdf59a);
+  background-image: linear-gradient(top, #fdd49a, #fdf59a);
+  background-repeat: repeat-x;
+  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#fdd49a', endColorstr='#fdf59a', GradientType=0);
+  border-color: #fdf59a #fdf59a #fbed50;
+  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
+  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
+  color: #000 !important;
+}
+.datepicker table tr td.today:hover,
+.datepicker table tr td.today:hover:hover,
+.datepicker table tr td.today.disabled:hover,
+.datepicker table tr td.today.disabled:hover:hover,
+.datepicker table tr td.today:active,
+.datepicker table tr td.today:hover:active,
+.datepicker table tr td.today.disabled:active,
+.datepicker table tr td.today.disabled:hover:active,
+.datepicker table tr td.today.active,
+.datepicker table tr td.today:hover.active,
+.datepicker table tr td.today.disabled.active,
+.datepicker table tr td.today.disabled:hover.active,
+.datepicker table tr td.today.disabled,
+.datepicker table tr td.today:hover.disabled,
+.datepicker table tr td.today.disabled.disabled,
+.datepicker table tr td.today.disabled:hover.disabled,
+.datepicker table tr td.today[disabled],
+.datepicker table tr td.today:hover[disabled],
+.datepicker table tr td.today.disabled[disabled],
+.datepicker table tr td.today.disabled:hover[disabled] {
+  background-color: #fdf59a;
+}
+.datepicker table tr td.today:active,
+.datepicker table tr td.today:hover:active,
+.datepicker table tr td.today.disabled:active,
+.datepicker table tr td.today.disabled:hover:active,
+.datepicker table tr td.today.active,
+.datepicker table tr td.today:hover.active,
+.datepicker table tr td.today.disabled.active,
+.datepicker table tr td.today.disabled:hover.active {
+  background-color: #fbf069 \9;
+}
+.datepicker table tr td.range,
+.datepicker table tr td.range:hover,
+.datepicker table tr td.range.disabled,
+.datepicker table tr td.range.disabled:hover {
+  background: #eeeeee;
+  -webkit-border-radius: 0;
+  -moz-border-radius: 0;
+  border-radius: 0;
+}
+.datepicker table tr td.range.today,
+.datepicker table tr td.range.today:hover,
+.datepicker table tr td.range.today.disabled,
+.datepicker table tr td.range.today.disabled:hover {
+  background-color: #f3d17a;
+  background-image: -moz-linear-gradient(top, #f3c17a, #f3e97a);
+  background-image: -ms-linear-gradient(top, #f3c17a, #f3e97a);
+  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#f3c17a), to(#f3e97a));
+  background-image: -webkit-linear-gradient(top, #f3c17a, #f3e97a);
+  background-image: -o-linear-gradient(top, #f3c17a, #f3e97a);
+  background-image: linear-gradient(top, #f3c17a, #f3e97a);
+  background-repeat: repeat-x;
+  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#f3c17a', endColorstr='#f3e97a', GradientType=0);
+  border-color: #f3e97a #f3e97a #edde34;
+  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
+  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
+  -webkit-border-radius: 0;
+  -moz-border-radius: 0;
+  border-radius: 0;
+}
+.datepicker table tr td.range.today:hover,
+.datepicker table tr td.range.today:hover:hover,
+.datepicker table tr td.range.today.disabled:hover,
+.datepicker table tr td.range.today.disabled:hover:hover,
+.datepicker table tr td.range.today:active,
+.datepicker table tr td.range.today:hover:active,
+.datepicker table tr td.range.today.disabled:active,
+.datepicker table tr td.range.today.disabled:hover:active,
+.datepicker table tr td.range.today.active,
+.datepicker table tr td.range.today:hover.active,
+.datepicker table tr td.range.today.disabled.active,
+.datepicker table tr td.range.today.disabled:hover.active,
+.datepicker table tr td.range.today.disabled,
+.datepicker table tr td.range.today:hover.disabled,
+.datepicker table tr td.range.today.disabled.disabled,
+.datepicker table tr td.range.today.disabled:hover.disabled,
+.datepicker table tr td.range.today[disabled],
+.datepicker table tr td.range.today:hover[disabled],
+.datepicker table tr td.range.today.disabled[disabled],
+.datepicker table tr td.range.today.disabled:hover[disabled] {
+  background-color: #f3e97a;
+}
+.datepicker table tr td.range.today:active,
+.datepicker table tr td.range.today:hover:active,
+.datepicker table tr td.range.today.disabled:active,
+.datepicker table tr td.range.today.disabled:hover:active,
+.datepicker table tr td.range.today.active,
+.datepicker table tr td.range.today:hover.active,
+.datepicker table tr td.range.today.disabled.active,
+.datepicker table tr td.range.today.disabled:hover.active {
+  background-color: #efe24b \9;
+}
+.datepicker table tr td.selected,
+.datepicker table tr td.selected:hover,
+.datepicker table tr td.selected.disabled,
+.datepicker table tr td.selected.disabled:hover {
+  background-color: #9e9e9e;
+  background-image: -moz-linear-gradient(top, #b3b3b3, #808080);
+  background-image: -ms-linear-gradient(top, #b3b3b3, #808080);
+  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#b3b3b3), to(#808080));
+  background-image: -webkit-linear-gradient(top, #b3b3b3, #808080);
+  background-image: -o-linear-gradient(top, #b3b3b3, #808080);
+  background-image: linear-gradient(top, #b3b3b3, #808080);
+  background-repeat: repeat-x;
+  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#b3b3b3', endColorstr='#808080', GradientType=0);
+  border-color: #808080 #808080 #595959;
+  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
+  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
+  color: #fff;
+  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
+}
+.datepicker table tr td.selected:hover,
+.datepicker table tr td.selected:hover:hover,
+.datepicker table tr td.selected.disabled:hover,
+.datepicker table tr td.selected.disabled:hover:hover,
+.datepicker table tr td.selected:active,
+.datepicker table tr td.selected:hover:active,
+.datepicker table tr td.selected.disabled:active,
+.datepicker table tr td.selected.disabled:hover:active,
+.datepicker table tr td.selected.active,
+.datepicker table tr td.selected:hover.active,
+.datepicker table tr td.selected.disabled.active,
+.datepicker table tr td.selected.disabled:hover.active,
+.datepicker table tr td.selected.disabled,
+.datepicker table tr td.selected:hover.disabled,
+.datepicker table tr td.selected.disabled.disabled,
+.datepicker table tr td.selected.disabled:hover.disabled,
+.datepicker table tr td.selected[disabled],
+.datepicker table tr td.selected:hover[disabled],
+.datepicker table tr td.selected.disabled[disabled],
+.datepicker table tr td.selected.disabled:hover[disabled] {
+  background-color: #808080;
+}
+.datepicker table tr td.selected:active,
+.datepicker table tr td.selected:hover:active,
+.datepicker table tr td.selected.disabled:active,
+.datepicker table tr td.selected.disabled:hover:active,
+.datepicker table tr td.selected.active,
+.datepicker table tr td.selected:hover.active,
+.datepicker table tr td.selected.disabled.active,
+.datepicker table tr td.selected.disabled:hover.active {
+  background-color: #666666 \9;
+}
+.datepicker table tr td.active,
+.datepicker table tr td.active:hover,
+.datepicker table tr td.active.disabled,
+.datepicker table tr td.active.disabled:hover {
+  background-color: #006dcc;
+  background-image: -moz-linear-gradient(top, #0088cc, #0044cc);
+  background-image: -ms-linear-gradient(top, #0088cc, #0044cc);
+  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#0088cc), to(#0044cc));
+  background-image: -webkit-linear-gradient(top, #0088cc, #0044cc);
+  background-image: -o-linear-gradient(top, #0088cc, #0044cc);
+  background-image: linear-gradient(top, #0088cc, #0044cc);
+  background-repeat: repeat-x;
+  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#0088cc', endColorstr='#0044cc', GradientType=0);
+  border-color: #0044cc #0044cc #002a80;
+  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
+  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
+  color: #fff;
+  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
+}
+.datepicker table tr td.active:hover,
+.datepicker table tr td.active:hover:hover,
+.datepicker table tr td.active.disabled:hover,
+.datepicker table tr td.active.disabled:hover:hover,
+.datepicker table tr td.active:active,
+.datepicker table tr td.active:hover:active,
+.datepicker table tr td.active.disabled:active,
+.datepicker table tr td.active.disabled:hover:active,
+.datepicker table tr td.active.active,
+.datepicker table tr td.active:hover.active,
+.datepicker table tr td.active.disabled.active,
+.datepicker table tr td.active.disabled:hover.active,
+.datepicker table tr td.active.disabled,
+.datepicker table tr td.active:hover.disabled,
+.datepicker table tr td.active.disabled.disabled,
+.datepicker table tr td.active.disabled:hover.disabled,
+.datepicker table tr td.active[disabled],
+.datepicker table tr td.active:hover[disabled],
+.datepicker table tr td.active.disabled[disabled],
+.datepicker table tr td.active.disabled:hover[disabled] {
+  background-color: #0044cc;
+}
+.datepicker table tr td.active:active,
+.datepicker table tr td.active:hover:active,
+.datepicker table tr td.active.disabled:active,
+.datepicker table tr td.active.disabled:hover:active,
+.datepicker table tr td.active.active,
+.datepicker table tr td.active:hover.active,
+.datepicker table tr td.active.disabled.active,
+.datepicker table tr td.active.disabled:hover.active {
+  background-color: #003399 \9;
+}
+.datepicker table tr td span {
+  display: block;
+  width: 23%;
+  height: 54px;
+  line-height: 54px;
+  float: left;
+  margin: 1%;
+  cursor: pointer;
+  -webkit-border-radius: 4px;
+  -moz-border-radius: 4px;
+  border-radius: 4px;
+}
+.datepicker table tr td span:hover {
+  background: #eeeeee;
+}
+.datepicker table tr td span.disabled,
+.datepicker table tr td span.disabled:hover {
+  background: none;
+  color: #999999;
+  cursor: default;
+}
+.datepicker table tr td span.active,
+.datepicker table tr td span.active:hover,
+.datepicker table tr td span.active.disabled,
+.datepicker table tr td span.active.disabled:hover {
+  background-color: #006dcc;
+  background-image: -moz-linear-gradient(top, #0088cc, #0044cc);
+  background-image: -ms-linear-gradient(top, #0088cc, #0044cc);
+  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#0088cc), to(#0044cc));
+  background-image: -webkit-linear-gradient(top, #0088cc, #0044cc);
+  background-image: -o-linear-gradient(top, #0088cc, #0044cc);
+  background-image: linear-gradient(top, #0088cc, #0044cc);
+  background-repeat: repeat-x;
+  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#0088cc', endColorstr='#0044cc', GradientType=0);
+  border-color: #0044cc #0044cc #002a80;
+  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
+  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
+  color: #fff;
+  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
+}
+.datepicker table tr td span.active:hover,
+.datepicker table tr td span.active:hover:hover,
+.datepicker table tr td span.active.disabled:hover,
+.datepicker table tr td span.active.disabled:hover:hover,
+.datepicker table tr td span.active:active,
+.datepicker table tr td span.active:hover:active,
+.datepicker table tr td span.active.disabled:active,
+.datepicker table tr td span.active.disabled:hover:active,
+.datepicker table tr td span.active.active,
+.datepicker table tr td span.active:hover.active,
+.datepicker table tr td span.active.disabled.active,
+.datepicker table tr td span.active.disabled:hover.active,
+.datepicker table tr td span.active.disabled,
+.datepicker table tr td span.active:hover.disabled,
+.datepicker table tr td span.active.disabled.disabled,
+.datepicker table tr td span.active.disabled:hover.disabled,
+.datepicker table tr td span.active[disabled],
+.datepicker table tr td span.active:hover[disabled],
+.datepicker table tr td span.active.disabled[disabled],
+.datepicker table tr td span.active.disabled:hover[disabled] {
+  background-color: #0044cc;
+}
+.datepicker table tr td span.active:active,
+.datepicker table tr td span.active:hover:active,
+.datepicker table tr td span.active.disabled:active,
+.datepicker table tr td span.active.disabled:hover:active,
+.datepicker table tr td span.active.active,
+.datepicker table tr td span.active:hover.active,
+.datepicker table tr td span.active.disabled.active,
+.datepicker table tr td span.active.disabled:hover.active {
+  background-color: #003399 \9;
+}
+.datepicker table tr td span.old {
+  color: #999999;
+}
+.datepicker th.datepicker-switch {
+  width: 145px;
+}
+.datepicker thead tr:first-child th,
+.datepicker tfoot tr:first-child th {
+  cursor: pointer;
+}
+.datepicker thead tr:first-child th:hover,
+.datepicker tfoot tr:first-child th:hover {
+  background: #eeeeee;
+}
+.datepicker .cw {
+  font-size: 10px;
+  width: 12px;
+  padding: 0 2px 0 5px;
+  vertical-align: middle;
+}
+.datepicker thead tr:first-child th.cw {
+  cursor: default;
+  background-color: transparent;
+}
+.input-append.date .add-on i,
+.input-prepend.date .add-on i {
+  display: block;
+  cursor: pointer;
+  width: 16px;
+  height: 16px;
+}
+.input-daterange input {
+  text-align: center;
+}
+.input-daterange input:first-child {
+  -webkit-border-radius: 3px 0 0 3px;
+  -moz-border-radius: 3px 0 0 3px;
+  border-radius: 3px 0 0 3px;
+}
+.input-daterange input:last-child {
+  -webkit-border-radius: 0 3px 3px 0;
+  -moz-border-radius: 0 3px 3px 0;
+  border-radius: 0 3px 3px 0;
+}
+.input-daterange .add-on {
+  display: inline-block;
+  width: auto;
+  min-width: 16px;
+  height: 18px;
+  padding: 4px 5px;
+  font-weight: normal;
+  line-height: 18px;
+  text-align: center;
+  text-shadow: 0 1px 0 #ffffff;
+  vertical-align: middle;
+  background-color: #eeeeee;
+  border: 1px solid #ccc;
+  margin-left: -5px;
+  margin-right: -5px;
+}

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.bg.js

@@ -0,0 +1,14 @@
+/**
+ * Bulgarian translation for bootstrap-datepicker
+ * Apostol Apostolov <apostol.s.apostolov@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['bg'] = {
+		days: ["Неделя", "Понеделник", "Вторник", "Сряда", "Четвъртък", "Петък", "Събота", "Неделя"],
+		daysShort: ["Нед", "Пон", "Вто", "Сря", "Чет", "Пет", "Съб", "Нед"],
+		daysMin: ["Н", "П", "В", "С", "Ч", "П", "С", "Н"],
+		months: ["Януари", "Февруари", "Март", "Април", "Май", "Юни", "Юли", "Август", "Септември", "Октомври", "Ноември", "Декември"],
+		monthsShort: ["Ян", "Фев", "Мар", "Апр", "Май", "Юни", "Юли", "Авг", "Сеп", "Окт", "Ное", "Дек"],
+		today: "днес"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.ca.js

@@ -0,0 +1,14 @@
+/**
+ * Catalan translation for bootstrap-datepicker
+ * J. Garcia <jogaco.en@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['ca'] = {
+		days: ["Diumenge", "Dilluns", "Dimarts", "Dimecres", "Dijous", "Divendres", "Dissabte", "Diumenge"],
+		daysShort: ["Diu",  "Dil", "Dmt", "Dmc", "Dij", "Div", "Dis", "Diu"],
+		daysMin: ["dg", "dl", "dt", "dc", "dj", "dv", "ds", "dg"],
+		months: ["Gener", "Febrer", "Març", "Abril", "Maig", "Juny", "Juliol", "Agost", "Setembre", "Octubre", "Novembre", "Desembre"],
+		monthsShort: ["Gen", "Feb", "Mar", "Abr", "Mai", "Jun", "Jul", "Ago", "Set", "Oct", "Nov", "Des"],
+		today: "Avui"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.cs.js

@@ -0,0 +1,15 @@
+/**
+ * Czech translation for bootstrap-datepicker
+ * Matěj Koubík <matej@koubik.name>
+ * Fixes by Michal Remiš <michal.remis@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['cs'] = {
+		days: ["Neděle", "Pondělí", "Úterý", "Středa", "Čtvrtek", "Pátek", "Sobota", "Neděle"],
+		daysShort: ["Ned", "Pon", "Úte", "Stř", "Čtv", "Pát", "Sob", "Ned"],
+		daysMin: ["Ne", "Po", "Út", "St", "Čt", "Pá", "So", "Ne"],
+		months: ["Leden", "Únor", "Březen", "Duben", "Květen", "Červen", "Červenec", "Srpen", "Září", "Říjen", "Listopad", "Prosinec"],
+		monthsShort: ["Led", "Úno", "Bře", "Dub", "Kvě", "Čer", "Čnc", "Srp", "Zář", "Říj", "Lis", "Pro"],
+		today: "Dnes"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.da.js

@@ -0,0 +1,14 @@
+/**
+ * Danish translation for bootstrap-datepicker
+ * Christian Pedersen <http://github.com/chripede>
+ */
+;(function($){
+	$.fn.datepicker.dates['da'] = {
+		days: ["Søndag", "Mandag", "Tirsdag", "Onsdag", "Torsdag", "Fredag", "Lørdag", "Søndag"],
+		daysShort: ["Søn", "Man", "Tir", "Ons", "Tor", "Fre", "Lør", "Søn"],
+		daysMin: ["Sø", "Ma", "Ti", "On", "To", "Fr", "Lø", "Sø"],
+		months: ["Januar", "Februar", "Marts", "April", "Maj", "Juni", "Juli", "August", "September", "Oktober", "November", "December"],
+		monthsShort: ["Jan", "Feb", "Mar", "Apr", "Maj", "Jun", "Jul", "Aug", "Sep", "Okt", "Nov", "Dec"],
+		today: "I Dag"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.de.js

@@ -0,0 +1,16 @@
+/**
+ * German translation for bootstrap-datepicker
+ * Sam Zurcher <sam@orelias.ch>
+ */
+;(function($){
+	$.fn.datepicker.dates['de'] = {
+		days: ["Sonntag", "Montag", "Dienstag", "Mittwoch", "Donnerstag", "Freitag", "Samstag", "Sonntag"],
+		daysShort: ["Son", "Mon", "Die", "Mit", "Don", "Fre", "Sam", "Son"],
+		daysMin: ["So", "Mo", "Di", "Mi", "Do", "Fr", "Sa", "So"],
+		months: ["Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", "August", "September", "Oktober", "November", "Dezember"],
+		monthsShort: ["Jan", "Feb", "Mär", "Apr", "Mai", "Jun", "Jul", "Aug", "Sep", "Okt", "Nov", "Dez"],
+		today: "Heute",
+		weekStart: 1,
+		format: "dd.mm.yyyy"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.el.js

@@ -0,0 +1,13 @@
+/**
+* Greek translation for bootstrap-datepicker
+*/
+;(function($){
+  $.fn.datepicker.dates['el'] = {
+    days: ["Κυριακή", "Δευτέρα", "Τρίτη", "Τετάρτη", "Πέμπτη", "Παρασκευή", "Σάββατο", "Κυριακή"],
+    daysShort: ["Κυρ", "Δευ", "Τρι", "Τετ", "Πεμ", "Παρ", "Σαβ", "Κυρ"],
+    daysMin: ["Κυ", "Δε", "Τρ", "Τε", "Πε", "Πα", "Σα", "Κυ"],
+    months: ["Ιανουάριος", "Φεβρουάριος", "Μάρτιος", "Απρίλιος", "Μάιος", "Ιούνιος", "Ιούλιος", "Αύγουστος", "Σεπτέμβριος", "Οκτώβριος", "Νοέμβριος", "Δεκέμβριος"],
+    monthsShort: ["Ιαν", "Φεβ", "Μαρ", "Απρ", "Μάι", "Ιουν", "Ιουλ", "Αυγ", "Σεπ", "Οκτ", "Νοε", "Δεκ"],
+    today: "Σήμερα"
+  };
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.es.js

@@ -0,0 +1,14 @@
+/**
+ * Spanish translation for bootstrap-datepicker
+ * Bruno Bonamin <bruno.bonamin@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['es'] = {
+		days: ["Domingo", "Lunes", "Martes", "Miércoles", "Jueves", "Viernes", "Sábado", "Domingo"],
+		daysShort: ["Dom", "Lun", "Mar", "Mié", "Jue", "Vie", "Sáb", "Dom"],
+		daysMin: ["Do", "Lu", "Ma", "Mi", "Ju", "Vi", "Sa", "Do"],
+		months: ["Enero", "Febrero", "Marzo", "Abril", "Mayo", "Junio", "Julio", "Agosto", "Septiembre", "Octubre", "Noviembre", "Diciembre"],
+		monthsShort: ["Ene", "Feb", "Mar", "Abr", "May", "Jun", "Jul", "Ago", "Sep", "Oct", "Nov", "Dic"],
+		today: "Hoy"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.fi.js

@@ -0,0 +1,14 @@
+/**
+ * Finnish translation for bootstrap-datepicker
+ * Jaakko Salonen <https://github.com/jsalonen>
+ */
+;(function($){
+	$.fn.datepicker.dates['fi'] = {
+		days: ["sunnuntai", "maanantai", "tiistai", "keskiviikko", "torstai", "perjantai", "lauantai", "sunnuntai"],
+		daysShort: ["sun", "maa", "tii", "kes", "tor", "per", "lau", "sun"],
+		daysMin: ["su", "ma", "ti", "ke", "to", "pe", "la", "su"],
+		months: ["tammikuu", "helmikuu", "maaliskuu", "huhtikuu", "toukokuu", "kesäkuu", "heinäkuu", "elokuu", "syyskuu", "lokakuu", "marraskuu", "joulukuu"],
+		monthsShort: ["tam", "hel", "maa", "huh", "tou", "kes", "hei", "elo", "syy", "lok", "mar", "jou"],
+		today: "tänään"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.fr.js

@@ -0,0 +1,16 @@
+/**
+ * French translation for bootstrap-datepicker
+ * Nico Mollet <nico.mollet@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['fr'] = {
+		days: ["Dimanche", "Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche"],
+		daysShort: ["Dim", "Lun", "Mar", "Mer", "Jeu", "Ven", "Sam", "Dim"],
+		daysMin: ["D", "L", "Ma", "Me", "J", "V", "S", "D"],
+		months: ["Janvier", "Février", "Mars", "Avril", "Mai", "Juin", "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre"],
+		monthsShort: ["Jan", "Fev", "Mar", "Avr", "Mai", "Jui", "Jul", "Aou", "Sep", "Oct", "Nov", "Dec"],
+		today: "Aujourd'hui",
+		weekStart: 1,
+		format: "dd/mm/yyyy"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.he.js

@@ -0,0 +1,15 @@
+/**
+ * Hebrew translation for bootstrap-datepicker
+ * Sagie Maoz <sagie@maoz.info>
+ */
+;(function($){
+  $.fn.datepicker.dates['he'] = {
+      days: ["ראשון", "שני", "שלישי", "רביעי", "חמישי", "שישי", "שבת", "ראשון"],
+      daysShort: ["א", "ב", "ג", "ד", "ה", "ו", "ש", "א"],
+      daysMin: ["א", "ב", "ג", "ד", "ה", "ו", "ש", "א"],
+      months: ["ינואר", "פברואר", "מרץ", "אפריל", "מאי", "יוני", "יולי", "אוגוסט", "ספטמבר", "אוקטובר", "נובמבר", "דצמבר"],
+      monthsShort: ["ינו", "פבר", "מרץ", "אפר", "מאי", "יונ", "יול", "אוג", "ספט", "אוק", "נוב", "דצמ"],
+      today: "היום",
+      rtl: true
+  };
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.hr.js

@@ -0,0 +1,13 @@
+/**
+ * Croatian localisation
+ */
+;(function($){
+	$.fn.datepicker.dates['hr'] = {
+		days: ["Nedjelja", "Ponedjelja", "Utorak", "Srijeda", "Četrtak", "Petak", "Subota", "Nedjelja"],
+		daysShort: ["Ned", "Pon", "Uto", "Srr", "Čet", "Pet", "Sub", "Ned"],
+		daysMin: ["Ne", "Po", "Ut", "Sr", "Če", "Pe", "Su", "Ne"],
+		months: ["Siječanj", "Veljača", "Ožujak", "Travanj", "Svibanj", "Lipanj", "Srpanj", "Kolovoz", "Rujan", "Listopad", "Studeni", "Prosinac"],
+		monthsShort: ["Sije", "Velj", "Ožu", "Tra", "Svi", "Lip", "Jul", "Kol", "Ruj", "Lis", "Stu", "Pro"],
+		today: "Danas"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.hu.js

@@ -0,0 +1,16 @@
+/**
+ * Hungarian translation for bootstrap-datepicker
+ * Sotus László <lacisan@gmail.com>
+ */
+;(function($){
+  $.fn.datepicker.dates['hu'] = {
+		days: ["Vasárnap", "Hétfő", "Kedd", "Szerda", "Csütörtök", "Péntek", "Szombat", "Vasárnap"],
+		daysShort: ["Vas", "Hét", "Ked", "Sze", "Csü", "Pén", "Szo", "Vas"],
+		daysMin: ["Va", "Hé", "Ke", "Sz", "Cs", "Pé", "Sz", "Va"],
+		months: ["Január", "Február", "Március", "Április", "Május", "Június", "Július", "Augusztus", "Szeptember", "Október", "November", "December"],
+		monthsShort: ["Jan", "Feb", "Már", "Ápr", "Máj", "Jún", "Júl", "Aug", "Sze", "Okt", "Nov", "Dec"],
+		today: "Ma",
+		weekStart: 1,
+		format: "yyyy.mm.dd"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.id.js

@@ -0,0 +1,13 @@
+/**
+ * Bahasa translation for bootstrap-datepicker
+ * Azwar Akbar <azwar.akbar@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['id'] = {
+		days: ["Minggu", "Senin", "Selasa", "Rabu", "Kamis", "Jumat", "Sabtu", "Minggu"],
+		daysShort: ["Mgu", "Sen", "Sel", "Rab", "Kam", "Jum", "Sab", "Mgu"],
+		daysMin: ["Mg", "Sn", "Sl", "Ra", "Ka", "Ju", "Sa", "Mg"],
+		months: ["Januari", "Februari", "Maret", "April", "Mei", "Juni", "Juli", "Agustus", "September", "Oktober", "November", "Desember"],
+		monthsShort: ["Jan", "Feb", "Mar", "Apr", "Mei", "Jun", "Jul", "Ags", "Sep", "Okt", "Nov", "Des"]
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.is.js

@@ -0,0 +1,14 @@
+/**
+ * Icelandic translation for bootstrap-datepicker
+ * Hinrik Örn Sigurðsson <hinrik.sig@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['is'] = {
+		days: ["Sunnudagur", "Mánudagur", "Þriðjudagur", "Miðvikudagur", "Fimmtudagur", "Föstudagur", "Laugardagur", "Sunnudagur"],
+		daysShort: ["Sun", "Mán", "Þri", "Mið", "Fim", "Fös", "Lau", "Sun"],
+		daysMin: ["Su", "Má", "Þr", "Mi", "Fi", "Fö", "La", "Su"],
+		months: ["Janúar", "Febrúar", "Mars", "Apríl", "Maí", "Júní", "Júlí", "Ágúst", "September", "Október", "Nóvember", "Desember"],
+		monthsShort: ["Jan", "Feb", "Mar", "Apr", "Maí", "Jún", "Júl", "Ágú", "Sep", "Okt", "Nóv", "Des"],
+		today: "Í Dag"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.it.js

@@ -0,0 +1,16 @@
+/**
+ * Italian translation for bootstrap-datepicker
+ * Enrico Rubboli <rubboli@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['it'] = {
+		days: ["Domenica", "Lunedì", "Martedì", "Mercoledì", "Giovedì", "Venerdì", "Sabato", "Domenica"],
+		daysShort: ["Dom", "Lun", "Mar", "Mer", "Gio", "Ven", "Sab", "Dom"],
+		daysMin: ["Do", "Lu", "Ma", "Me", "Gi", "Ve", "Sa", "Do"],
+		months: ["Gennaio", "Febbraio", "Marzo", "Aprile", "Maggio", "Giugno", "Luglio", "Agosto", "Settembre", "Ottobre", "Novembre", "Dicembre"],
+		monthsShort: ["Gen", "Feb", "Mar", "Apr", "Mag", "Giu", "Lug", "Ago", "Set", "Ott", "Nov", "Dic"],
+		today: "Oggi",
+		weekStart: 1,
+		format: "dd/mm/yyyy"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.ja.js

@@ -0,0 +1,15 @@
+/**
+ * Japanese translation for bootstrap-datepicker
+ * Norio Suzuki <https://github.com/suzuki/>
+ */
+;(function($){
+	$.fn.datepicker.dates['ja'] = {
+		days: ["日曜", "月曜", "火曜", "水曜", "木曜", "金曜", "土曜", "日曜"],
+		daysShort: ["日", "月", "火", "水", "木", "金", "土", "日"],
+		daysMin: ["日", "月", "火", "水", "木", "金", "土", "日"],
+		months: ["1月", "2月", "3月", "4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月"],
+		monthsShort: ["1月", "2月", "3月", "4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月"],
+		today: "今日",
+		format: "yyyy/mm/dd"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.kr.js

@@ -0,0 +1,13 @@
+/**
+ * Korean translation for bootstrap-datepicker
+ * Gu Youn <http://github.com/guyoun>
+ */
+;(function($){
+	$.fn.datepicker.dates['kr'] = {
+		days: ["일요일", "월요일", "화요일", "수요일", "목요일", "금요일", "토요일", "일요일"],
+		daysShort: ["일", "월", "화", "수", "목", "금", "토", "일"],
+		daysMin: ["일", "월", "화", "수", "목", "금", "토", "일"],
+		months: ["1월", "2월", "3월", "4월", "5월", "6월", "7월", "8월", "9월", "10월", "11월", "12월"],
+		monthsShort: ["1월", "2월", "3월", "4월", "5월", "6월", "7월", "8월", "9월", "10월", "11월", "12월"]
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.lt.js

@@ -0,0 +1,16 @@
+/**
+ * Lithuanian translation for bootstrap-datepicker
+ * Šarūnas Gliebus <ssharunas@yahoo.co.uk>
+ */
+
+;(function($){
+    $.fn.datepicker.dates['lt'] = {
+        days: ["Sekmadienis", "Pirmadienis", "Antradienis", "Trečiadienis", "Ketvirtadienis", "Penktadienis", "Šeštadienis", "Sekmadienis"],
+        daysShort: ["S", "Pr", "A", "T", "K", "Pn", "Š", "S"],
+        daysMin: ["Sk", "Pr", "An", "Tr", "Ke", "Pn", "Št", "Sk"],
+        months: ["Sausis", "Vasaris", "Kovas", "Balandis", "Gegužė", "Birželis", "Liepa", "Rugpjūtis", "Rugsėjis", "Spalis", "Lapkritis", "Gruodis"],
+        monthsShort: ["Sau", "Vas", "Kov", "Bal", "Geg", "Bir", "Lie", "Rugp", "Rugs", "Spa", "Lap", "Gru"],
+        today: "Šiandien",
+        weekStart: 1
+    };
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.lv.js

@@ -0,0 +1,16 @@
+/**
+ * Latvian translation for bootstrap-datepicker
+ * Artis Avotins <artis@apit.lv>
+ */
+
+;(function($){
+    $.fn.datepicker.dates['lv'] = {
+        days: ["Svētdiena", "Pirmdiena", "Otrdiena", "Trešdiena", "Ceturtdiena", "Piektdiena", "Sestdiena", "Svētdiena"],
+        daysShort: ["Sv", "P", "O", "T", "C", "Pk", "S", "Sv"],
+        daysMin: ["Sv", "Pr", "Ot", "Tr", "Ce", "Pk", "St", "Sv"],
+        months: ["Janvāris", "Februāris", "Marts", "Aprīlis", "Maijs", "Jūnijs", "Jūlijs", "Augusts", "Septembris", "Oktobris", "Novembris", "Decembris"],
+        monthsShort: ["Jan", "Feb", "Mar", "Apr", "Mai", "Jūn", "Jūl", "Aug", "Sep", "Okt", "Nov", "Dec."],
+        today: "Šodien",
+        weekStart: 1
+    };
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.ms.js

@@ -0,0 +1,14 @@
+/**
+ * Malay translation for bootstrap-datepicker
+ * Ateman Faiz <noorulfaiz@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['ms'] = {
+		days: ["Ahad", "Isnin", "Selasa", "Rabu", "Khamis", "Jumaat", "Sabtu", "Ahad"],
+		daysShort: ["Aha", "Isn", "Sel", "Rab", "Kha", "Jum", "Sab", "Aha"],
+		daysMin: ["Ah", "Is", "Se", "Ra", "Kh", "Ju", "Sa", "Ah"],
+		months: ["Januari", "Februari", "Mac", "April", "Mei", "Jun", "Julai", "Ogos", "September", "Oktober", "November", "Disember"],
+		monthsShort: ["Jan", "Feb", "Mar", "Apr", "Mei", "Jun", "Jul", "Ogo", "Sep", "Okt", "Nov", "Dis"],
+		today: "Hari Ini"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.nb.js

@@ -0,0 +1,14 @@
+/**
+ * Norwegian (bokmål) translation for bootstrap-datepicker
+ * Fredrik Sundmyhr <http://github.com/fsundmyhr>
+ */
+;(function($){
+	$.fn.datepicker.dates['nb'] = {
+		days: ["Søndag", "Mandag", "Tirsdag", "Onsdag", "Torsdag", "Fredag", "Lørdag", "Søndag"],
+		daysShort: ["Søn", "Man", "Tir", "Ons", "Tor", "Fre", "Lør", "Søn"],
+		daysMin: ["Sø", "Ma", "Ti", "On", "To", "Fr", "Lø", "Sø"],
+		months: ["Januar", "Februar", "Mars", "April", "Mai", "Juni", "Juli", "August", "September", "Oktober", "November", "Desember"],
+		monthsShort: ["Jan", "Feb", "Mar", "Apr", "Mai", "Jun", "Jul", "Aug", "Sep", "Okt", "Nov", "Des"],
+		today: "I Dag"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.nl.js

@@ -0,0 +1,14 @@
+/**
+ * Dutch translation for bootstrap-datepicker
+ * Reinier Goltstein <mrgoltstein@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['nl'] = {
+		days: ["Zondag", "Maandag", "Dinsdag", "Woensdag", "Donderdag", "Vrijdag", "Zaterdag", "Zondag"],
+		daysShort: ["Zo", "Ma", "Di", "Wo", "Do", "Vr", "Za", "Zo"],
+		daysMin: ["Zo", "Ma", "Di", "Wo", "Do", "Vr", "Za", "Zo"],
+		months: ["Januari", "Februari", "Maart", "April", "Mei", "Juni", "Juli", "Augustus", "September", "Oktober", "November", "December"],
+		monthsShort: ["Jan", "Feb", "Mrt", "Apr", "Mei", "Jun", "Jul", "Aug", "Sep", "Okt", "Nov", "Dec"],
+		today: "Vandaag"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.pl.js

@@ -0,0 +1,15 @@
+/**
+ * Polish translation for bootstrap-datepicker
+ * Robert <rtpm@gazeta.pl>
+ */
+;(function($){
+        $.fn.datepicker.dates['pl'] = {
+                days: ["Niedziela", "Poniedziałek", "Wtorek", "Środa", "Czwartek", "Piątek", "Sobota", "Niedziela"],
+                daysShort: ["Nie", "Pn", "Wt", "Śr", "Czw", "Pt", "So", "Nie"],
+                daysMin: ["N", "Pn", "Wt", "Śr", "Cz", "Pt", "So", "N"],
+                months: ["Styczeń", "Luty", "Marzec", "Kwiecień", "Maj", "Czerwiec", "Lipiec", "Sierpień", "Wrzesień", "Październik", "Listopad", "Grudzień"],
+                monthsShort: ["Sty", "Lu", "Mar", "Kw", "Maj", "Cze", "Lip", "Sie", "Wrz", "Pa", "Lis", "Gru"],
+                today: "Dzisiaj",
+                weekStart: 1
+        };
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.pt-BR.js

@@ -0,0 +1,14 @@
+/**
+ * Brazilian translation for bootstrap-datepicker
+ * Cauan Cabral <cauan@radig.com.br>
+ */
+;(function($){
+	$.fn.datepicker.dates['pt-BR'] = {
+		days: ["Domingo", "Segunda", "Terça", "Quarta", "Quinta", "Sexta", "Sábado", "Domingo"],
+		daysShort: ["Dom", "Seg", "Ter", "Qua", "Qui", "Sex", "Sáb", "Dom"],
+		daysMin: ["Do", "Se", "Te", "Qu", "Qu", "Se", "Sa", "Do"],
+		months: ["Janeiro", "Fevereiro", "Março", "Abril", "Maio", "Junho", "Julho", "Agosto", "Setembro", "Outubro", "Novembro", "Dezembro"],
+		monthsShort: ["Jan", "Fev", "Mar", "Abr", "Mai", "Jun", "Jul", "Ago", "Set", "Out", "Nov", "Dez"],
+		today: "Hoje"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.pt.js

@@ -0,0 +1,14 @@
+/**
+ * Portuguese translation for bootstrap-datepicker
+ * Original code: Cauan Cabral <cauan@radig.com.br>
+ * Tiago Melo <tiago.blackcode@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['pt'] = {
+		days: ["Domingo", "Segunda", "Terça", "Quarta", "Quinta", "Sexta", "Sábado", "Domingo"],
+		daysShort: ["Dom", "Seg", "Ter", "Qua", "Qui", "Sex", "Sáb", "Dom"],
+		daysMin: ["Do", "Se", "Te", "Qu", "Qu", "Se", "Sa", "Do"],
+		months: ["Janeiro", "Fevereiro", "Março", "Abril", "Maio", "Junho", "Julho", "Agosto", "Setembro", "Outubro", "Novembro", "Dezembro"],
+		monthsShort: ["Jan", "Fev", "Mar", "Abr", "Mai", "Jun", "Jul", "Ago", "Set", "Out", "Nov", "Dez"]
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.ro.js

@@ -0,0 +1,15 @@
+/**
+ * Romanian translation for bootstrap-datepicker
+ * Cristian Vasile <cristi.mie@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['ro'] = {
+		days: ["Duminică", "Luni", "Marţi", "Miercuri", "Joi", "Vineri", "Sâmbătă", "Duminică"],
+		daysShort: ["Dum", "Lun", "Mar", "Mie", "Joi", "Vin", "Sâm", "Dum"],
+		daysMin: ["Du", "Lu", "Ma", "Mi", "Jo", "Vi", "Sâ", "Du"],
+		months: ["Ianuarie", "Februarie", "Martie", "Aprilie", "Mai", "Iunie", "Iulie", "August", "Septembrie", "Octombrie", "Noiembrie", "Decembrie"],
+		monthsShort: ["Ian", "Feb", "Mar", "Apr", "Mai", "Iun", "Iul", "Aug", "Sep", "Oct", "Nov", "Dec"],
+		today: "Astăzi",
+		weekStart: 1
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.rs-latin.js

@@ -0,0 +1,14 @@
+/**
+ * Serbian latin translation for bootstrap-datepicker
+ * Bojan Milosavlević <milboj@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['rs'] = {
+		days: ["Nedelja","Ponedeljak", "Utorak", "Sreda", "Četvrtak", "Petak", "Subota", "Nedelja"],
+		daysShort: ["Ned", "Pon", "Uto", "Sre", "Čet", "Pet", "Sub", "Ned"],
+		daysMin: ["N", "Po", "U", "Sr", "Č", "Pe", "Su", "N"],
+		months: ["Januar", "Februar", "Mart", "April", "Maj", "Jun", "Jul", "Avgust", "Septembar", "Oktobar", "Novembar", "Decembar"],
+		monthsShort: ["Jan", "Feb", "Mar", "Apr", "Maj", "Jun", "Jul", "Avg", "Sep", "Okt", "Nov", "Dec"],
+		today: "Danas"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.rs.js

@@ -0,0 +1,14 @@
+/**
+ * Serbian cyrillic translation for bootstrap-datepicker
+ * Bojan Milosavlević <milboj@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['rs'] = {
+		days: ["Недеља","Понедељак", "Уторак", "Среда", "Четвртак", "Петак", "Субота", "Недеља"],
+		daysShort: ["Нед", "Пон", "Уто", "Сре", "Чет", "Пет", "Суб", "Нед"],
+		daysMin: ["Н", "По", "У", "Ср", "Ч", "Пе", "Су", "Н"],
+		months: ["Јануар", "Фебруар", "Март", "Април", "Мај", "Јун", "Јул", "Август", "Септембар", "Октобар", "Новембар", "Децембар"],
+		monthsShort: ["Јан", "Феб", "Мар", "Апр", "Мај", "Јун", "Јул", "Авг", "Сеп", "Окт", "Нов", "Дец"],
+		today: "Данас"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.ru.js

@@ -0,0 +1,14 @@
+/**
+ * Russian translation for bootstrap-datepicker
+ * Victor Taranenko <darwin@snowdale.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['ru'] = {
+		days: ["Воскресенье", "Понедельник", "Вторник", "Среда", "Четверг", "Пятница", "Суббота", "Воскресенье"],
+		daysShort: ["Вск", "Пнд", "Втр", "Срд", "Чтв", "Птн", "Суб", "Вск"],
+		daysMin: ["Вс", "Пн", "Вт", "Ср", "Чт", "Пт", "Сб", "Вс"],
+		months: ["Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь"],
+		monthsShort: ["Янв", "Фев", "Мар", "Апр", "Май", "Июн", "Июл", "Авг", "Сен", "Окт", "Ноя", "Дек"],
+		today: "Сегодня"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.sk.js

@@ -0,0 +1,15 @@
+/**
+ * Slovak translation for bootstrap-datepicker
+ * Marek Lichtner <marek@licht.sk>
+ * Fixes by Michal Remiš <michal.remis@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates["sk"] = {
+		days: ["Nedeľa", "Pondelok", "Utorok", "Streda", "Štvrtok", "Piatok", "Sobota", "Nedeľa"],
+		daysShort: ["Ned", "Pon", "Uto", "Str", "Štv", "Pia", "Sob", "Ned"],
+		daysMin: ["Ne", "Po", "Ut", "St", "Št", "Pia", "So", "Ne"],
+		months: ["Január", "Február", "Marec", "Apríl", "Máj", "Jún", "Júl", "August", "September", "Október", "November", "December"],
+		monthsShort: ["Jan", "Feb", "Mar", "Apr", "Máj", "Jún", "Júl", "Aug", "Sep", "Okt", "Nov", "Dec"],
+		today: "Dnes"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.sl.js

@@ -0,0 +1,14 @@
+/**
+ * Slovene translation for bootstrap-datepicker
+ * Gregor Rudolf <gregor.rudolf@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['sl'] = {
+		days: ["Nedelja", "Ponedeljek", "Torek", "Sreda", "Četrtek", "Petek", "Sobota", "Nedelja"],
+		daysShort: ["Ned", "Pon", "Tor", "Sre", "Čet", "Pet", "Sob", "Ned"],
+		daysMin: ["Ne", "Po", "To", "Sr", "Če", "Pe", "So", "Ne"],
+		months: ["Januar", "Februar", "Marec", "April", "Maj", "Junij", "Julij", "Avgust", "September", "Oktober", "November", "December"],
+		monthsShort: ["Jan", "Feb", "Mar", "Apr", "Maj", "Jun", "Jul", "Avg", "Sep", "Okt", "Nov", "Dec"],
+		today: "Danes"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.sv.js

@@ -0,0 +1,14 @@
+/**
+ * Swedish translation for bootstrap-datepicker
+ * Patrik Ragnarsson <patrik@starkast.net>
+ */
+;(function($){
+	$.fn.datepicker.dates['sv'] = {
+		days: ["Söndag", "Måndag", "Tisdag", "Onsdag", "Torsdag", "Fredag", "Lördag", "Söndag"],
+		daysShort: ["Sön", "Mån", "Tis", "Ons", "Tor", "Fre", "Lör", "Sön"],
+		daysMin: ["Sö", "Må", "Ti", "On", "To", "Fr", "Lö", "Sö"],
+		months: ["Januari", "Februari", "Mars", "April", "Maj", "Juni", "Juli", "Augusti", "September", "Oktober", "November", "December"],
+		monthsShort: ["Jan", "Feb", "Mar", "Apr", "Maj", "Jun", "Jul", "Aug", "Sep", "Okt", "Nov", "Dec"],
+		today: "I Dag"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.sw.js

@@ -0,0 +1,15 @@
+/**
+ * Swahili translation for bootstrap-datepicker
+ * Edwin Mugendi <https://github.com/edwinmugendi>
+ * Source: http://scriptsource.org/cms/scripts/page.php?item_id=entry_detail&uid=xnfaqyzcku
+ */
+;(function($){
+    $.fn.datepicker.dates['sw'] = {
+        days: ["Jumapili", "Jumatatu", "Jumanne", "Jumatano", "Alhamisi", "Ijumaa", "Jumamosi", "Jumapili"],
+        daysShort: ["J2", "J3", "J4", "J5", "Alh", "Ij", "J1", "J2"],
+        daysMin: ["2", "3", "4", "5", "A", "I", "1", "2"],
+        months: ["Januari", "Februari", "Machi", "Aprili", "Mei", "Juni", "Julai", "Agosti", "Septemba", "Oktoba", "Novemba", "Desemba"],
+        monthsShort: ["Jan", "Feb", "Mac", "Apr", "Mei", "Jun", "Jul", "Ago", "Sep", "Okt", "Nov", "Des"],
+        today: "Leo"
+    };
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.th.js

@@ -0,0 +1,14 @@
+/**
+ * Thai translation for bootstrap-datepicker
+ * Suchau Jiraprapot <seroz24@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['th'] = {
+		days: ["อาทิตย์", "จันทร์", "อังคาร", "พุธ", "พฤหัส", "ศุกร์", "เสาร์", "อาทิตย์"],
+		daysShort: ["อา", "จ", "อ", "พ", "พฤ", "ศ", "ส", "อา"],
+		daysMin: ["อา", "จ", "อ", "พ", "พฤ", "ศ", "ส", "อา"],
+		months: ["มกราคม", "กุมภาพันธ์", "มีนาคม", "เมษายน", "พฤษภาคม", "มิถุนายน", "กรกฎาคม", "สิงหาคม", "กันยายน", "ตุลาคม", "พฤศจิกายน", "ธันวาคม"],
+		monthsShort: ["ม.ค.", "ก.พ.", "มี.ค.", "เม.ย.", "พ.ค.", "มิ.ย.", "ก.ค.", "ส.ค.", "ก.ย.", "ต.ค.", "พ.ย.", "ธ.ค."],
+		today: "วันนี้"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.tr.js

@@ -0,0 +1,15 @@
+/**
+ * Turkish translation for bootstrap-datepicker
+ * Serkan Algur <kaisercrazy_2@hotmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['tr'] = {
+		days: ["Pazar", "Pazartesi", "Salı", "Çarşamba", "Perşembe", "Cuma", "Cumartesi", "Pazar"],
+		daysShort: ["Pz", "Pzt", "Sal", "Çrş", "Prş", "Cu", "Cts", "Pz"],
+		daysMin: ["Pz", "Pzt", "Sa", "Çr", "Pr", "Cu", "Ct", "Pz"],
+		months: ["Ocak", "Şubat", "Mart", "Nisan", "Mayıs", "Haziran", "Temmuz", "Ağustos", "Eylül", "Ekim", "Kasım", "Aralık"],
+		monthsShort: ["Oca", "Şub", "Mar", "Nis", "May", "Haz", "Tem", "Ağu", "Eyl", "Eki", "Kas", "Ara"],
+		today: "Bugün"
+	};
+}(jQuery));
+

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.uk.js

@@ -0,0 +1,14 @@
+/**
+ * Ukrainian translation for bootstrap-datepicker
+ * Andrey Vityuk <andrey [dot] vityuk [at] gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['uk'] = {
+		days: ["Неділя", "Понеділок", "Вівторок", "Середа", "Четвер", "П'ятниця", "Субота", "Неділя"],
+		daysShort: ["Нед", "Пнд", "Втр", "Срд", "Чтв", "Птн", "Суб", "Нед"],
+		daysMin: ["Нд", "Пн", "Вт", "Ср", "Чт", "Пт", "Сб", "Нд"],
+		months: ["Січень", "Лютий", "Березень", "Квітень", "Травень", "Червень", "Липень", "Серпень", "Вересень", "Жовтень", "Листопад", "Грудень"],
+		monthsShort: ["Січ", "Лют", "Бер", "Кві", "Тра", "Чер", "Лип", "Сер", "Вер", "Жов", "Лис", "Гру"],
+		today: "Сьогодні"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.zh-CN.js

@@ -0,0 +1,14 @@
+/**
+ * Simplified Chinese translation for bootstrap-datepicker
+ * Yuan Cheung <advanimal@gmail.com>
+ */
+;(function($){
+	$.fn.datepicker.dates['zh-CN'] = {
+				days: ["星期日", "星期一", "星期二", "星期三", "星期四", "星期五", "星期六", "星期日"],
+			daysShort: ["周日", "周一", "周二", "周三", "周四", "周五", "周六", "周日"],
+			daysMin:  ["日", "一", "二", "三", "四", "五", "六", "日"],
+			months: ["一月", "二月", "三月", "四月", "五月", "六月", "七月", "八月", "九月", "十月", "十一月", "十二月"],
+			monthsShort: ["一月", "二月", "三月", "四月", "五月", "六月", "七月", "八月", "九月", "十月", "十一月", "十二月"],
+			today: "今日"
+	};
+}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.zh-TW.js

@@ -0,0 +1,13 @@
+/**
+ * Traditional Chinese translation for bootstrap-datepicker
+ * Rung-Sheng Jang <daniel@i-trend.co.cc>
+ */
+;(function($){
+	$.fn.datepicker.dates['zh-TW'] = {
+				days: ["星期日", "星期一", "星期二", "星期三", "星期四", "星期五", "星期六", "星期日"],
+			daysShort: ["周日", "周一", "周二", "周三", "周四", "周五", "周六", "周日"],
+			daysMin:  ["日", "一", "二", "三", "四", "五", "六", "日"],
+			months: ["一月", "二月", "三月", "四月", "五月", "六月", "七月", "八月", "九月", "十月", "十一月", "十二月"],
+			monthsShort: ["一月", "二月", "三月", "四月", "五月", "六月", "七月", "八月", "九月", "十月", "十一月", "十二月"]
+	};
+}(jQuery));

inst/www/shared/datepicker/less/datepicker.less

@@ -0,0 +1,230 @@
+/*!
+ * Datepicker for Bootstrap
+ *
+ * Copyright 2012 Stefan Petre
+ * Improvements by Andrew Rowls
+ * Licensed under the Apache License v2.0
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ */
+
+.datepicker {
+	padding: 4px;
+	.border-radius(4px);
+	&-inline {
+		width: 220px;
+	}
+	direction: ltr;
+	&&-rtl {
+		direction: rtl;
+		table tr td span {
+			float: right;
+		}
+	}
+	&-dropdown {
+		top: 0;
+		left: 0;
+		&:before {
+			content: '';
+			display: inline-block;
+			border-left:   7px solid transparent;
+			border-right:  7px solid transparent;
+			border-bottom: 7px solid #ccc;
+			border-bottom-color: rgba(0,0,0,.2);
+			position: absolute;
+			top: -7px;
+			left: 6px;
+		}
+		&:after {
+			content: '';
+			display: inline-block;
+			border-left:   6px solid transparent;
+			border-right:  6px solid transparent;
+			border-bottom: 6px solid @white;
+			position: absolute;
+			top: -6px;
+			left: 7px;
+		}
+	}
+	>div {
+		display: none;
+	}
+	&.days div.datepicker-days {
+		display: block;
+	}
+	&.months div.datepicker-months {
+		display: block;
+	}
+	&.years div.datepicker-years {
+		display: block;
+	}
+	table{
+		margin: 0;
+	}
+	td,
+	th{
+		text-align: center;
+		width: 20px;
+		height: 20px;
+		.border-radius(4px);
+
+		border: none;
+	}
+	// Inline display inside a table presents some problems with
+	// border and background colors.
+	.table-striped & table tr {
+		td, th {
+			background-color:transparent;
+		}
+	}
+	table tr td {
+		&.day:hover {
+			background: @grayLighter;
+			cursor: pointer;
+		}
+		&.old,
+		&.new {
+			color: @grayLight;
+		}
+		&.disabled,
+		&.disabled:hover {
+			background: none;
+			color: @grayLight;
+			cursor: default;
+		}
+		&.today,
+		&.today:hover,
+		&.today.disabled,
+		&.today.disabled:hover {
+			@todayBackground: lighten(@orange, 30%);
+			.buttonBackground(@todayBackground, spin(@todayBackground, 20));
+			color: #000 !important;
+		}
+		&.range,
+		&.range:hover,
+		&.range.disabled,
+		&.range.disabled:hover {
+			background:@grayLighter;
+			.border-radius(0);
+		}
+		&.range.today,
+		&.range.today:hover,
+		&.range.today.disabled,
+		&.range.today.disabled:hover {
+			@todayBackground: mix(@orange, @grayLighter);
+			.buttonBackground(@todayBackground, spin(@todayBackground, 20));
+			.border-radius(0);
+		}
+		&.selected,
+		&.selected:hover,
+		&.selected.disabled,
+		&.selected.disabled:hover {
+			.buttonBackground(lighten(@grayLight, 10), darken(@grayLight, 10));
+			color: #fff;
+			text-shadow: 0 -1px 0 rgba(0,0,0,.25);
+		}
+		&.active,
+		&.active:hover,
+		&.active.disabled,
+		&.active.disabled:hover {
+			.buttonBackground(@btnPrimaryBackground, spin(@btnPrimaryBackground, 20));
+			color: #fff;
+			text-shadow: 0 -1px 0 rgba(0,0,0,.25);
+		}
+		span {
+			display: block;
+			width: 23%;
+			height: 54px;
+			line-height: 54px;
+			float: left;
+			margin: 1%;
+			cursor: pointer;
+			.border-radius(4px);
+			&:hover {
+				background: @grayLighter;
+			}
+			&.disabled,
+			&.disabled:hover {
+				background:none;
+				color: @grayLight;
+				cursor: default;
+			}
+			&.active,
+			&.active:hover,
+			&.active.disabled,
+			&.active.disabled:hover {
+				.buttonBackground(@btnPrimaryBackground, spin(@btnPrimaryBackground, 20));
+				color: #fff;
+				text-shadow: 0 -1px 0 rgba(0,0,0,.25);
+			}
+			&.old {
+				color: @grayLight;
+			}
+		}
+	}
+
+	th.datepicker-switch {
+		width: 145px;
+	}
+
+	thead tr:first-child th,
+	tfoot tr:first-child th {
+		cursor: pointer;
+		&:hover{
+			background: @grayLighter;
+		}
+	}
+	/*.dow {
+		border-top: 1px solid #ddd !important;
+	}*/
+
+	// Basic styling for calendar-week cells
+	.cw {
+		font-size: 10px;
+		width: 12px;
+		padding: 0 2px 0 5px;
+		vertical-align: middle;
+	}
+	thead tr:first-child th.cw {
+		cursor: default;
+		background-color: transparent;
+	}
+}
+.input-append,
+.input-prepend {
+	&.date {
+		.add-on i {
+			display: block;
+			cursor: pointer;
+			width: 16px;
+			height: 16px;
+		}
+	}
+}
+.input-daterange {
+	input {
+		text-align:center;
+	}
+	input:first-child {
+		.border-radius(3px 0 0 3px);
+	}
+	input:last-child {
+		.border-radius(0 3px 3px 0);
+	}
+	.add-on {
+		display: inline-block;
+		width: auto;
+		min-width: 16px;
+		height: @baseLineHeight;
+		padding: 4px 5px;
+		font-weight: normal;
+		line-height: @baseLineHeight;
+		text-align: center;
+		text-shadow: 0 1px 0 @white;
+		vertical-align: middle;
+		background-color: @grayLighter;
+		border: 1px solid #ccc;
+		margin-left:-5px;
+		margin-right:-5px;
+	}
+}

inst/www/shared/shiny.css

@@ -14,6 +14,10 @@ table.data td[align=right] {
 .shiny-output-error {
   color: red;
 }
+.shiny-output-error:before {
+  content: 'Error: ';
+  font-weight: bold;
+}
 
 .jslider {
   /* Fix jslider running into the control above it */
@@ -54,3 +58,27 @@ span.jslider {
 .slider-animate-button.playing .play {
   display: none;
 }
+
+.progress.shiny-file-input-progress {
+  position: relative;
+  visibility: hidden;
+}
+.progress.shiny-file-input-progress .bar {
+  overflow: hidden;
+}
+.progress.shiny-file-input-progress label {
+  display: block;
+  position: absolute;
+  left: 0;
+  top: 0;
+  right: 0;
+  bottom: 0;
+  font-size: 12px;
+  padding: 0 6px;
+}
+.progress.shiny-file-input-progress .bar.bar-danger {
+  -webkit-transition: none;
+  -moz-transition: none;
+  -o-transition: none;
+  transition: none;
+}