Restore HTML generating functions

These functions were temporarily ripped out of Shiny and moved
to the htmltools package. We've discovered that it's safe to
keep including them in shiny; as long as the functions in shiny
and the functions in htmltools are identical, the user won't
receive a conflict warning.

.Rbuildignore

@@ -7,7 +7,7 @@
 ^run\.R$
 ^\.gitignore$
 ^res$
-^tools$
 ^man-roxygen$
 ^\.travis\.yml$
 ^staticdocs$
+^tools$

.Rinstignore

@@ -0,0 +1,2 @@
+^tools$
+^Rmd$

.travis.yml

@@ -13,7 +13,8 @@ install:
   - sudo apt-get update
   - sudo apt-get install r-base-dev r-cran-shiny r-cran-cairo r-cran-markdown
   - "[ ! -d ~/R ] && mkdir ~/R"
-  - Rscript -e "install.packages('xtable', repos = 'http://cran.rstudio.org')"
+  - Rscript -e "install.packages(c('xtable'), repos = 'http://cran.rstudio.org')"
+  - Rscript -e "install.packages('knitr', repos = c('http://rforge.net', 'http://cran.rstudio.org'))"
   - Rscript -e "install.packages('$R_MY_PKG', dep = TRUE, repos = 'http://cran.rstudio.org')"
 
 # run tests

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.9.1
+Version: 0.9.1.9008
 Date: 2014-03-19
 Author: RStudio, Inc.
 Maintainer: Winston Chang <winston@rstudio.com>
@@ -14,43 +14,51 @@ Depends:
     R (>= 2.14.1),
     methods
 Imports:
-    stats,
     tools,
     utils,
     httpuv (>= 1.2.0),
     caTools,
     RJSONIO,
     xtable,
-    digest
+    digest,
+    htmltools (>= 0.2.4)
 Suggests:
     datasets,
-    markdown,
     Cairo (>= 1.5-5),
-    testthat
+    testthat,
+    knitr (>= 1.6),
+    markdown
 URL: http://www.rstudio.com/shiny/
 BugReports: https://github.com/rstudio/shiny/issues
+Roxygen: list(wrap = FALSE)
 Collate:
+    'app.R'
     'bootstrap-layout.R'
+    'map.R'
+    'globals.R'
+    'utils.R'
     'bootstrap.R'
     'cache.R'
-    'map.R'
     'fileupload.R'
     'graph.R'
     'hooks.R'
+    'html-deps.R'
+    'htmltools.R'
     'imageutils.R'
     'jqueryui.R'
+    'middleware-shiny.R'
+    'middleware.R'
     'priorityqueue.R'
     'react.R'
+    'reactive-domains.R'
     'reactives.R'
     'run-url.R'
-    'sessioncontext.R'
-    'utils.R'
+    'server.R'
     'shiny.R'
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
     'slider.R'
-    'tags.R'
     'tar.R'
     'timer.R'
     'update-input.R'

NAMESPACE

@@ -1,4 +1,4 @@
-# Generated by roxygen2 (4.0.0): do not edit by hand
+# Generated by roxygen2 (4.0.1): do not edit by hand
 
 S3method("$",reactivevalues)
 S3method("$",shinyoutput)
@@ -13,23 +13,23 @@ 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,html)
-S3method(format,shiny.tag)
-S3method(format,shiny.tag.list)
+S3method(as.shiny.appobj,character)
+S3method(as.shiny.appobj,list)
+S3method(as.shiny.appobj,shiny.appobj)
+S3method(as.tags,shiny.render.function)
 S3method(names,reactivevalues)
-S3method(print,html)
 S3method(print,reactive)
-S3method(print,shiny.tag)
-S3method(print,shiny.tag.list)
+S3method(print,shiny.appobj)
+S3method(str,reactivevalues)
 export(HTML)
 export(a)
 export(absolutePanel)
 export(actionButton)
+export(actionLink)
 export(addResourcePath)
 export(animationOptions)
+export(as.shiny.appobj)
 export(basicPage)
 export(bootstrapPage)
 export(br)
@@ -51,8 +51,10 @@ export(fileInput)
 export(fixedPage)
 export(fixedPanel)
 export(fixedRow)
+export(flowLayout)
 export(fluidPage)
 export(fluidRow)
+export(getDefaultReactiveDomain)
 export(h1)
 export(h2)
 export(h3)
@@ -71,18 +73,26 @@ export(includeHTML)
 export(includeMarkdown)
 export(includeScript)
 export(includeText)
+export(inputPanel)
 export(installExprFunction)
 export(invalidateLater)
 export(is.reactive)
 export(is.reactivevalues)
+export(is.singleton)
 export(isolate)
+export(knit_print.shiny.appobj)
+export(knit_print.shiny.render.function)
 export(mainPanel)
 export(makeReactiveBinding)
+export(markRenderFunction)
+export(maskReactiveContext)
 export(navbarMenu)
 export(navbarPage)
 export(navlistPanel)
+export(need)
 export(numericInput)
 export(observe)
+export(onReactiveDomainEnded)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
@@ -119,6 +129,8 @@ export(runGitHub)
 export(runUrl)
 export(selectInput)
 export(selectizeInput)
+export(shinyApp)
+export(shinyAppDir)
 export(shinyServer)
 export(shinyUI)
 export(showReactLog)
@@ -127,6 +139,7 @@ export(sidebarPanel)
 export(singleton)
 export(sliderInput)
 export(span)
+export(splitLayout)
 export(stopApp)
 export(strong)
 export(submitButton)
@@ -151,18 +164,22 @@ export(updateDateRangeInput)
 export(updateNumericInput)
 export(updateRadioButtons)
 export(updateSelectInput)
+export(updateSelectizeInput)
 export(updateSliderInput)
 export(updateTabsetPanel)
 export(updateTextInput)
+export(validate)
 export(validateCssUnit)
 export(verbatimTextOutput)
 export(verticalLayout)
 export(wellPanel)
 export(withMathJax)
+export(withReactiveDomain)
 export(withTags)
 import(RJSONIO)
 import(caTools)
 import(digest)
+import(htmltools)
 import(httpuv)
 import(methods)
 import(xtable)

NEWS

@@ -1,3 +1,41 @@
+shiny 0.9.1.9XXX
+--------------------------------------------------------------------------------
+
+* BREAKING CHANGE: By default, observers now terminate themselves if they were
+  created during a session and that session ends. See ?domains for more details.
+
+* Most inputs can now accept `NULL` label values to omit the label altogether.
+
+* New `actionLink` input control; like `actionButton`, but with the appearance
+  of a normal link.
+
+* `renderPlot` now calls `print` on its result if it's visible (i.e. no more
+  explicit `print()` required for ggplot2).
+
+* Added `maskReactiveContext` function. It blocks the current reactive context,
+  to evaluate expressions that shouldn't use reactive sources directly. (This
+  should not be commonly needed.)
+
+* Added `flowLayout`, `splitLayout`, and `inputPanel` functions for putting UI
+  elements side by side. `flowPanel` lays out its children in a left-to-right,
+  top-to-bottom arrangement. `splitLayout` evenly divides its horizontal space
+  among its children (or unevenly divides if `cellWidths` argument is provided).
+  `inputPanel` is like `flowPanel`, but with a light grey background, and is
+  intended to be used to encapsulate small input controls wherever vertical
+  space is at a premium.
+
+* `sliderInput` and `selectizeInput`/`selectInput` now use a standard horizontal
+  size instead of filling up all available horizontal space.
+
+* Fixed a bug of renderDataTable() when the data object only has 1 row and 1
+  column. (Thanks, ZJ Dai, #429)
+
+* `renderPrint` gained a new argument 'width' to control the width of the text
+  output, e.g. renderPrint({mtcars}, width = 40).
+
+* Fixed #220: the zip file for a directory created by some programs may not have
+  the directory name as its first entry, in which case runUrl() can fail. (#220)
+
 shiny 0.9.1
 --------------------------------------------------------------------------------
 

R/app.R

@@ -0,0 +1,288 @@
+# TODO: Subapp global.R
+
+#' Create a Shiny app object
+#'
+#' These functions create Shiny app objects from either an explicit UI/server
+#' pair (\code{shinyApp}), or by passing the path of a directory that
+#' contains a Shiny app (\code{shinyAppDir}). You generally shouldn't need to
+#' use these functions to create/run applications; they are intended for
+#' interoperability purposes, such as embedding Shiny apps inside a \pkg{knitr}
+#' document.
+#'
+#' @param ui The UI definition of the app (for example, a call to
+#'   \code{fluidPage()} with nested controls)
+#' @param server A server function
+#' @param onStart A function that will be called before the app is actually run.
+#'   This is only needed for \code{shinyAppObj}, since in the \code{shinyAppDir}
+#'   case, a \code{global.R} file can be used for this purpose.
+#' @param options Named options that should be passed to the `runApp` call. You
+#'   can also specify \code{width} and \code{height} parameters which provide a
+#'   hint to the embedding environment about the ideal height/width for the app.
+#' @param uiPattern A regular expression that will be applied to each \code{GET}
+#'   request to determine whether the \code{ui} should be used to handle the
+#'   request. Note that the entire request path must match the regular
+#'   expression in order for the match to be considered successful.
+#' @return An object that represents the app. Printing the object will run the
+#'   app.
+#'
+#' @examples
+#' \dontrun{
+#' shinyApp(
+#'   ui = fluidPage(
+#'     numericInput("n", "n", 1),
+#'     plotOutput("plot")
+#'   ),
+#'   server = function(input, output) {
+#'     output$plot <- renderPlot( plot(head(cars, input$n)) )
+#'   },
+#'   options=list(launch.browser = rstudio::viewer)
+#' )
+#'
+#' shinyAppDir(system.file("examples/01_hello", package="shiny"))
+#' }
+#'
+#' @export
+shinyApp <- function(ui, server, onStart=NULL, options=list(), uiPattern="/") {
+  # Ensure that the entire path is a match
+  uiPattern <- sprintf("^%s$", uiPattern)
+
+  httpHandler <- function(req) {
+    if (!identical(req$REQUEST_METHOD, 'GET'))
+      return(NULL)
+
+    if (!isTRUE(grepl(uiPattern, req$PATH_INFO)))
+      return(NULL)
+
+    textConn <- textConnection(NULL, "w")
+    on.exit(close(textConn))
+
+    uiValue <- if (is.function(ui)) {
+      if (length(formals(ui)) > 0)
+        ui(req)
+      else
+        ui()
+    } else {
+      ui
+    }
+    if (is.null(uiValue))
+      return(NULL)
+
+    renderPage(uiValue, textConn)
+    html <- paste(textConnectionValue(textConn), collapse='\n')
+    return(httpResponse(200, content=html))
+  }
+
+  serverFuncSource <- function() {
+    server
+  }
+
+  structure(
+    list(
+      httpHandler = httpHandler,
+      serverFuncSource = serverFuncSource,
+      onStart = onStart,
+      options = options),
+    class = "shiny.appobj"
+  )
+}
+
+#' @rdname shinyApp
+#' @param appDir Path to directory that contains a Shiny app (i.e. a server.R
+#'   file and either ui.R or www/index.html)
+#' @export
+shinyAppDir <- function(appDir, options=list()) {
+  # Most of the complexity here comes from needing to hot-reload if the .R files
+  # change on disk, or are created, or are removed.
+
+  if (!file.exists(appDir)) {
+    stop("No Shiny application exists at the path \"", appDir, "\"")
+  }
+
+  # In case it's a relative path, convert to absolute (so we're not adversely
+  # affected by future changes to the path)
+  appDir <- normalizePath(appDir, mustWork = TRUE)
+
+  # uiHandlerSource is a function that returns an HTTP handler for serving up
+  # ui.R as a webpage. The "cachedFuncWithFile" call makes sure that the closure
+  # we're creating here only gets executed when ui.R's contents change.
+  uiHandlerSource <- cachedFuncWithFile(appDir, "ui.R", case.sensitive = FALSE,
+    function(uiR) {
+      if (file.exists(uiR)) {
+        # If ui.R contains a call to shinyUI (which sets .globals$ui), use that.
+        # If not, then take the last expression that's returned from ui.R.
+        .globals$ui <- NULL
+        on.exit(.globals$ui <- NULL, add = FALSE)
+        ui <- source(uiR,
+          local = new.env(parent = globalenv()),
+          keep.source = TRUE)$value
+        if (!is.null(.globals$ui)) {
+          ui <- .globals$ui[[1]]
+        }
+        return(uiHttpHandler(ui))
+      } else {
+        return(function(req) NULL)
+      }
+    }
+  )
+  uiHandler <- function(req) {
+    uiHandlerSource()(req)
+  }
+
+  wwwDir <- file.path.ci(appDir, "www")
+  fallbackWWWDir <- system.file("www-dir", package = "shiny")
+  serverSource <- cachedFuncWithFile(appDir, "server.R", case.sensitive = FALSE,
+    function(serverR) {
+      # If server.R contains a call to shinyServer (which sets .globals$server),
+      # use that. If not, then take the last expression that's returned from
+      # server.R.
+      .globals$server <- NULL
+      on.exit(.globals$server <- NULL, add = TRUE)
+      result <- source(
+        serverR,
+        local = new.env(parent = globalenv()),
+        keep.source = TRUE
+      )$value
+      if (!is.null(.globals$server)) {
+        result <- .globals$server[[1]]
+      }
+      return(result)
+    }
+  )
+
+  # This function stands in for the server function, and reloads the
+  # real server function as necessary whenever server.R changes
+  serverFuncSource <- function() {
+    serverFunction <- serverSource()
+    if (is.null(serverFunction)) {
+      return(function(input, output) NULL)
+    } else if (is.function(serverFunction)) {
+      # This is what we normally expect; run the server function
+      return(serverFunction)
+    } else {
+      stop("server.R returned an object of unexpected type: ",
+        typeof(serverFunction))
+    }
+  }
+
+  oldwd <- NULL
+  onStart <- function() {
+    oldwd <<- getwd()
+    setwd(appDir)
+    if (file.exists(file.path.ci(appDir, "global.R")))
+      source(file.path.ci(appDir, "global.R"), keep.source = TRUE)
+  }
+  onEnd <- function() {
+    setwd(oldwd)
+  }
+
+  structure(
+    list(
+      httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)),
+      serverFuncSource = serverFuncSource,
+      onStart = onStart,
+      onEnd = onEnd,
+      options = options),
+    class = "shiny.appobj"
+  )
+}
+
+#' @rdname shinyApp
+#' @param x Object to convert to a Shiny app.
+#' @export
+as.shiny.appobj <- function(x) {
+  UseMethod("as.shiny.appobj", x)
+}
+
+#' @rdname shinyApp
+#' @export
+as.shiny.appobj.shiny.appobj <- function(x) {
+  x
+}
+
+#' @rdname shinyApp
+#' @export
+as.shiny.appobj.list <- function(x) {
+  shinyApp(ui = x$ui, server = x$server)
+}
+
+#' @rdname shinyApp
+#' @export
+as.shiny.appobj.character <- function(x) {
+  shinyAppDir(x)
+}
+
+#' @rdname shinyApp
+#' @param ... Additional parameters to be passed to print.
+#' @export
+print.shiny.appobj <- function(x, ...) {
+  opts <- x$options %OR% list()
+  opts <- opts[names(opts) %in%
+      c("port", "launch.browser", "host", "quiet", "display.mode")]
+
+  args <- c(list(x), opts)
+
+  do.call(runApp, args)
+}
+
+#' Knitr S3 methods
+#'
+#' These S3 methods are necessary to help Shiny applications and UI chunks embed
+#' themselves in knitr/rmarkdown documents.
+#'
+#' @name knitr_methods
+#' @param x Object to knit_print
+#' @param ... Additional knit_print arguments
+NULL
+
+#' @rdname knitr_methods
+#' @export
+knit_print.shiny.appobj <- function(x, ...) {
+  opts <- x$options %OR% list()
+  width <- if (is.null(opts$width)) "100%" else opts$width
+  height <- if (is.null(opts$height)) "400" else opts$height
+  shiny_warning <- NULL
+  # if there's an R Markdown runtime option set but it isn't set to Shiny, then
+  # emit a warning indicating the runtime is inappropriate for this object
+  runtime <- knitr::opts_knit$get("rmarkdown.runtime")
+  if (!is.null(runtime) && runtime != "shiny") {
+    # note that the RStudio IDE checks for this specific string to detect Shiny
+    # applications in static document
+    shiny_warning <- list(structure(
+      "Shiny application in a static R Markdown document",
+      class = "rmd_warning"))
+
+    # create a box exactly the same dimensions as the Shiny app would have had
+    # (so the document continues to flow as it would have with the app), and
+    # display a diagnostic message
+    width <- validateCssUnit(width)
+    height <- validateCssUnit(height)
+    output <- tags$div(
+      style=paste("width:", width, "; height:", height, "; text-align: center;",
+                  "box-sizing: border-box;", "-moz-box-sizing: border-box;",
+                  "-webkit-box-sizing: border-box;"),
+      class="muted well",
+      "Shiny applications not supported in static R Markdown documents")
+  }
+  else {
+    path <- addSubApp(x)
+    output <- tags$iframe(src=path, width=width, height=height,
+                          class="shiny-frame")
+  }
+
+  # If embedded Shiny apps ever have JS/CSS dependencies (like pym.js) we'll
+  # need to grab those and put them in meta, like in knit_print.shiny.tag. But
+  # for now it's not an issue, so just return the HTML and warning.
+
+  knitr::asis_output(htmlPreserve(format(output, indent=FALSE)),
+                     meta = shiny_warning, cacheable = FALSE)
+}
+
+# Lets us use a nicer syntax in knitr chunks than literally
+# calling output$value <- renderFoo(...) and fooOutput().
+#' @rdname knitr_methods
+#' @export
+knit_print.shiny.render.function <- function(x, ...) {
+  output <- knitr::knit_print(tagList(x))
+  attr(output, "knit_cacheable") <- FALSE
+  output
+}

R/bootstrap-layout.R

@@ -276,7 +276,7 @@ sidebarLayout <- function(sidebarPanel,
     fixedRow(firstPanel, secondPanel)
 }
 
-#' Layout UI elements vertically
+#' Lay out UI elements vertically
 #'
 #' Create a container that includes one or more rows of content (each element
 #' passed to the container will appear on it's own line in the UI)
@@ -285,7 +285,7 @@ sidebarLayout <- function(sidebarPanel,
 #' @param fluid \code{TRUE} to use fluid layout; \code{FALSE} to use fixed
 #'   layout.
 #'
-#' @seealso \code{\link{fluidPage}}
+#' @seealso \code{\link{fluidPage}}, \code{\link{flowLayout}}
 #'
 #' @examples
 #' shinyUI(fluidPage(
@@ -306,5 +306,116 @@ verticalLayout <- function(..., fluid = TRUE) {
   })
 }
 
+#' Flow layout
+#'
+#' Lays out elements in a left-to-right, top-to-bottom arrangement. The elements
+#' on a given row will be top-aligned with each other. This layout will not work
+#' well with elements that have a percentage-based width (e.g. `plotOutput` at
+#' its default setting of `width = "100%"`).
+#'
+#' @param ... Unnamed arguments will become child elements of the layout. Named
+#'   arguments will become HTML attributes on the outermost tag.
+#' @param cellArgs Any additional attributes that should be used for each cell
+#'   of the layout.
+#'
+#' @seealso \code{\link{verticalLayout}}
+#'
+#' #' @examples
+#' flowLayout(
+#'   numericInput("rows", "How many rows?", 5),
+#'   selectInput("letter", "Which letter?", LETTERS),
+#'   sliderInput("value", "What value?", 0, 100, 50)
+#' )
+#' @export
+flowLayout <- function(..., cellArgs = list()) {
 
+  children <- list(...)
+  childIdx <- !nzchar(names(children) %OR% character(length(children)))
+  attribs <- children[!childIdx]
+  children <- children[childIdx]
 
+  do.call(tags$div, c(list(class = "shiny-flow-layout"),
+    attribs,
+    lapply(children, function(x) {
+      do.call(tags$div, c(cellArgs, list(x)))
+    })
+  ))
+}
+
+#' Input panel
+#'
+#' A \code{\link{flowLayout}} with a grey border and light grey background,
+#' suitable for wrapping inputs.
+#'
+#' @param ... Input controls or other HTML elements.
+#'
+#' @export
+inputPanel <- function(...) {
+  div(class = "shiny-input-panel",
+    flowLayout(...)
+  )
+}
+
+#' Split layout
+#'
+#' Lays out elements horizontally, dividing the available horizontal space into
+#' equal parts (by default).
+#'
+#' @param ... Unnamed arguments will become child elements of the layout. Named
+#'   arguments will become HTML attributes on the outermost tag.
+#' @param cellWidths Character or numeric vector indicating the widths of the
+#'   individual cells. Recycling will be used if needed. Character values will
+#'   be interpreted as CSS lengths (see \code{\link{validateCssUnit}}), numeric
+#'   values as pixels.
+#' @param cellArgs Any additional attributes that should be used for each cell
+#'   of the layout.
+#'
+#' #' @examples
+#' # Equal sizing
+#' splitLayout(
+#'   plotOutput("plot1"),
+#'   plotOutput("plot2")
+#' )
+#'
+#' # Custom widths
+#' splitLayout(cellWidths = c("25%", "75%"),
+#'   plotOutput("plot1"),
+#'   plotOutput("plot2")
+#' )
+#'
+#' # All cells at 300 pixels wide, with cell padding
+#' # and a border around everything
+#' splitLayout(
+#'   style = "border: 1px solid silver;",
+#'   cellWidths = 300,
+#'   cellArgs = list(style = "padding: 6px"),
+#'   plotOutput("plot1"),
+#'   plotOutput("plot2"),
+#'   plotOutput("plot3")
+#' )
+#' @export
+splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
+
+  children <- list(...)
+  childIdx <- !nzchar(names(children) %OR% character(length(children)))
+  attribs <- children[!childIdx]
+  children <- children[childIdx]
+  count <- length(children)
+
+  if (length(cellWidths) == 0 || is.na(cellWidths)) {
+    cellWidths <- sprintf("%.3f%%", 100 / count)
+  }
+  cellWidths <- rep(cellWidths, length.out = count)
+  cellWidths <- sapply(cellWidths, validateCssUnit)
+
+  do.call(tags$div, c(list(class = "shiny-split-layout"),
+    attribs,
+    mapply(children, cellWidths, FUN = function(x, w) {
+      do.call(tags$div, c(
+        list(style = sprintf("width: %s;", w)),
+        cellArgs,
+        list(x)
+      ))
+    }, SIMPLIFY = FALSE)
+  ))
+}

R/bootstrap.R

@@ -1,3 +1,6 @@
+#' @include utils.R
+NULL
+
 #' Create a Bootstrap page
 #'
 #' Create a Shiny UI page that loads the CSS and JavaScript for
@@ -34,43 +37,37 @@ bootstrapPage <- function(..., title = NULL, responsive = TRUE, theme = NULL) {
     }
     cssExt <- ext(".css")
     jsExt = ext(".js")
-    bs <- "shared/bootstrap/"
-
-    # apply theme if requested
-    if (is.null(theme))
-      cssHref <- paste(bs, "css/bootstrap", cssExt, sep="")
-    else
-      cssHref <- theme
-
-    result <- tags$head(
-      tags$link(rel="stylesheet", type="text/css", href=cssHref),
-      tags$script(src=paste(bs, "js/bootstrap", jsExt, sep=""))
+    bs <- c(
+      href = "shared/bootstrap",
+      file = system.file("www/shared/bootstrap", package = "shiny")
     )
 
-    if (!is.null(title))
-      result <- tagAppendChild(result, tags$title(title))
-
-    if (responsive) {
-      result <- tagAppendChild(
-        result,
-        tags$meta(name="viewport",
-                  content="width=device-width, initial-scale=1.0"))
-      result <- tagAppendChild(
-        result,
-        tags$link(rel="stylesheet",
-                  type="text/css",
-                  href=paste(bs, "css/bootstrap-responsive", cssExt, sep="")))
-    }
-
-    result
+    list(
+      htmlDependency("bootstrap", "2.3.2", bs,
+        script = sprintf("js/bootstrap%s", jsExt),
+        stylesheet = if (is.null(theme))
+          sprintf("css/bootstrap%s", cssExt)
+      ),
+      if (responsive) {
+        htmlDependency("bootstrap-responsive", "2.3.2", bs,
+          stylesheet = sprintf("css/bootstrap-responsive%s", cssExt),
+          meta = list(viewport = "width=device-width, initial-scale=1.0")
+        )
+      }
+    )
   }
 
-  tagList(
-    # inject bootstrap requirements into head
-    importBootstrap(),
+  attachDependencies(
+    tagList(
+      if (!is.null(title)) tags$head(tags$title(title)),
+      if (!is.null(theme)) {
+        tags$head(tags$link(rel="stylesheet", type="text/css", href = theme))
+      },
 
-    # remainder of tags passed to the function
-    list(...)
+      # remainder of tags passed to the function
+      list(...)
+    ),
+    importBootstrap()
   )
 }
 
@@ -213,7 +210,7 @@ navbarPage <- function(title,
 
   # built the container div dynamically to support optional collapsability
   if (collapsable) {
-    navId <- paste("navbar-", as.integer(stats::runif(1, 1, 10000)), sep="")
+    navId <- paste("navbar-", p_randomInt(1000, 10000), sep="")
     containerDiv <- div(class="container",
                         tags$button(type="button",
                                     class="btn btn-navbar",
@@ -431,7 +428,7 @@ conditionalPanel <- function(condition, ...) {
 #' @export
 textInput <- function(inputId, label, value = "") {
   tagList(
-    tags$label(label, `for` = inputId),
+    label %AND% tags$label(label, `for` = inputId),
     tags$input(id = inputId, type="text", value=value)
   )
 }
@@ -467,7 +464,7 @@ numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA) {
     inputTag$attribs$step = step
 
   tagList(
-    tags$label(label, `for` = inputId),
+    label %AND% tags$label(label, `for` = inputId),
     inputTag
   )
 }
@@ -514,7 +511,7 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL) {
     inputTag$attribs$accept <- paste(accept, collapse=',')
 
   tagList(
-    tags$label(label),
+    label %AND% tags$label(label),
     inputTag,
     tags$div(
       id=paste(inputId, "_progress", sep=""),
@@ -556,7 +553,7 @@ checkboxInput <- function(inputId, label, value = FALSE) {
 #' selected values.
 #'
 #' @param inputId Input variable to assign the control's value to.
-#' @param label Display label for the control.
+#' @param label Display label for the control, or \code{NULL}.
 #' @param choices List of values to show checkboxes for. If elements of the list
 #'   are named then that name rather than the value is displayed to the user.
 #' @param selected The values that should be initially selected, if any.
@@ -608,6 +605,8 @@ checkboxGroupInput <- function(inputId, label, choices, selected = NULL) {
 # Before shiny 0.9, `selected` refers to names/labels of `choices`; now it
 # refers to values. Below is a function for backward compatibility.
 validateSelected <- function(selected, choices, inputId) {
+  # drop names, otherwise toJSON() keeps them too
+  selected <- unname(selected)
   if (is.list(choices)) {
     # <optgroup> is not there yet
     if (any(sapply(choices, length) > 1)) return(selected)
@@ -620,7 +619,7 @@ validateSelected <- function(selected, choices, inputId) {
   i <- (selected %in% nms) & !(selected %in% choices)
   if (any(i)) {
     warnFun <- if (all(i)) {
-      # replace names with values; drop names, otherwise toJSON() keeps them too
+      # replace names with values
       selected <- unname(choices[selected])
       warning
     } else stop  # stop when it is ambiguous (some labels == values)
@@ -648,7 +647,7 @@ helpText <- function(...) {
 }
 
 controlLabel <- function(controlName, label) {
-  tags$label(class = "control-label", `for` = controlName, label)
+  label %AND% tags$label(class = "control-label", `for` = controlName, label)
 }
 
 # Takes a vector or list, and adds names (same as the value) to any entries
@@ -675,11 +674,13 @@ choicesWithNames <- function(choices) {
 #' Create a select list that can be used to choose a single or
 #' multiple items from a list of values.
 #'
-#' \code{selectizeInput()} uses the JavaScript library \pkg{selectize.js}
-#' (\url{https://github.com/brianreavis/selectize.js}) to extend the basic
-#' select input element.
+#' By default, \code{selectInput()} and \code{selectizeInput()} use the
+#' JavaScript library \pkg{selectize.js} (\url{https://github.com/brianreavis/selectize.js})
+#' to instead of the basic select input element. To use the standard HTML select
+#' input element, use \code{selectInput()} with \code{selectize=FALSE}.
+#'
 #' @param inputId Input variable to assign the control's value to
-#' @param label Display label for the control
+#' @param label Display label for the control, or \code{NULL}
 #' @param choices List of values to select from. If elements of the list are
 #' named then that name rather than the value is displayed to the user.
 #' @param selected The initially selected value (or multiple values if
@@ -699,7 +700,7 @@ choicesWithNames <- function(choices) {
 #'               "Gears" = "gear"))
 #' @export
 selectInput <- function(inputId, label, choices, selected = NULL,
-                        multiple = FALSE, selectize = TRUE) {
+                        multiple = FALSE, selectize = TRUE, width = NULL) {
   # resolve names
   choices <- choicesWithNames(choices)
 
@@ -708,30 +709,25 @@ selectInput <- function(inputId, label, choices, selected = NULL,
     if (!multiple) selected <- choices[[1]]
   } else selected <- validateSelected(selected, choices, inputId)
 
+  # Create tags for each of the options
+  options <- HTML(paste("<option value=\"",
+    htmlEscape(choices),
+    "\"",
+    ifelse(choices %in% selected, " selected", ""),
+    ">",
+    htmlEscape(names(choices)),
+    "</option>",
+    sep = "", collapse = "\n"));
+
   # create select tag and add options
-  selectTag <- tags$select(id = inputId)
+  selectTag <- tags$select(id = inputId, options)
   if (multiple)
     selectTag$attribs$multiple <- "multiple"
 
-  # Create tags for each of the options
-  optionTags <- mapply(choices, names(choices),
-    SIMPLIFY = FALSE, USE.NAMES = FALSE,
-    FUN = function(choice, name) {
-      optionTag <- tags$option(value = choice, name)
-
-      if (choice %in% selected)
-        optionTag$attribs$selected = "selected"
-
-      optionTag
-    }
-  )
-
-  selectTag <- tagSetChildren(selectTag, list = optionTags)
-
   # return label and select tag
   res <- tagList(controlLabel(inputId, label), selectTag)
   if (!selectize) return(res)
-  selectizeIt(inputId, res, NULL, nonempty = !multiple && !("" %in% choices))
+  selectizeIt(inputId, res, NULL, width, nonempty = !multiple && !("" %in% choices))
 }
 
 #' @rdname selectInput
@@ -740,6 +736,8 @@ selectInput <- function(inputId, label, choices, selected = NULL,
 #'   for possible options (character option values inside \code{\link{I}()} will
 #'   be treated as literal JavaScript code; see \code{\link{renderDataTable}()}
 #'   for details).
+#' @param width The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+#'   see \code{\link{validateCssUnit}}.
 #' @note The selectize input created from \code{selectizeInput()} allows
 #'   deletion of the selected option even in a single select input, which will
 #'   return an empty string as its value. This is the default behavior of
@@ -749,30 +747,36 @@ selectInput <- function(inputId, label, choices, selected = NULL,
 #'   \code{choices} argument. This is to keep compatibility with
 #'   \code{selectInput(..., selectize = FALSE)}.
 #' @export
-selectizeInput <- function(inputId, ..., options = NULL) {
-  selectizeIt(inputId, selectInput(inputId, ..., selectize = FALSE), options)
+selectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
+  selectizeIt(inputId, selectInput(inputId, ..., selectize = FALSE), options, width)
 }
 
 # given a select input and its id, selectize it
-selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
+selectizeIt <- function(inputId, select, options, width = NULL, nonempty = FALSE) {
   res <- checkAsIs(options)
 
-  tagList(
-    select,
-    singleton(tags$head(
-      tags$link(rel = 'stylesheet', type = 'text/css',
-                href = 'shared/selectize/css/selectize.bootstrap2.css'),
+  selectizeDep <- htmlDependency(
+    "selectize", "0.8.5", c(href = "shared/selectize"),
+    stylesheet = "css/selectize.bootstrap2.css",
+    head = format(tagList(
       HTML('<!--[if lt IE 9]>'),
       tags$script(src = 'shared/selectize/js/es5-shim.min.js'),
       HTML('<![endif]-->'),
       tags$script(src = 'shared/selectize/js/selectize.min.js')
-    )),
-    tags$script(
-      type = 'application/json',
-      `data-for` = inputId, `data-nonempty` = if (nonempty) '',
-      `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
-      if (length(res$options)) HTML(toJSON(res$options)) else '{}'
-    )
+    ))
+  )
+  attachDependencies(
+    tagList(
+      select,
+      tags$script(
+        type = 'application/json',
+        `data-for` = inputId, `data-nonempty` = if (nonempty) '',
+        `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
+        `data-width` = validateCssUnit(width),
+        if (length(res$options)) HTML(toJSON(res$options)) else '{}'
+      )
+    ),
+    selectizeDep
   )
 }
 
@@ -781,7 +785,7 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 #' Create a set of radio buttons used to select an item from a list.
 #'
 #' @param inputId Input variable to assign the control's value to
-#' @param label Display label for the control
+#' @param label Display label for the control, or \code{NULL}
 #' @param choices List of values to select from (if elements of the list are
 #' named then that name rather than the value is displayed to the user)
 #' @param selected The initially selected value (if not specified then
@@ -830,9 +834,9 @@ radioButtons <- function(inputId, label, choices, selected = NULL) {
   )
 
   tags$div(id = inputId,
-           class = 'control-group shiny-input-radiogroup',
-           tags$label(class = "control-label", `for` = inputId, label),
-           inputTags)
+    class = 'control-group shiny-input-radiogroup',
+    label %AND% tags$label(class = "control-label", `for` = inputId, label),
+    inputTags)
 }
 
 #' Create a submit button
@@ -852,27 +856,22 @@ radioButtons <- function(inputId, label, choices, selected = NULL) {
 #' submitButton("Update View", icon("refresh"))
 #' @export
 submitButton <- function(text = "Apply Changes", icon = NULL) {
-
-  if (!is.null(icon))
-    buttonContent <- list(icon, text)
-  else
-    buttonContent <- text
-
   div(
-    tags$button(type="submit", class="btn btn-primary", buttonContent)
+    tags$button(type="submit", class="btn btn-primary", list(icon, text))
   )
 }
 
-#' Action button
+#' Action button/link
 #'
-#' Creates an action button whose value is initially zero, and increments by one
+#' Creates an action button or link whose value is initially zero, and increments by one
 #' each time it is pressed.
 #'
 #' @param inputId Specifies the input slot that will be used to access the
 #'   value.
-#' @param label The contents of the button--usually a text label, but you could
-#'   also use any other HTML, like an image.
-#' @param icon Optional \code{\link{icon}} to appear on the button
+#' @param label The contents of the button or link--usually a text label, but
+#'   you could also use any other HTML, like an image.
+#' @param icon An optional \code{\link{icon}} to appear on the button.
+#' @param ... Named attributes to be applied to the button or link.
 #'
 #' @family input elements
 #' @examples
@@ -891,17 +890,20 @@ submitButton <- function(text = "Apply Changes", icon = NULL) {
 #' actionButton("goButton", "Go!")
 #' }
 #' @export
-actionButton <- function(inputId, label, icon = NULL) {
-
-  if (!is.null(icon))
-    buttonContent <- list(icon, label)
-  else
-    buttonContent <- label
-
+actionButton <- function(inputId, label, icon = NULL, ...) {
   tags$button(id=inputId,
               type="button",
               class="btn action-button",
-              buttonContent)
+              list(icon, label))
+}
+
+#' @rdname actionButton
+#' @export
+actionLink <- function(inputId, label, icon = NULL, ...) {
+  tags$a(id=inputId,
+         href="#",
+         class="action-button",
+         list(icon, label))
 }
 
 #' Slider Input Widget
@@ -910,7 +912,8 @@ actionButton <- function(inputId, label, icon = NULL) {
 #'
 #' @param inputId Specifies the \code{input} slot that will be used to access
 #'   the value.
-#' @param label A descriptive label to be displayed with the widget.
+#' @param label A descriptive label to be displayed with the widget, or
+#'   \code{NULL}.
 #' @param min The minimum value (inclusive) that can be selected.
 #' @param max The maximum value (inclusive) that can be selected.
 #' @param value The initial value of the slider. A numeric vector of length
@@ -933,7 +936,7 @@ actionButton <- function(inputId, label, icon = NULL) {
 #' @param animate \code{TRUE} to show simple animation controls with default
 #'   settings; \code{FALSE} not to; or a custom settings list, such as those
 #'   created using \code{animationOptions}.
-#'
+#' @inheritParams selectizeInput
 #' @family input elements
 #' @seealso \code{\link{updateSliderInput}}
 #'
@@ -952,7 +955,7 @@ actionButton <- function(inputId, label, icon = NULL) {
 #' @export
 sliderInput <- function(inputId, label, min, max, value, step = NULL,
                         round=FALSE, format='#,##0.#####', locale='us',
-                        ticks=TRUE, animate=FALSE) {
+                        ticks=TRUE, animate=FALSE, width=NULL) {
 
   if (identical(animate, TRUE))
     animate <- animationOptions()
@@ -965,16 +968,24 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   }
 
   # build slider
-  tags$div(
-    tagList(
+  sliderTag <- slider(inputId, min=min, max=max, value=value, step=step,
+    round=round, locale=locale, format=format, ticks=ticks, animate=animate,
+    width=width)
+
+  if (is.null(label)) {
+    sliderTag
+  } else {
+    tags$div(
       controlLabel(inputId, label),
-      slider(inputId, min=min, max=max, value=value, step=step, round=round,
-             locale=locale, format=format, ticks=ticks,
-             animate=animate)
+      sliderTag
     )
-  )
+  }
 }
 
+datePickerDependency <- htmlDependency(
+  "bootstrap-datepicker", "1.0.2", c(href = "shared/datepicker"),
+  script = "js/bootstrap-datepicker.min.js",
+  stylesheet = "css/datepicker.css")
 
 #' Create date input
 #'
@@ -998,7 +1009,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
 #' }
 #'
 #' @param inputId Input variable to assign the control's value to.
-#' @param label Display label for the control.
+#' @param label Display label for the control, or \code{NULL}.
 #' @param value The starting date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format. If NULL (the default), will use the current
 #'   date in the client's time zone.
@@ -1052,12 +1063,7 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
   if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
   if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
 
-  tagList(
-    singleton(tags$head(
-      tags$script(src = "shared/datepicker/js/bootstrap-datepicker.min.js"),
-      tags$link(rel = "stylesheet", type = "text/css",
-                href = 'shared/datepicker/css/datepicker.css')
-    )),
+  attachDependencies(
     tags$div(id = inputId,
              class = "shiny-date-input",
 
@@ -1073,7 +1079,8 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
                  `data-max-date` = max,
                  `data-initial-date` = value
       )
-    )
+    ),
+    datePickerDependency
   )
 }
 
@@ -1155,12 +1162,7 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
   if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
   if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
 
-  tagList(
-    singleton(tags$head(
-      tags$script(src = "shared/datepicker/js/bootstrap-datepicker.min.js"),
-      tags$link(rel = "stylesheet", type = "text/css",
-                href = 'shared/datepicker/css/datepicker.css')
-    )),
+  attachDependencies(
     tags$div(id = inputId,
              # input-daterange class is needed for dropdown behavior
              class = "shiny-date-range-input input-daterange",
@@ -1187,7 +1189,8 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
                  `data-max-date` = max,
                  `data-initial-date` = end
                  )
-    )
+    ),
+    datePickerDependency
   )
 }
 
@@ -1282,9 +1285,7 @@ tabsetPanel <- function(...,
   }
 
   # create the tab div
-  tabDiv <- tags$div(class = paste("tabbable tabs-", position, sep=""),
-                     first,
-                     second)
+  tags$div(class = paste("tabbable tabs-", position, sep=""), first, second)
 }
 
 #' Create a navigation list panel
@@ -1377,7 +1378,7 @@ buildTabset <- function(tabs,
   tabNavList <- tags$ul(class = ulClass, id = id)
   tabContent <- tags$div(class = "tab-content")
   firstTab <- TRUE
-  tabsetId <- as.integer(stats::runif(1, 1, 10000))
+  tabsetId <- p_randomInt(1000, 10000)
   tabId <- 1
   for (divTag in tabs) {
 
@@ -1606,17 +1607,24 @@ tableOutput <- function(outputId) {
   div(id = outputId, class="shiny-html-output")
 }
 
+dataTableDependency <- list(
+  htmlDependency(
+    "datatables", "1.9.4", c(href = "shared/datatables"),
+    script = "js/jquery.dataTables.min.js"
+  ),
+  htmlDependency(
+    "datatables-bootstrap", "1.9.4", c(href = "shared/datatables"),
+    stylesheet = "css/DT_bootstrap.css",
+    script = "js/DT_bootstrap.js"
+  )
+)
+
 #' @rdname tableOutput
 #' @export
 dataTableOutput <- function(outputId) {
-  tagList(
-    singleton(tags$head(
-      tags$link(rel = "stylesheet", type = "text/css",
-                href = "shared/datatables/css/DT_bootstrap.css"),
-      tags$script(src = "shared/datatables/js/jquery.dataTables.min.js"),
-      tags$script(src = "shared/datatables/js/DT_bootstrap.js")
-    )),
-    div(id = outputId, class="shiny-datatable-output")
+  attachDependencies(
+    div(id = outputId, class="shiny-datatable-output"),
+    dataTableDependency
   )
 }
 
@@ -1756,47 +1764,5 @@ icon <- function(name, class = NULL, lib = "font-awesome") {
 
 # Helper funtion to extract the class from an icon
 iconClass <- function(icon) {
-  if (is.null(icon))
-    NULL
-  else
-    icon[[2]]$attribs$class
-}
-
-#' Validate proper CSS formatting of a unit
-#'
-#' Checks that the argument is valid for use as a CSS unit of length.
-#'
-#' \code{NULL} and \code{NA} are returned unchanged.
-#'
-#' Single element numeric vectors are returned as a character vector with the
-#' number plus a suffix of \code{"px"}.
-#'
-#' Single element character vectors must be \code{"auto"} or \code{"inherit"},
-#' or a number followed by a valid suffix: \code{px}, \code{\%}, \code{em},
-#' \code{pt}, \code{in}, \code{cm}, \code{mm}, \code{ex}, or \code{pc}.
-#'
-#' Any other value will cause an error to be thrown.
-#'
-#' @param x The unit to validate. Will be treated as a number of pixels if a
-#'   unit is not specified.
-#' @return A properly formatted CSS unit of length, if possible. Otherwise, will
-#'   throw an error.
-#' @examples
-#' validateCssUnit("10%")
-#' validateCssUnit(400)  #treated as '400px'
-#' @export
-validateCssUnit <- function(x) {
-  if (is.null(x) || is.na(x))
-    return(x)
-
-  if (length(x) > 1 || (!is.character(x) && !is.numeric(x)))
-    stop('CSS units must be a numeric or character vector with a single element')
-
-  if (is.character(x) &&
-     !grepl("^(auto|inherit|((\\.\\d+)|(\\d+(\\.\\d+)?))(%|in|cm|mm|em|ex|pt|pc|px))$", x)) {
-    stop('"', x, '" is not a valid CSS unit (e.g., "100%", "400px", "auto")')
-  } else if (is.numeric(x)) {
-    x <- paste(x, "px", sep = "")
-  }
-  x
+  if (!is.null(icon)) icon[[2]]$attribs$class
 }

R/cache.R

@@ -23,7 +23,7 @@ CacheContext <- setRefClass(
       mtime <- file.info(file)$mtime
       .tests <<- c(.tests, function() {
         newMtime <- try(file.info(file)$mtime, silent=TRUE)
-        if (is(newMtime, 'try-error'))
+        if (inherits(newMtime, 'try-error'))
           return(TRUE)
         return(!identical(mtime, newMtime))
       })
@@ -77,4 +77,4 @@ dependsOnFile <- function(filepath) {
     .currentCacheContext$cc$forceDirty()
   else
     .currentCacheContext$cc$addDependencyFile(filepath)
-}
+}

R/fileupload.R

@@ -90,7 +90,7 @@ FileUploadContext <- setRefClass(
     },
     createUploadOperation = function(fileInfos) {
       while (TRUE) {
-        id <- paste(as.raw(runif(12, min=0, max=0xFF)), collapse='')
+        id <- paste(as.raw(p_runif(12, min=0, max=0xFF)), collapse='')
         dir <- file.path(.basedir, id)
         if (!dir.create(dir))
           next

R/globals.R

@@ -0,0 +1,9 @@
+# A scope where we can put mutable global state
+.globals <- new.env(parent = emptyenv())
+
+.onLoad <- function(libname, pkgname) {
+  # R's lazy-loading package scheme causes the private seed to be cached in the
+  # package itself, making our PRNG completely deterministic. This line resets
+  # the private seed during load.
+  withPrivateSeed(set.seed(NULL))
+}

R/graph.R

@@ -54,12 +54,12 @@ renderReactLog <- function() {
   return(file)
 }
 
-.graphAppend <- function(logEntry) {
+.graphAppend <- function(logEntry, domain = getDefaultReactiveDomain()) {
   if (isTRUE(getOption('shiny.reactlog', FALSE)))
     .graphEnv$log <- c(.graphEnv$log, list(logEntry))
-  session <- .getShowcaseSessionContext()
-  if (!is.null(session)) {
-    session$.sendCustomMessage("reactlog", logEntry)
+
+  if (!is.null(domain)) {
+    domain$reactlog(logEntry)
   }
 }
 
@@ -71,12 +71,12 @@ renderReactLog <- function() {
   .graphAppend(list(action='depId', id=id, dependsOn=dependee))
 }
 
-.graphCreateContext <- function(id, label, type, prevId) {
+.graphCreateContext <- function(id, label, type, prevId, domain) {
   .graphAppend(list(
     action='ctx', id=id, label=paste(label, collapse='\n'),
     srcref=attr(label, "srcref"), srcfile=attr(label, "srcfile"),
     type=type, prevId=prevId
-  ))
+  ), domain = domain)
 }
 
 .graphEnterContext <- function(id) {
@@ -95,8 +95,8 @@ renderReactLog <- function() {
   ))
 }
 
-.graphInvalidate <- function(id) {
-  .graphAppend(list(action='invalidate', id=id))
+.graphInvalidate <- function(id, domain) {
+  .graphAppend(list(action='invalidate', id=id), domain)
 }
 
 .graphEnv <- new.env()

R/html-deps.R

@@ -0,0 +1,15 @@
+createWebDependency <- function(dependency) {
+  if (is.null(dependency))
+    return(NULL)
+
+  if (!inherits(dependency, "html_dependency"))
+    stop("Unexpected non-html_dependency type")
+
+  if (is.null(dependency$src$href)) {
+    prefix <- paste(dependency$name, "-", dependency$version, sep = "")
+    addResourcePath(prefix, dependency$src$file)
+    dependency$src$href <- prefix
+  }
+
+  return(dependency)
+}

R/htmltools.R

@@ -0,0 +1,101 @@
+#' @export
+a <- htmltools::a
+
+#' @export
+br <- htmltools::br
+
+#' @export
+code <- htmltools::code
+
+#' @export
+div <- htmltools::div
+
+#' @export
+em <- htmltools::em
+
+#' @export
+h1 <- htmltools::h1
+
+#' @export
+h2 <- htmltools::h2
+
+#' @export
+h3 <- htmltools::h3
+
+#' @export
+h4 <- htmltools::h4
+
+#' @export
+h5 <- htmltools::h5
+
+#' @export
+h6 <- htmltools::h6
+
+#' @export
+hr <- htmltools::hr
+
+#' @export
+HTML <- htmltools::HTML
+
+#' @export
+img <- htmltools::img
+
+#' @export
+includeCSS <- htmltools::includeCSS
+
+#' @export
+includeHTML <- htmltools::includeHTML
+
+#' @export
+includeMarkdown <- htmltools::includeMarkdown
+
+#' @export
+includeScript <- htmltools::includeScript
+
+#' @export
+includeText <- htmltools::includeText
+
+#' @export
+is.singleton <- htmltools::is.singleton
+
+#' @export
+p <- htmltools::p
+
+#' @export
+pre <- htmltools::pre
+
+#' @export
+singleton <- htmltools::singleton
+
+#' @export
+span <- htmltools::span
+
+#' @export
+strong <- htmltools::strong
+
+#' @export
+tag <- htmltools::tag
+
+#' @export
+tagAppendAttributes <- htmltools::tagAppendAttributes
+
+#' @export
+tagAppendChild <- htmltools::tagAppendChild
+
+#' @export
+tagAppendChildren <- htmltools::tagAppendChildren
+
+#' @export
+tagList <- htmltools::tagList
+
+#' @export
+tags <- htmltools::tags
+
+#' @export
+tagSetChildren <- htmltools::tagSetChildren
+
+#' @export
+validateCssUnit <- htmltools::validateCssUnit
+
+#' @export
+withTags <- htmltools::withTags

R/imageutils.R

@@ -42,6 +42,9 @@ plotPNG <- function(func, filename=tempfile(fileext='.png'),
   }
 
   pngfun(filename=filename, width=width, height=height, res=res, ...)
+  # Call plot.new() so that even if no plotting operations are performed
+  # at least we have a blank background
+  plot.new()
   dv <- dev.cur()
   tryCatch(shinyCallingHandlers(func()), finally = dev.off(dv))
 

R/jqueryui.R

@@ -80,7 +80,9 @@ absolutePanel <- function(...,
   if (isTRUE(draggable)) {
     divTag <- tagAppendAttributes(divTag, class='draggable')
     return(tagList(
-      singleton(tags$head(tags$script(src='shared/jqueryui/1.10.3/jquery-ui.min.js'))),
+      # IMPORTANT NOTE: If you update jqueryui, make sure you DON'T include the datepicker,
+      # as it collides with our bootstrap datepicker!
+      singleton(tags$head(tags$script(src='shared/jqueryui/1.10.4/jquery-ui.min.js'))),
       divTag,
       tags$script('$(".draggable").draggable();')
     ))

R/map.R

@@ -20,27 +20,23 @@ Map <- setRefClass(
     },
     get = function(key) {
       if (.self$containsKey(key))
-        return(base::get(key, pos=.env, inherits=FALSE))
-      else
-        return(NULL)
+        base::get(key, pos=.env, inherits=FALSE)
     },
     set = function(key, value) {
       assign(key, value, pos=.env, inherits=FALSE)
-      return(value)
+      value
     },
     mset = function(...) {
       args <- list(...)
       for (key in names(args))
         set(key, args[[key]])
-      return()
     },
     remove = function(key) {
       if (.self$containsKey(key)) {
         result <- .self$get(key)
         rm(list = key, pos=.env, inherits=FALSE)
-        return(result)
+        result
       }
-      return(NULL)
     },
     containsKey = function(key) {
       exists(key, where=.env, inherits=FALSE)

R/middleware-shiny.R

@@ -0,0 +1,71 @@
+#' @include globals.R
+NULL
+
+reactLogHandler <- function(req) {
+  if (!identical(req$PATH_INFO, '/reactlog'))
+    return(NULL)
+
+  if (!getOption('shiny.reactlog', FALSE)) {
+    return(NULL)
+  }
+
+  return(httpResponse(
+    status=200,
+    content=list(file=renderReactLog(), owned=TRUE)
+  ))
+}
+
+sessionHandler <- function(req) {
+  path <- req$PATH_INFO
+  if (is.null(path))
+    return(NULL)
+
+  matches <- regmatches(path, regexec('^(/session/([0-9a-f]+))(/.*)$', path))
+  if (length(matches[[1]]) == 0)
+    return(NULL)
+
+  session <- matches[[1]][3]
+  subpath <- matches[[1]][4]
+
+  shinysession <- appsByToken$get(session)
+  if (is.null(shinysession))
+    return(NULL)
+
+  subreq <- as.environment(as.list(req, all.names=TRUE))
+  subreq$PATH_INFO <- subpath
+  subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, matches[[1]][2], sep='')
+
+  return(shinysession$handleRequest(subreq))
+}
+
+dynamicHandler <- function(filePath, dependencyFiles=filePath) {
+  lastKnownTimestamps <- NA
+  metaHandler <- function(req) NULL
+
+  if (!file.exists(filePath))
+    return(metaHandler)
+
+  cacheContext <- CacheContext$new()
+
+  return (function(req) {
+    # Check if we need to rebuild
+    if (cacheContext$isDirty()) {
+      cacheContext$reset()
+      for (dep in dependencyFiles)
+        cacheContext$addDependencyFile(dep)
+
+      clearClients()
+      if (file.exists(filePath)) {
+        local({
+          cacheContext$with(function() {
+            sys.source(filePath, envir=new.env(parent=globalenv()), keep.source=TRUE)
+          })
+        })
+      }
+      metaHandler <<- joinHandlers(.globals$clients)
+      clearClients()
+    }
+
+    return(metaHandler(req))
+  })
+}

R/middleware.R

@@ -0,0 +1,354 @@
+# This file contains a general toolkit for routing and combining bits of
+# HTTP-handling logic. It is similar in spirit to Rook (and Rack, and WSGI, and
+# Connect, and...) but adds cascading and routing.
+#
+# This file is called "middleware" because that's the term used for these bits
+# of logic in these other frameworks. However, our code uses the word "handler"
+# so we'll stick to that for the rest of this document; just know that they're
+# basically the same concept.
+#
+# ## Intro to handlers
+#
+# A **handler** (or sometimes, **httpHandler**) is a function that takes a
+# `req` parameter--a request object as described in the Rook specification--and
+# returns `NULL`, or an `httpResponse`.
+#
+## ------------------------------------------------------------------------
+httpResponse <- function(status = 200,
+                         content_type = "text/html; charset=UTF-8",
+                         content = "",
+                         headers = list()) {
+  # Make sure it's a list, not a vector
+  headers <- as.list(headers)
+  if (is.null(headers$`X-UA-Compatible`))
+    headers$`X-UA-Compatible` <- "chrome=1"
+  resp <- list(status = status, content_type = content_type, content = content,
+               headers = headers)
+  class(resp) <- 'httpResponse'
+  return(resp)
+}
+
+#
+# You can think of a web application as being simply an aggregation of these
+# functions, each of which performs one kind of duty. Each handler in turn gets
+# a look at the request and can decide whether it knows how to handle it. If
+# so, it returns an `httpResponse` and processing terminates; if not, it
+# returns `NULL` and the next handler gets to execute. If the final handler
+# returns `NULL`, a 404 response should be returned.
+#
+# We have a similar construct for websockets: **websocket handlers** or
+# **wsHandlers**. These take a single `ws` argument which is the websocket
+# connection that was just opened, and they can either return `TRUE` if they
+# are handling the connection, and `NULL` to pass responsibility on to the next
+# wsHandler.
+#
+# ### Combining handlers
+#
+# Since it's so common for httpHandlers to be invoked in this "cascading"
+# fashion, we'll introduce a function that takes zero or more handlers and
+# returns a single handler. And while we're at it, making a directory of static
+# content available is such a common thing to do, we'll allow strings
+# representing paths to be used instead of handlers; any such strings we
+# encounter will be converted into `staticHandler` objects.
+#
+## ------------------------------------------------------------------------
+joinHandlers <- function(handlers) {
+  # Zero handlers; return a null handler
+  if (length(handlers) == 0)
+    return(function(req) NULL)
+
+  # Just one handler (function)? Return it.
+  if (is.function(handlers))
+    return(handlers)
+
+  handlers <- lapply(handlers, function(h) {
+    if (is.character(h))
+      return(staticHandler(h))
+    else
+      return(h)
+  })
+
+  # Filter out NULL
+  handlers <- handlers[!sapply(handlers, is.null)]
+
+  if (length(handlers) == 0)
+    return(function(req) NULL)
+  if (length(handlers) == 1)
+    return(handlers[[1]])
+
+  function(req) {
+    for (handler in handlers) {
+      response <- handler(req)
+      if (!is.null(response))
+        return(response)
+    }
+    return(NULL)
+  }
+}
+
+#
+# Note that we don't have an equivalent of `joinHandlers` for wsHandlers. It's
+# easy to imagine it, we just haven't needed one.
+#
+# ### Handler routing
+#
+# Handlers do not have a built-in notion of routing. Conceptually, given a list
+# of handlers, all the handlers are peers and they all get to see every request
+# (well, up until the point that a handler returns a response).
+#
+# You could implement routing in each handler by checking the request's
+# `PATH_INFO` field, but since it's such a common need, let's make it simple by
+# introducing a `routeHandler` function. This is a handler
+# [decorator](http://en.wikipedia.org/wiki/Decorator_pattern) and it's
+# responsible for 1) filtering out requests that don't match the given route,
+# and 2) temporarily modifying the request object to take the matched part of
+# the route off of the `PATH_INFO` (and add it to the end of `SCRIPT_NAME`).
+# This way, the handler doesn't need to figure out about what part of its URL
+# path has already been matched via routing.
+#
+# (BTW, it's safe for `routeHandler` calls to nest.)
+#
+## ------------------------------------------------------------------------
+routeHandler <- function(prefix, handler) {
+  force(prefix)
+  force(handler)
+
+  if (identical("", prefix))
+    return(handler)
+
+  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
+    stop("Invalid URL prefix \"", prefix, "\"")
+  }
+
+  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
+  function(req) {
+    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
+      origScript <- req$SCRIPT_NAME
+      origPath <- req$PATH_INFO
+      on.exit({
+        req$SCRIPT_NAME <- origScript
+        req$PATH_INFO <- origPath
+      }, add = TRUE)
+      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
+      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
+      req$PATH_INFO <- pathInfo
+      return(handler(req))
+    } else {
+      return(NULL)
+    }
+  }
+}
+
+#
+# We have a version for websocket handlers as well. Pity about the copy/paste
+# job.
+#
+## ------------------------------------------------------------------------
+routeWSHandler <- function(prefix, wshandler) {
+  force(prefix)
+  force(wshandler)
+
+  if (identical("", prefix))
+    return(wshandler)
+
+  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
+    stop("Invalid URL prefix \"", prefix, "\"")
+  }
+
+  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
+  function(ws) {
+    req <- ws$request
+    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
+      origScript <- req$SCRIPT_NAME
+      origPath <- req$PATH_INFO
+      on.exit({
+        req$SCRIPT_NAME <- origScript
+        req$PATH_INFO <- origPath
+      }, add = TRUE)
+      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
+      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
+      req$PATH_INFO <- pathInfo
+      return(wshandler(ws))
+    } else {
+      return(NULL)
+    }
+  }
+}
+
+#
+# ### Handler implementations
+#
+# Now let's actually write some handlers. Note that these functions aren't
+# *themselves* handlers, you call them and they *return* a handler. Handler
+# factory functions, if you will.
+#
+# Here's one that serves up static assets from a directory.
+#
+## ------------------------------------------------------------------------
+staticHandler <- function(root) {
+  force(root)
+  return(function(req) {
+    if (!identical(req$REQUEST_METHOD, 'GET'))
+      return(NULL)
+
+    path <- req$PATH_INFO
+
+    if (is.null(path))
+      return(httpResponse(400, content="<h1>Bad Request</h1>"))
+
+    if (path == '/')
+      path <- '/index.html'
+
+    abs.path <- resolve(root, path)
+    if (is.null(abs.path))
+      return(NULL)
+
+    ext <- tools::file_ext(abs.path)
+    content.type <- getContentType(ext)
+    response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
+    return(httpResponse(200, content.type, response.content))
+  })
+}
+
+#
+# ## Handler manager
+#
+# The handler manager gives you a place to register handlers (of both http and
+# websocket varieties) and provides an httpuv-compatible set of callbacks for
+# invoking them.
+#
+# Create one of these, make zero or more calls to `addHandler` and
+# `addWSHandler` methods (order matters--first one wins!), and then pass the
+# return value of `createHttpuvApp` to httpuv's `startServer` function.
+#
+## ------------------------------------------------------------------------
+HandlerList <- setRefClass("HandlerList",
+  fields = list(
+    handlers = "list"
+  ),
+  methods = list(
+    add = function(handler, key, tail = FALSE) {
+      if (!is.null(handlers[[key]]))
+        stop("Key ", key, " already in use")
+      newList <- structure(names=key, list(handler))
+
+      if (length(handlers) == 0)
+        handlers <<- newList
+      else if (tail)
+        handlers <<- c(handlers, newList)
+      else
+        handlers <<- c(newList, handlers)
+    },
+    remove = function(key) {
+      handlers[key] <<- NULL
+    },
+    clear = function() {
+      handlers <<- list()
+    },
+    invoke = function(...) {
+      for (handler in handlers) {
+        result <- handler(...)
+        if (!is.null(result))
+          return(result)
+      }
+      return(NULL)
+    }
+  )
+)
+
+HandlerManager <- setRefClass("HandlerManager",
+  fields = list(
+    handlers = "HandlerList",
+    wsHandlers = "HandlerList"
+  ),
+  methods = list(
+    addHandler = function(handler, key, tail = FALSE) {
+      handlers$add(handler, key, tail)
+    },
+    removeHandler = function(key) {
+      handlers$remove(key)
+    },
+    addWSHandler = function(wsHandler, key, tail = FALSE) {
+      wsHandlers$add(wsHandler, key, tail)
+    },
+    removeWSHandler = function(key) {
+      wsHandlers$remove(key)
+    },
+    clear = function() {
+      handlers$clear()
+      wsHandlers$clear()
+    },
+    createHttpuvApp = function() {
+      list(
+        onHeaders = function(req) {
+          maxSize <- getOption('shiny.maxRequestSize', 5 * 1024 * 1024)
+          if (maxSize <= 0)
+            return(NULL)
+
+          reqSize <- 0
+          if (length(req$CONTENT_LENGTH) > 0)
+            reqSize <- as.numeric(req$CONTENT_LENGTH)
+          else if (length(req$HTTP_TRANSFER_ENCODING) > 0)
+            reqSize <- Inf
+
+          if (reqSize > maxSize) {
+            return(list(status = 413L,
+              headers = list(
+                'Content-Type' = 'text/plain'
+              ),
+              body = 'Maximum upload size exceeded'))
+          }
+          else {
+            return(NULL)
+          }
+        },
+        call = .httpServer(
+          function (req) {
+            return(handlers$invoke(req))
+          },
+          getOption('shiny.sharedSecret', NULL)
+        ),
+        onWSOpen = function(ws) {
+          return(wsHandlers$invoke(ws))
+        }
+      )
+    },
+    .httpServer = function(handler, sharedSecret) {
+      filter <- getOption('shiny.http.response.filter', NULL)
+      if (is.null(filter))
+        filter <- function(req, response) response
+
+      function(req) {
+        if (!is.null(sharedSecret)
+          && !identical(sharedSecret, req$HTTP_SHINY_SHARED_SECRET)) {
+          return(list(status=403,
+            body='<h1>403 Forbidden</h1><p>Shared secret mismatch</p>',
+            headers=list('Content-Type' = 'text/html')))
+        }
+
+        response <- handler(req)
+        if (is.null(response))
+          response <- httpResponse(404, content="<h1>Not Found</h1>")
+        
+        if (inherits(response, "httpResponse")) {
+          headers <- as.list(response$headers)
+          headers$'Content-Type' <- response$content_type
+  
+          response <- filter(req, response)
+          return(list(status=response$status,
+            body=response$content,
+            headers=headers))
+        } else {
+          # Assume it's a Rook-compatible response
+          return(response)
+        }
+      }
+    }
+  )
+)
+
+#
+# ## Next steps
+#
+# See server.R and middleware-shiny.R to see actual implementation and usage of
+# handlers in the context of Shiny.

R/react.R

@@ -5,23 +5,29 @@ Context <- setRefClass(
     .label = 'character',      # For debug purposes
     .invalidated = 'logical',
     .invalidateCallbacks = 'list',
-    .flushCallbacks = 'list'
+    .flushCallbacks = 'list',
+    .domain = 'ANY'
   ),
   methods = list(
-    initialize = function(label='', type='other', prevId='') {
+    initialize = function(domain, label='', type='other', prevId='') {
       id <<- .getReactiveEnvironment()$nextId()
       .invalidated <<- FALSE
       .invalidateCallbacks <<- list()
       .flushCallbacks <<- list()
       .label <<- label
-      .graphCreateContext(id, label, type, prevId)
+      .domain <<- domain
+      .graphCreateContext(id, label, type, prevId, domain)
     },
     run = function(func) {
       "Run the provided function under this context."
-      env <- .getReactiveEnvironment()
-      .graphEnterContext(id)
-      on.exit(.graphExitContext(id))
-      env$runWith(.self, func)
+      withReactiveDomain(.domain, {
+        env <- .getReactiveEnvironment()
+        .graphEnterContext(id)
+        tryCatch(
+          env$runWith(.self, func),
+          finally = .graphExitContext(id)
+        )
+      })
     },
     invalidate = function() {
       "Invalidate this context. It will immediately call the callbacks
@@ -30,10 +36,11 @@ Context <- setRefClass(
         return()
       .invalidated <<- TRUE
 
-      .graphInvalidate(id)
+      .graphInvalidate(id, .domain)
       lapply(.invalidateCallbacks, function(func) {
         func()
       })
+      .invalidateCallbacks <<- list()
       NULL
     },
     onInvalidate = function(func) {
@@ -124,10 +131,14 @@ ReactiveEnvironment <- setRefClass(
   )
 )
 
-.reactiveEnvironment <- ReactiveEnvironment$new()
-.getReactiveEnvironment <- function() {
-  .reactiveEnvironment
-}
+.getReactiveEnvironment <- local({
+  reactiveEnvironment <- NULL
+  function() {
+    if (is.null(reactiveEnvironment))
+      reactiveEnvironment <<- ReactiveEnvironment$new()
+    return(reactiveEnvironment)
+  }
+}) 
 
 # Causes any pending invalidations to run.
 flushReact <- function() {
@@ -144,8 +155,10 @@ getDummyContext <- function() {}
 local({
   dummyContext <- NULL
   getDummyContext <<- function() {
-    if (is.null(dummyContext))
-      dummyContext <<- Context$new('[none]', type='isolate')
+    if (is.null(dummyContext)) {
+      dummyContext <<- Context$new(getDefaultReactiveDomain(), '[none]',
+        type='isolate')
+    }
     return(dummyContext)
   }
 })

R/reactive-domains.R

@@ -0,0 +1,252 @@
+#' @include globals.R
+NULL
+
+#
+# Over the last few months we've seen a number of cases where it'd be helpful
+# for objects that are instantiated within a Shiny app to know what Shiny
+# session they are "owned" by. I put "owned" in quotes because there isn't a
+# built-in notion of object ownership in Shiny today, any more than there is a
+# notion of one object owning another in R.
+#
+# But it's intuitive to everyone, I think, that the outputs for a session are
+# owned by that session, and any logic that is executed as part of the output
+# is done on behalf of that session. And it seems like in the vast majority of
+# cases, observers that are created inside a shinyServer function (i.e. one per
+# session) are also intuitively owned by the session that's starting up.
+#
+# This notion of ownership is important/helpful for a few scenarios that have
+# come up in recent months:
+#
+# 1. The showcase mode that Jonathan implemented recently highlights
+# observers/reactives as they execute. In order for sessions to only receive
+# highlights for their own code execution, we need to know which sessions own
+# which observers. 2. We've seen a number of apps crash out when observers
+# outlive their sessions and then try to do things with their sessions (the
+# most common error message was something like "Can't write to a closed
+# websocket", but we now silently ignore writes to closed websockets). It'd be
+# convenient for the default behavior of observers to be that they don't
+# outlive their parent sessions. 3. The reactive log visualizer currently
+# visualizes all reactivity in the process; it would be great if by default it
+# only visualized the current session. 4. When an observer has an error, it
+# would be great to be able to send the error to the session so it can do its
+# own handling (such as sending the error info to the client so the user can be
+# notified). 5. Shiny Server Pro wants to show the admin how much time is being
+# spent servicing each session.
+#
+# So what are the rules for establishing ownership?
+#
+# 1. Define the "current domain" as a global variable whose value will own any
+# newly created observer (by default). A domain is a reference class or
+# environment that contains the functions `onEnded(callback)`, `isEnded()`, and
+# `reactlog(logEntry)`.
+#
+## ------------------------------------------------------------------------
+createMockDomain <- function() {
+  callbacks <- list()
+  ended <- FALSE
+  domain <- new.env(parent = emptyenv())
+  domain$onEnded <- function(callback) {
+    callbacks <<- c(callbacks, callback)
+  }
+  domain$isEnded <- function() {
+    ended
+  }
+  domain$reactlog <- function(logEntry) NULL
+  domain$end <- function() {
+    if (!ended) {
+      ended <<- TRUE
+      lapply(callbacks, do.call, list())
+    }
+    invisible()
+  }
+  return(domain)
+}
+
+#
+# 2. The initial value of "current domain" is null.
+#
+## ------------------------------------------------------------------------
+.globals$domain <- NULL
+
+#
+# 3. Objects that can be owned include observers, reactive expressions,
+# invalidateLater instances, reactiveTimer instances. Whenever one of these is
+# created, by default its owner will be the current domain.
+#
+## ------------------------------------------------------------------------
+
+#' @rdname domains
+#' @export
+getDefaultReactiveDomain <- function() {
+  .globals$domain
+}
+
+#
+# 4. While a session is being created and the shinyServer function is executed,
+# the current domain is set to the new session. When the shinyServer function
+# is done executing, the previous value of the current domain is restored. This
+# is made foolproof using a `withReactiveDomain` function.
+#
+## ------------------------------------------------------------------------
+
+#' @rdname domains
+#' @export
+withReactiveDomain <- function(domain, expr) {
+  oldValue <- .globals$domain
+  .globals$domain <- domain
+  on.exit(.globals$domain <- oldValue)
+
+  expr
+}
+
+#
+# 5. While an observer or reactive expression is executing, the current domain
+# is set to the owner of the observer. When the observer completes, the
+# previous value of the current domain is restored.
+#
+# 6. Note that once created, an observer/reactive expression belongs to the
+# same domain forever, regardless of how many times it is invalidated and
+# re-executed, and regardless of what caused the invalidation to happen.
+#
+# 7. When a session ends, any observers that it owns are suspended, any
+# invalidateLater/reactiveTimers are stopped.
+#
+## ------------------------------------------------------------------------
+
+#' @rdname domains
+#' @export
+onReactiveDomainEnded <- function(domain, callback, failIfNull = FALSE) {
+  if (is.null(domain)) {
+    if (isTRUE(failIfNull))
+      stop("onReactiveDomainEnded called with null domain and failIfNull=TRUE")
+    else
+      return()
+  }
+  domain$onEnded(callback)
+}
+
+#
+# 8. If an uncaught error occurs while executing an observer, the session gets
+# a chance to handle it. I suppose the default behavior would be to send the
+# message to the client if possible, and then perhaps end the session (or not,
+# I could argue either way).
+#
+# The basic idea here is inspired by Node.js domains, which you can think of as
+# a way to track execution contexts across callback- or listener-oriented
+# asynchronous code. They use it to unify error handling code across a graph of
+# related objects. Our domains will be to unify both lifetime and error
+# handling across a graph of related reactive primitives.
+#
+# (You could imagine that as a client update is being processed, the session
+# associated with that client would become the current domain. IIRC this is how
+# showcase mode is implemented today. I don't think this would cover any cases
+# not covered by rule 5 above, and the absence of rule 5 would leave cases that
+# this rule would not cover.)
+#
+# Pitfalls/open issues:
+#
+# 1. Our current approach has the issue of observers staying alive longer than
+# they ought to. This proposal introduces the opposite risk: that
+# observers/invalidateLater/reactiveTimer instances, having implicitly been
+# assigned a parent, are suspended/disposed earlier than they ought to have
+# been. I find this especially worrisome for invalidateLater/reactiveTimer,
+# which will often be called in a reactive expression, and thus execute under
+# unpredictable circumstances. Perhaps those should continue to accept an
+# explicit "session=" parameter that the user is warned about if they don't
+# provide a value.
+#
+# 2. Are there situations where it is ambiguous what the right thing to do is,
+# and we should warn/error to ask the user to provide a domain explicitly?
+#
+## ------------------------------------------------------------------------
+
+#' Reactive domains
+#'
+#' Reactive domains are a mechanism for establishing ownership over reactive
+#' primitives (like reactive expressions and observers), even if the set of
+#' reactive primitives is dynamically created. This is useful for lifetime
+#' management (i.e. destroying observers when the Shiny session that created
+#' them ends) and error handling.
+#'
+#' At any given time, there can be either a single "default" reactive domain
+#' object, or none (i.e. the reactive domain object is \code{NULL}). You can
+#' access the current default reactive domain by calling
+#' \code{getDefaultReactiveDomain}.
+#'
+#' Unless you specify otherwise, newly created observers and reactive
+#' expressions will be assigned to the current default domain (if any). You can
+#' override this assignment by providing an explicit \code{domain} argument to
+#' \code{\link{reactive}} or \code{\link{observe}}.
+#'
+#' For advanced usage, it's possible to override the default domain using
+#' \code{withReactiveDomain}. The \code{domain} argument will be made the
+#' default domain while \code{expr} is evaluated.
+#'
+#' Implementers of new reactive primitives can use \code{onReactiveDomainEnded}
+#' as a convenience function for registering callbacks. If the reactive domain
+#' is \code{NULL} and \code{failIfNull} is \code{FALSE}, then the callback will
+#' never be invoked.
+#'
+#' @name domains
+#' @param domain A valid domain object (for example, a Shiny session), or
+#'   \code{NULL}
+#' @param expr An expression to evaluate under \code{domain}
+#' @param callback A callback function to be invoked
+#' @param failIfNull If \code{TRUE} then an error is given if the \code{domain}
+#'   is \code{NULL}
+NULL
+
+#
+# Example 1
+# ---
+# ```
+# obs1 <- observe({
+# })
+# shinyServer(function(input, output) {
+#   obs2 <- observe({
+#     obs3 <- observe({
+#     })
+#   })
+# })
+# # obs1 would have no domain, obs2 and obs3 would be owned by the session
+# ```
+#
+# Example 2
+# ---
+# ```
+# globalValues <- reactiveValues(broadcast="")
+# shinyServer(function(input, output) {
+#   sessionValues <- reactiveValues()
+#   output$messageOutput <- renderText({
+#     globalValues$broadcast
+#     obs1 <- observe({...})
+#   })
+#   observe({
+#     if (input$goButton == 0) return()
+#     isolate( globalValues$broadcast <- input$messageInput )
+#   })
+# })
+# # The observer behind messageOutput would be owned by the session,
+# # as would all the many instances of obs1 that were created.
+# ```
+# ---
+#
+# Example 3
+# ---
+# ```
+# rexpr1 <- reactive({
+#   invalidateLater(1000)
+#   obs1 <- observe({...})
+# })
+# observeSomething <- function() {
+#   obs2 <- observe({...})
+# })
+# shinyServer(function(input, output) {
+#   obs3 <- observe({
+#     observeSomething()
+#     rexpr1()
+#   })
+# })
+# # rexpr1, the invalidateLater call, and obs1 would all have no owner;
+# # obs2 and obs3 would be owned by the session.
+# ```

R/reactives.R

@@ -1,3 +1,6 @@
+#' @include utils.R
+NULL
+
 Dependents <- setRefClass(
   'Dependents',
   fields = list(
@@ -49,7 +52,8 @@ ReactiveValues <- setRefClass(
   ),
   methods = list(
     initialize = function() {
-      .label <<- paste('reactiveValues', runif(1, min=1000, max=9999),
+      .label <<- paste('reactiveValues',
+                       p_randomInt(1000, 10000),
                        sep="")
       .values <<- new.env(parent=emptyenv())
       .dependents <<- new.env(parent=emptyenv())
@@ -208,15 +212,15 @@ setOldClass("reactivevalues")
 #' @export
 is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
 
-#' @S3method $ reactivevalues
+#' @export
 `$.reactivevalues` <- function(x, name) {
   .subset2(x, 'impl')$get(name)
 }
 
-#' @S3method [[ reactivevalues
+#' @export
 `[[.reactivevalues` <- `$.reactivevalues`
 
-#' @S3method $<- reactivevalues
+#' @export
 `$<-.reactivevalues` <- function(x, name, value) {
   if (attr(x, 'readonly')) {
     stop("Attempted to assign value to a read-only reactivevalues object")
@@ -228,30 +232,30 @@ is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
   }
 }
 
-#' @S3method [[<- reactivevalues
+#' @export
 `[[<-.reactivevalues` <- `$<-.reactivevalues`
 
-#' @S3method [ reactivevalues
+#' @export
 `[.reactivevalues` <- function(values, name) {
   stop("Single-bracket indexing of reactivevalues object is not allowed.")
 }
 
-#' @S3method [<- reactivevalues
+#' @export
 `[<-.reactivevalues` <- function(values, name, value) {
   stop("Single-bracket indexing of reactivevalues object is not allowed.")
 }
 
-#' @S3method names reactivevalues
+#' @export
 names.reactivevalues <- function(x) {
   .subset2(x, 'impl')$names()
 }
 
-#' @S3method names<- reactivevalues
+#' @export
 `names<-.reactivevalues` <- function(x, value) {
   stop("Can't assign names to reactivevalues object")
 }
 
-#' @S3method as.list reactivevalues
+#' @export
 as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
   shinyDeprecated("reactiveValuesToList",
     msg = paste("'as.list.reactivevalues' is deprecated. ",
@@ -293,6 +297,17 @@ reactiveValuesToList <- function(x, all.names=FALSE) {
   .subset2(x, 'impl')$toList(all.names)
 }
 
+# This function is needed because str() on a reactivevalues object will call
+# [[.reactivevalues(), which will give an error when it tries to access
+# x[['impl']].
+#' @export
+str.reactivevalues <- function(object, indent.str = " ", ...) {
+  str(unclass(object), indent.str = indent.str, ...)
+  # Need to manually print out the class field,
+  cat(indent.str, '- attr(*, "class")=', sep = "")
+  str(class(object))
+}
+
 # Observable ----------------------------------------------------------------
 
 Observable <- setRefClass(
@@ -300,6 +315,7 @@ Observable <- setRefClass(
   fields = list(
     .func = 'function',
     .label = 'character',
+    .domain = 'ANY',
     .dependents = 'Dependents',
     .invalidated = 'logical',
     .running = 'logical',
@@ -309,7 +325,8 @@ Observable <- setRefClass(
     .mostRecentCtxId = 'character'
   ),
   methods = list(
-    initialize = function(func, label=deparse(substitute(func))) {
+    initialize = function(func, label = deparse(substitute(func)),
+                          domain = getDefaultReactiveDomain()) {
       if (length(formals(func)) > 0)
         stop("Can't make a reactive expression from a function that takes one ",
              "or more parameters; only functions without parameters can be ",
@@ -318,6 +335,7 @@ Observable <- setRefClass(
       .invalidated <<- TRUE
       .running <<- FALSE
       .label <<- label
+      .domain <<- domain
       .execCount <<- 0L
       .mostRecentCtxId <<- ""
     },
@@ -339,7 +357,8 @@ Observable <- setRefClass(
         invisible(.value)
     },
     .updateValue = function() {
-      ctx <- Context$new(.label, type='observable', prevId=.mostRecentCtxId)
+      ctx <- Context$new(.domain, .label, type = 'observable',
+                         prevId = .mostRecentCtxId)
       .mostRecentCtxId <<- ctx$id
       ctx$onInvalidate(function() {
         .invalidated <<- TRUE
@@ -354,7 +373,7 @@ Observable <- setRefClass(
       on.exit(.running <<- wasRunning)
 
       ctx$run(function() {
-        result <- withVisible(try(shinyCallingHandlers(.func()), silent=FALSE))
+        result <- withVisible(try(shinyCallingHandlers(.func()), silent=TRUE))
         .visible <<- result$visible
         .value <<- result$value
       })
@@ -387,6 +406,7 @@ Observable <- setRefClass(
 #'   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.
+#' @param domain See \link{domains}.
 #' @return a function, wrapped in a S3 class "reactive"
 #'
 #' @examples
@@ -409,7 +429,8 @@ Observable <- setRefClass(
 #' isolate(reactiveD())
 #'
 #' @export
-reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL) {
+reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
+                     domain = getDefaultReactiveDomain()) {
   fun <- exprToFunction(x, env, quoted)
   # Attach a label and a reference to the original user source for debugging
   if (is.null(label))
@@ -417,12 +438,12 @@ reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL) {
   srcref <- attr(substitute(x), "srcref")
   if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
   attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
-  o <- Observable$new(fun, label)
+  o <- Observable$new(fun, label, domain)
   registerDebugHook(".func", o, "Reactive")
   structure(o$getValue@.Data, observable = o, class = "reactive")
 }
 
-#' @S3method print reactive
+#' @export
 print.reactive <- function(x, ...) {
   label <- attr(x, "observable")$.label
   cat(label, "\n")
@@ -436,7 +457,7 @@ is.reactive <- function(x) inherits(x, "reactive")
 execCount <- function(x) {
   if (is.function(x))
     return(environment(x)$.execCount)
-  else if (is(x, 'Observer'))
+  else if (inherits(x, 'Observer'))
     return(x$.execCount)
   else
     stop('Unexpected argument to execCount')
@@ -449,32 +470,42 @@ Observer <- setRefClass(
   fields = list(
     .func = 'function',
     .label = 'character',
+    .domain = 'ANY',
     .priority = 'numeric',
+    .autoDestroy = 'logical',
     .invalidateCallbacks = 'list',
     .execCount = 'integer',
     .onResume = 'function',
     .suspended = 'logical',
+    .destroyed = 'logical',
     .prevId = 'character'
   ),
   methods = list(
-    initialize = function(func, label, suspended = FALSE, priority = 0) {
+    initialize = function(func, label, suspended = FALSE, priority = 0,
+                          domain = getDefaultReactiveDomain(),
+                          autoDestroy = TRUE) {
       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
+      .domain <<- domain
+      .autoDestroy <<- autoDestroy
       .priority <<- normalizePriority(priority)
       .execCount <<- 0L
       .suspended <<- suspended
       .onResume <<- function() NULL
+      .destroyed <<- FALSE
       .prevId <<- ''
 
+      onReactiveDomainEnded(.domain, .self$.onDomainEnded)
+
       # Defer the first running of this until flushReact is called
       .createContext()$invalidate()
     },
     .createContext = function() {
-      ctx <- Context$new(.label, type='observer', prevId=.prevId)
+      ctx <- Context$new(.domain, .label, type='observer', prevId=.prevId)
       .prevId <<- ctx$id
 
       ctx$onInvalidate(function() {
@@ -494,7 +525,8 @@ Observer <- setRefClass(
       })
 
       ctx$onFlush(function() {
-        run()
+        if (!.destroyed)
+          run()
       })
 
       return(ctx)
@@ -517,6 +549,17 @@ Observer <- setRefClass(
       which case the priority change will be effective upon resume."
       .priority <<- normalizePriority(priority)
     },
+    setAutoDestroy = function(autoDestroy) {
+      "Sets whether this observer should be automatically destroyed when its
+      domain (if any) ends. If autoDestroy is TRUE and the domain already
+      ended, then destroy() is called immediately."
+      oldValue <- .autoDestroy
+      .autoDestroy <<- autoDestroy
+      if (!is.null(.domain) && .domain$isEnded()) {
+        destroy()
+      }
+      invisible(oldValue)
+    },
     suspend = function() {
       "Causes this observer to stop scheduling flushes (re-executions) in
       response to invalidations. If the observer was invalidated prior to this
@@ -535,6 +578,18 @@ Observer <- setRefClass(
         .onResume <<- function() NULL
       }
       invisible()
+    },
+    destroy = function() {
+      "Prevents this observer from ever executing again (even if a flush has
+      already been scheduled)."
+
+      suspend()
+      .destroyed <<- TRUE
+    },
+    .onDomainEnded = function() {
+      if (isTRUE(.autoDestroy)) {
+        destroy()
+      }
     }
   )
 )
@@ -543,23 +598,28 @@ Observer <- setRefClass(
 #'
 #' 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).
+#' 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.
+#' 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
+#' Starting with Shiny 0.10.0, observers are automatically destroyed by default
+#' when the \link[=domains]{domain} that owns them ends (e.g. when a Shiny session
+#' ends).
+#'
+#' @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
@@ -571,6 +631,9 @@ Observer <- setRefClass(
 #'   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.
+#' @param domain See \link{domains}.
+#' @param autoDestroy If \code{TRUE} (the default), the observer will be
+#'   automatically destroyed when its domain (if any) ends.
 #' @return An observer reference class object. This object has the following
 #'   methods:
 #'   \describe{
@@ -585,12 +648,21 @@ Observer <- setRefClass(
 #'       invalidations. If the observer was invalidated while suspended, then it
 #'       will schedule itself for re-execution.
 #'     }
+#'     \item{\code{destroy()}}{
+#'       Stops the observer from executing ever again, even if it is currently
+#'       scheduled 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{setAutoDestroy(autoDestroy)}}{
+#'       Sets whether this observer should be automatically destroyed when its
+#'       domain (if any) ends. If autoDestroy is TRUE and the domain already
+#'       ended, then destroy() is called immediately."
+#'     }
 #'     \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
@@ -618,13 +690,15 @@ Observer <- setRefClass(
 #'
 #' @export
 observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
-                    suspended=FALSE, priority=0) {
+                    suspended=FALSE, priority=0,
+                    domain=getDefaultReactiveDomain(), autoDestroy = TRUE) {
 
   fun <- exprToFunction(x, env, quoted)
   if (is.null(label))
     label <- sprintf('observe(%s)', paste(deparse(body(fun)), collapse='\n'))
 
-  o <- Observer$new(fun, label=label, suspended=suspended, priority=priority)
+  o <- Observer$new(fun, label=label, suspended=suspended, priority=priority,
+                    domain=domain, autoDestroy=autoDestroy)
   registerDebugHook(".func", o, "Observer")
   invisible(o)
 }
@@ -1085,9 +1159,28 @@ reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...)
 #'
 #' @export
 isolate <- function(expr) {
-  ctx <- Context$new('[isolate]', type='isolate')
+  ctx <- Context$new(getDefaultReactiveDomain(), '[isolate]', type='isolate')
   on.exit(ctx$invalidate())
   ctx$run(function() {
     expr
   })
 }
+
+#' Evaluate an expression without a reactive context
+#'
+#' Temporarily blocks the current reactive context and evaluates the given
+#' expression. Any attempt to directly access reactive values or expressions in
+#' \code{expr} will give the same results as doing it at the top-level (by
+#' default, an error).
+#'
+#' @param expr An expression to evaluate.
+#' @return The value of \code{expr}.
+#'
+#' @seealso \code{\link{isolate}}
+#'
+#' @export
+maskReactiveContext <- function(expr) {
+  .getReactiveEnvironment()$runWith(NULL, function() {
+    expr
+  })
+}

R/run-url.R

@@ -137,6 +137,8 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, port = NULL,
 
   message("Downloading ", url)
   filePath <- tempfile('shinyapp', fileext=fileext)
+  fileDir  <- tempfile('shinyapp')
+  dir.create(fileDir, showWarnings = FALSE)
   if (download(url, filePath, mode = "wb", quiet = TRUE) != 0)
     stop("Failed to download URL ", url)
   on.exit(unlink(filePath))
@@ -148,17 +150,18 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, port = NULL,
     #   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))
+    first <- untar2(filePath, list=TRUE)[1]
+    untar2(filePath, exdir = fileDir)
 
   } else if (fileext == ".zip") {
-    dirname <- as.character(unzip(filePath, list=TRUE)$Name[1])
-    unzip(filePath, exdir = dirname(filePath))
+    first <- as.character(unzip(filePath, list=TRUE)$Name)[1]
+    unzip(filePath, exdir = fileDir)
   }
+  on.exit(unlink(fileDir, recursive = TRUE), add = TRUE)
 
-  appdir <- file.path(dirname(filePath), dirname)
-  on.exit(unlink(appdir, recursive = TRUE), add = TRUE)
+  appdir <- file.path(fileDir, first)
+  if (!file_test('-d', appdir)) appdir <- dirname(appdir)
 
-  appsubdir <- ifelse(is.null(subdir), appdir, file.path(appdir, subdir))
-  runApp(appsubdir, port=port, launch.browser=launch.browser)
+  if (!is.null(subdir)) appdir <- file.path(appdir, subdir)
+  runApp(appdir, port=port, launch.browser=launch.browser)
 }

R/server.R

@@ -0,0 +1,801 @@
+#' @include globals.R
+
+appsByToken <- Map$new()
+
+# Create a map for input handlers and register the defaults.
+inputHandlers <- Map$new()
+
+#' Register an Input Handler
+#'
+#' Adds an input handler for data of this type. When called, Shiny will use the
+#' function provided to refine the data passed back from the client (after being
+#' deserialized by RJSONIO) before making it available in the \code{input}
+#' variable of the \code{server.R} file.
+#'
+#' This function will register the handler for the duration of the R process
+#' (unless Shiny is explicitly reloaded). For that reason, the \code{type} used
+#' should be very specific to this package to minimize the risk of colliding
+#' with another Shiny package which might use this data type name. We recommend
+#' the format of "packageName.widgetName".
+#'
+#' Currently Shiny registers the following handlers: \code{shiny.matrix},
+#' \code{shiny.number}, and \code{shiny.date}.
+#'
+#' The \code{type} of a custom Shiny Input widget will be deduced using the
+#' \code{getType()} JavaScript function on the registered Shiny inputBinding.
+#' @param type The type for which the handler should be added -- should be a
+#' single-element character vector.
+#' @param fun The handler function. This is the function that will be used to
+#'   parse the data delivered from the client before it is available in the
+#'   \code{input} variable. The function will be called with the following three
+#'   parameters:
+#'    \enumerate{
+#'      \item{The value of this input as provided by the client, deserialized
+#'      using RJSONIO.}
+#'      \item{The \code{shinysession} in which the input exists.}
+#'      \item{The name of the input.}
+#'    }
+#' @param force If \code{TRUE}, will overwrite any existing handler without
+#' warning. If \code{FALSE}, will throw an error if this class already has
+#' a handler defined.
+#' @examples
+#' \dontrun{
+#' # Register an input handler which rounds a input number to the nearest integer
+#' registerInputHandler("mypackage.validint", function(x, shinysession, name) {
+#'   if (is.null(x)) return(NA)
+#'   round(x)
+#' })
+#'
+#' ## On the Javascript side, the associated input binding must have a corresponding getType method:
+#' getType: function(el) {
+#'   return "mypackage.validint";
+#' }
+#'
+#' }
+#' @seealso \code{\link{removeInputHandler}}
+#' @export
+registerInputHandler <- function(type, fun, force=FALSE){
+  if (inputHandlers$containsKey(type) && !force){
+    stop("There is already an input handler for type: ", type)
+  }
+  inputHandlers$set(type, fun)
+}
+
+#' Deregister an Input Handler
+#'
+#' Removes an Input Handler. Rather than using the previously specified handler
+#' for data of this type, the default RJSONIO serialization will be used.
+#'
+#' @param type The type for which handlers should be removed.
+#' @return The handler previously associated with this \code{type}, if one
+#'   existed. Otherwise, \code{NULL}.
+#' @seealso \code{\link{registerInputHandler}}
+#' @export
+removeInputHandler <- function(type){
+  inputHandlers$remove(type)
+}
+
+# Takes a list-of-lists and returns a matrix. The lists
+# must all be the same length. NULL is replaced by NA.
+registerInputHandler("shiny.matrix", function(data, ...) {
+  if (length(data) == 0)
+    return(matrix(nrow=0, ncol=0))
+
+  m <- matrix(unlist(lapply(data, function(x) {
+    sapply(x, function(y) {
+      ifelse(is.null(y), NA, y)
+    })
+  })), nrow = length(data[[1]]), ncol = length(data))
+  return(m)
+})
+
+registerInputHandler("shiny.number", function(val, ...){
+  ifelse(is.null(val), NA, val)
+})
+
+registerInputHandler("shiny.date", function(val, ...){
+  # First replace NULLs with NA, then convert to Date vector
+  datelist <- ifelse(lapply(val, is.null), NA, val)
+  as.Date(unlist(datelist))
+})
+
+registerInputHandler("shiny.action", function(val, ...) {
+  # mark up the action button value with a special class so we can recognize it later
+  class(val) <- c(class(val), "shinyActionButtonValue")
+  val
+})
+
+# Provide a character representation of the WS that can be used
+# as a key in a Map.
+wsToKey <- function(WS) {
+  as.character(WS$socket)
+}
+
+.globals$clients <- function(req) NULL
+
+
+clearClients <- function() {
+  .globals$clients <- function(req) NULL
+}
+
+
+registerClient <- function(client) {
+  .globals$clients <- append(.globals$clients, client)
+}
+
+
+.globals$resources <- list()
+
+.globals$showcaseDefault <- 0
+
+.globals$showcaseOverride <- FALSE
+
+#' Resource Publishing
+#'
+#' Adds a directory of static resources to Shiny's web server, with the given
+#' path prefix. Primarily intended for package authors to make supporting
+#' JavaScript/CSS files available to their components.
+#'
+#' @param prefix The URL prefix (without slashes). Valid characters are a-z,
+#'   A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
+#'   For example, a value of 'foo' means that any request paths that begin with
+#'   '/foo' will be mapped to the given directory.
+#' @param directoryPath The directory that contains the static resources to be
+#'   served.
+#'
+#' @details You can call \code{addResourcePath} multiple times for a given
+#'   \code{prefix}; only the most recent value will be retained. If the
+#'   normalized \code{directoryPath} is different than the directory that's
+#'   currently mapped to the \code{prefix}, a warning will be issued.
+#'
+#' @seealso \code{\link{singleton}}
+#'
+#' @examples
+#' addResourcePath('datasets', system.file('data', package='datasets'))
+#'
+#' @export
+addResourcePath <- function(prefix, directoryPath) {
+  prefix <- prefix[1]
+  if (!grepl('^[a-z][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
+    stop("addResourcePath called with invalid prefix; please see documentation")
+  }
+
+  if (prefix %in% c('shared')) {
+    stop("addResourcePath called with the reserved prefix '", prefix, "'; ",
+         "please use a different prefix")
+  }
+
+  directoryPath <- normalizePath(directoryPath, mustWork=TRUE)
+
+  existing <- .globals$resources[[prefix]]
+
+  if (!is.null(existing)) {
+    if (!identical(existing$directoryPath, directoryPath)) {
+      warning("Overriding existing prefix ", prefix, " => ",
+              existing$directoryPath)
+    }
+  }
+
+  .globals$resources[[prefix]] <- list(directoryPath=directoryPath,
+                                       func=staticHandler(directoryPath))
+}
+
+resourcePathHandler <- function(req) {
+  if (!identical(req$REQUEST_METHOD, 'GET'))
+    return(NULL)
+
+  path <- req$PATH_INFO
+
+  match <- regexpr('^/([^/]+)/', path, perl=TRUE)
+  if (match == -1)
+    return(NULL)
+  len <- attr(match, 'capture.length')
+  prefix <- substr(path, 2, 2 + len - 1)
+
+  resInfo <- .globals$resources[[prefix]]
+  if (is.null(resInfo))
+    return(NULL)
+
+  suffix <- substr(path, 2 + len, nchar(path))
+
+  subreq <- as.environment(as.list(req, all.names=TRUE))
+  subreq$PATH_INFO <- suffix
+  subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, substr(path, 1, 2 + len), sep='')
+
+  return(resInfo$func(subreq))
+}
+
+#' Define Server Functionality
+#'
+#' Defines the server-side logic of the Shiny application. This generally
+#' involves creating functions that map user inputs to various kinds of output.
+#'
+#' @param func The server function for this application. See the details section
+#'   for more information.
+#'
+#' @details
+#' Call \code{shinyServer} from your application's \code{server.R} file, passing
+#' in a "server function" that provides the server-side logic of your
+#' application.
+#'
+#' The server function will be called when each client (web browser) first loads
+#' the Shiny application's page. It must take an \code{input} and an
+#' \code{output} parameter. Any return value will be ignored. It also takes an
+#' optional \code{session} parameter, which is used when greater control is
+#' needed.
+#'
+#' See the \href{http://rstudio.github.com/shiny/tutorial/}{tutorial} for more
+#' on how to write a server function.
+#'
+#' @examples
+#' \dontrun{
+#' # A very simple Shiny app that takes a message from the user
+#' # and outputs an uppercase version of it.
+#' shinyServer(function(input, output, session) {
+#'   output$uppercase <- renderText({
+#'     toupper(input$message)
+#'   })
+#' })
+#' }
+#'
+#' @export
+shinyServer <- function(func) {
+  .globals$server <- list(func)
+  invisible(func)
+}
+
+decodeMessage <- function(data) {
+  readInt <- function(pos) {
+    packBits(rawToBits(data[pos:(pos+3)]), type='integer')
+  }
+
+  if (readInt(1) != 0x01020202L)
+    return(fromJSON(rawToChar(data), asText=TRUE, simplify=FALSE))
+
+  i <- 5
+  parts <- list()
+  while (i <= length(data)) {
+    length <- readInt(i)
+    i <- i + 4
+    if (length != 0)
+      parts <- append(parts, list(data[i:(i+length-1)]))
+    else
+      parts <- append(parts, list(raw(0)))
+    i <- i + length
+  }
+
+  mainMessage <- decodeMessage(parts[[1]])
+  mainMessage$blobs <- parts[2:length(parts)]
+  return(mainMessage)
+}
+
+createAppHandlers <- function(httpHandlers, serverFuncSource) {
+  appvars <- new.env()
+  appvars$server <- NULL
+
+  sys.www.root <- system.file('www', package='shiny')
+
+  # This value, if non-NULL, must be present on all HTTP and WebSocket
+  # requests as the Shiny-Shared-Secret header or else access will be
+  # denied (403 response for HTTP, and instant close for websocket).
+  sharedSecret <- getOption('shiny.sharedSecret', NULL)
+
+  appHandlers <- list(
+    http = joinHandlers(c(
+      sessionHandler,
+      httpHandlers,
+      sys.www.root,
+      resourcePathHandler,
+      reactLogHandler)),
+    ws = function(ws) {
+      if (!is.null(sharedSecret)
+          && !identical(sharedSecret, ws$request$HTTP_SHINY_SHARED_SECRET)) {
+        ws$close()
+        return(TRUE)
+      }
+
+      shinysession <- ShinySession$new(ws)
+      appsByToken$set(shinysession$token, shinysession)
+      shinysession$setShowcase(.globals$showcaseDefault)
+
+      ws$onMessage(function(binary, msg) {
+        # To ease transition from websockets-based code. Should remove once we're stable.
+        if (is.character(msg))
+          msg <- charToRaw(msg)
+
+        if (getOption('shiny.trace', FALSE)) {
+          if (binary)
+            message("RECV ", '$$binary data$$')
+          else
+            message("RECV ", rawToChar(msg))
+        }
+
+        if (identical(charToRaw("\003\xe9"), msg))
+          return()
+
+        msg <- decodeMessage(msg)
+
+        # Do our own list simplifying here. sapply/simplify2array give names to
+        # character vectors, which is rarely what we want.
+        if (!is.null(msg$data)) {
+          for (name in names(msg$data)) {
+            val <- msg$data[[name]]
+
+            splitName <- strsplit(name, ':')[[1]]
+            if (length(splitName) > 1) {
+              msg$data[[name]] <- NULL
+
+              if (!inputHandlers$containsKey(splitName[[2]])){
+                # No input handler registered for this type
+                stop("No handler registered for for type ", name)
+              }
+
+              msg$data[[ splitName[[1]] ]] <-
+                  inputHandlers$get(splitName[[2]])(
+                      val,
+                      shinysession,
+                      splitName[[1]] )
+            }
+            else if (is.list(val) && is.null(names(val))) {
+              val_flat <- unlist(val, recursive = TRUE)
+
+              if (is.null(val_flat)) {
+                # This is to assign NULL instead of deleting the item
+                msg$data[name] <- list(NULL)
+              } else {
+                msg$data[[name]] <- val_flat
+              }
+            }
+          }
+        }
+
+        switch(
+          msg$method,
+          init = {
+
+            serverFunc <- serverFuncSource()
+            if (!identicalFunctionBodies(serverFunc, appvars$server)) {
+              appvars$server <- serverFunc
+              if (!is.null(appvars$server))
+              {
+                # Tag this function as the Shiny server function. A debugger may use this
+                # tag to give this function special treatment.
+                # It's very important that it's appvars$server itself and NOT a copy that
+                # is invoked, otherwise new breakpoints won't be picked up.
+                attr(appvars$server, "shinyServerFunction") <- TRUE
+                registerDebugHook("server", appvars, "Server Function")
+              }
+            }
+
+            # Check for switching into/out of showcase mode
+            if (.globals$showcaseOverride &&
+                exists(".clientdata_url_search", where = msg$data)) {
+              mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
+              if (!is.null(mode))
+                shinysession$setShowcase(mode)
+            }
+
+            shinysession$manageInputs(msg$data)
+
+            # The client tells us what singletons were rendered into
+            # the initial page
+            if (!is.null(msg$data$.clientdata_singletons)) {
+              shinysession$singletons <<- strsplit(
+                msg$data$.clientdata_singletons, ',')[[1]]
+            }
+
+            local({
+              args <- list(
+                input=shinysession$input,
+                output=.createOutputWriter(shinysession))
+
+              # The clientData and session arguments are optional; check if
+              # each exists
+              if ('clientData' %in% names(formals(serverFunc)))
+                args$clientData <- shinysession$clientData
+
+              if ('session' %in% names(formals(serverFunc)))
+                args$session <- shinysession$session
+
+              withReactiveDomain(shinysession$session, {
+                do.call(appvars$server, args)
+              })
+            })
+          },
+          update = {
+            shinysession$manageInputs(msg$data)
+          },
+          shinysession$dispatch(msg)
+        )
+        shinysession$manageHiddenOutputs()
+
+        if (exists(".shiny__stdout", globalenv()) &&
+            exists("HTTP_GUID", ws$request)) {
+          # safe to assume we're in shiny-server
+          shiny_stdout <- get(".shiny__stdout", globalenv())
+
+          # eNter a flushReact
+          writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
+                           " @ ", sprintf("%.3f", as.numeric(Sys.time())),
+                           sep=""), con=shiny_stdout)
+          flush(shiny_stdout)
+
+          flushReact()
+
+          # eXit a flushReact
+          writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
+                           " @ ", sprintf("%.3f", as.numeric(Sys.time())),
+                           sep=""), con=shiny_stdout)
+          flush(shiny_stdout)
+        } else {
+          flushReact()
+        }
+        lapply(appsByToken$values(), function(shinysession) {
+          shinysession$flushOutput()
+          NULL
+        })
+      })
+
+      ws$onClose(function() {
+        shinysession$close()
+        appsByToken$remove(shinysession$token)
+      })
+
+      return(TRUE)
+    }
+  )
+  return(appHandlers)
+}
+
+getEffectiveBody <- function(func) {
+  # Note: NULL values are OK. isS4(NULL) returns FALSE, body(NULL)
+  # returns NULL.
+  if (isS4(func) && class(func) == "functionWithTrace")
+    body(func@original)
+  else
+    body(func)
+}
+
+identicalFunctionBodies <- function(a, b) {
+  identical(getEffectiveBody(a), getEffectiveBody(b))
+}
+
+handlerManager <- HandlerManager$new()
+
+addSubApp <- function(appObj, autoRemove = TRUE) {
+  path <- createUniqueId(16, "/app")
+  appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource)
+
+  # remove the leading / from the path so a relative path is returned
+  # (needed for the case where the root URL for the Shiny app isn't /, such
+  # as portmapped URLs)
+  finalPath <- paste(
+    substr(path, 2, nchar(path)),
+    "/?w=", workerId(),
+    "&__subapp__=1",
+    sep="")
+  handlerManager$addHandler(routeHandler(path, appHandlers$http), finalPath)
+  handlerManager$addWSHandler(routeWSHandler(path, appHandlers$ws), finalPath)
+
+  if (autoRemove) {
+    # If a session is currently active, remove this subapp automatically when
+    # the current session ends
+    onReactiveDomainEnded(getDefaultReactiveDomain(), function() {
+      removeSubApp(finalPath)
+    })
+  }
+
+  return(finalPath)
+}
+
+removeSubApp <- function(path) {
+  handlerManager$removeHandler(path)
+  handlerManager$removeWSHandler(path)
+}
+
+startApp <- function(appObj, port, host, quiet) {
+  appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource)
+  handlerManager$addHandler(appHandlers$http, "/", tail = TRUE)
+  handlerManager$addWSHandler(appHandlers$ws, "/", tail = TRUE)
+
+  if (is.numeric(port) || is.integer(port)) {
+    if (!quiet) {
+      message('\n', 'Listening on http://', host, ':', port)
+    }
+    return(startServer(host, port, handlerManager$createHttpuvApp()))
+  } else if (is.character(port)) {
+    if (!quiet) {
+      message('\n', 'Listening on domain socket ', port)
+    }
+    mask <- attr(port, 'mask')
+    return(startPipeServer(port, mask, handlerManager$createHttpuvApp()))
+  }
+}
+
+# Run an application that was created by \code{\link{startApp}}. This
+# function should normally be called in a \code{while(TRUE)} loop.
+serviceApp <- function() {
+  if (timerCallbacks$executeElapsed()) {
+    for (shinysession in appsByToken$values()) {
+      shinysession$manageHiddenOutputs()
+    }
+
+    flushReact()
+
+    for (shinysession in appsByToken$values()) {
+      shinysession$flushOutput()
+    }
+  }
+
+  # If this R session is interactive, then call service() with a short timeout
+  # to keep the session responsive to user input
+  maxTimeout <- ifelse(interactive(), 100, 1000)
+
+  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent()))
+  service(timeout)
+}
+
+.shinyServerMinVersion <- '0.3.4'
+
+#' Run Shiny Application
+#'
+#' Runs a Shiny application. This function normally does not return; interrupt
+#' R to stop the application (usually by pressing Ctrl+C or Esc).
+#'
+#' The host parameter was introduced in Shiny 0.9.0. Its default value of
+#' \code{"127.0.0.1"} means that, contrary to previous versions of Shiny, only
+#' the current machine can access locally hosted Shiny apps. To allow other
+#' clients to connect, use the value \code{"0.0.0.0"} instead (which was the
+#' value that was hard-coded into Shiny in 0.8.0 and earlier).
+#'
+#' @param appDir The directory of the application. Should contain
+#'   \code{server.R}, plus, either \code{ui.R} or a \code{www} directory that
+#'   contains the file \code{index.html}. Defaults to the working directory.
+#' @param port The TCP port that the application should listen on. Defaults to
+#'   choosing a random port.
+#' @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. This value of this parameter can also be a
+#'   function to call with the application's URL.
+#' @param host The IPv4 address that the application should listen on. Defaults
+#'   to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not. See
+#'   Details.
+#' @param workerId Can generally be ignored. Exists to help some editions of
+#'   Shiny Server Pro route requests to the correct process.
+#' @param quiet Should Shiny status messages be shown? Defaults to FALSE.
+#' @param display.mode The mode in which to display the application. If set to
+#'   the value \code{"showcase"}, shows application code and metadata from a
+#'   \code{DESCRIPTION} file in the application directory alongside the
+#'   application. If set to \code{"normal"}, displays the application normally.
+#'   Defaults to \code{"auto"}, which displays the application in the mode
+#'   given in its \code{DESCRIPTION} file, if any.
+#'
+#' @examples
+#' \dontrun{
+#' # Start app in the current working directory
+#' runApp()
+#'
+#' # Start app in a subdirectory called myapp
+#' runApp("myapp")
+#'
+#'
+#' # Apps can be run without a server.r and ui.r file
+#' runApp(list(
+#'   ui = bootstrapPage(
+#'     numericInput('n', 'Number of obs', 100),
+#'     plotOutput('plot')
+#'   ),
+#'   server = function(input, output) {
+#'     output$plot <- renderPlot({ hist(runif(input$n)) })
+#'   }
+#' ))
+#' }
+#' @export
+runApp <- function(appDir=getwd(),
+                   port=NULL,
+                   launch.browser=getOption('shiny.launch.browser',
+                                            interactive()),
+                   host=getOption('shiny.host', '127.0.0.1'),
+                   workerId="", quiet=FALSE,
+                   display.mode=c("auto", "normal", "showcase")) {
+  on.exit({
+    handlerManager$clear()
+  }, add = TRUE)
+
+
+  if (is.null(host) || is.na(host))
+    host <- '0.0.0.0'
+
+  # Make warnings print immediately
+  ops <- options(warn = 1)
+  on.exit(options(ops), add = TRUE)
+
+  workerId(workerId)
+
+  if (nzchar(Sys.getenv('SHINY_PORT'))) {
+    # If SHINY_PORT is set, we're running under Shiny Server. Check the version
+    # to make sure it is compatible. Older versions of Shiny Server don't set
+    # SHINY_SERVER_VERSION, those will return "" which is considered less than
+    # any valid version.
+    ver <- Sys.getenv('SHINY_SERVER_VERSION')
+    if (compareVersion(ver, .shinyServerMinVersion) < 0) {
+      warning('Shiny Server v', .shinyServerMinVersion,
+              ' or later is required; please upgrade!')
+    }
+  }
+
+  # Showcase mode is disabled by default; it must be explicitly enabled in
+  # either the DESCRIPTION file for directory-based apps, or via
+  # the display.mode parameter. The latter takes precedence.
+  setShowcaseDefault(0)
+
+  # If appDir specifies a path, and display mode is specified in the
+  # DESCRIPTION file at that path, apply it here.
+  if (is.character(appDir)) {
+    desc <- file.path.ci(appDir, "DESCRIPTION")
+    if (file.exists(desc)) {
+      settings <- read.dcf(desc)
+      if ("DisplayMode" %in% colnames(settings)) {
+        mode <- settings[1,"DisplayMode"]
+        if (mode == "Showcase") {
+          setShowcaseDefault(1)
+        }
+      }
+    }
+  }
+
+  # If display mode is specified as an argument, apply it (overriding the
+  # value specified in DESCRIPTION, if any).
+  display.mode <- match.arg(display.mode)
+  if (display.mode == "normal")
+    setShowcaseDefault(0)
+  else if (display.mode == "showcase")
+    setShowcaseDefault(1)
+
+  require(shiny)
+
+  # determine port if we need to
+  if (is.null(port)) {
+
+    # Try up to 20 random ports. If we don't succeed just plow ahead
+    # with the final value we tried, and let the "real" startServer
+    # somewhere down the line fail and throw the error to the user.
+    #
+    # If we (think we) succeed, save the value as .globals$lastPort,
+    # and try that first next time the user wants a random port.
+
+    for (i in 1:20) {
+      if (!is.null(.globals$lastPort)) {
+        port <- .globals$lastPort
+        .globals$lastPort <- NULL
+      }
+      else {
+        # Try up to 20 random ports
+        port <- p_randomInt(3000, 8000)
+      }
+
+      # Test port to see if we can use it
+      tmp <- try(startServer(host, port, list()), silent=TRUE)
+      if (!inherits(tmp, 'try-error')) {
+        stopServer(tmp)
+        .globals$lastPort <- port
+        break
+      }
+    }
+  }
+
+  appParts <- as.shiny.appobj(appDir)
+  if (!is.null(appParts$onStart))
+    appParts$onStart()
+  if (!is.null(appParts$onEnd))
+    on.exit(appParts$onEnd(), add = TRUE)
+
+  server <- startApp(appParts, port, host, quiet)
+
+  on.exit({
+    stopServer(server)
+  }, add = TRUE)
+
+  if (!is.character(port)) {
+    # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
+    browseHost <- if (identical(host, "0.0.0.0")) "127.0.0.1" else host
+
+    appUrl <- paste("http://", browseHost, ":", port, sep="")
+    if (is.function(launch.browser))
+      launch.browser(appUrl)
+    else if (launch.browser)
+      utils::browseURL(appUrl)
+  } else {
+    appUrl <- NULL
+  }
+
+  # call application hooks
+  callAppHook("onAppStart", appUrl)
+  on.exit({
+    callAppHook("onAppStop", appUrl)
+  }, add = TRUE)
+
+  .globals$retval <- NULL
+  .globals$stopped <- FALSE
+  shinyCallingHandlers(
+    while (!.globals$stopped) {
+      serviceApp()
+      Sys.sleep(0.001)
+    }
+  )
+
+  return(.globals$retval)
+}
+
+#' Stop the currently running Shiny app
+#'
+#' Stops the currently running Shiny app, returning control to the caller of
+#' \code{\link{runApp}}.
+#'
+#' @param returnValue The value that should be returned from
+#'   \code{\link{runApp}}.
+#'
+#' @export
+stopApp <- function(returnValue = NULL) {
+  .globals$retval <- returnValue
+  .globals$stopped <- TRUE
+  httpuv::interrupt()
+}
+
+#' Run Shiny Example Applications
+#'
+#' Launch Shiny example applications, and optionally, your system's web browser.
+#'
+#' @param example The name of the example to run, or \code{NA} (the default) to
+#'   list the available examples.
+#' @param port The TCP port that the application should listen on. Defaults to
+#'   choosing a random port.
+#' @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.
+#' @param host The IPv4 address that the application should listen on. Defaults
+#'   to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not.
+#' @param display.mode The mode in which to display the example. Defaults to
+#'   \code{showcase}, but may be set to \code{normal} to see the example without
+#'   code or commentary.
+#'
+#' @examples
+#' \dontrun{
+#' # List all available examples
+#' runExample()
+#'
+#' # Run one of the examples
+#' runExample("01_hello")
+#'
+#' # Print the directory containing the code for all examples
+#' system.file("examples", package="shiny")
+#' }
+#' @export
+runExample <- function(example=NA,
+                       port=NULL,
+                       launch.browser=getOption('shiny.launch.browser',
+                                                interactive()),
+                       host=getOption('shiny.host', '127.0.0.1'),
+                       display.mode=c("auto", "normal", "showcase")) {
+  examplesDir <- system.file('examples', package='shiny')
+  dir <- resolve(examplesDir, example)
+  if (is.null(dir)) {
+    if (is.na(example)) {
+      errFun <- message
+      errMsg <- ''
+    }
+    else {
+      errFun <- stop
+      errMsg <- paste('Example', example, 'does not exist. ')
+    }
+
+    errFun(errMsg,
+           'Valid examples are "',
+           paste(list.files(examplesDir), collapse='", "'),
+           '"')
+  }
+  else {
+    runApp(dir, port = port, host = host, launch.browser = launch.browser,
+           display.mode = display.mode)
+  }
+}

R/sessioncontext.R

@@ -1,20 +0,0 @@
-# Keeps the context associated with a ShinySession reference object for the
-# duration of a request. Used to emit reactive evaluation information to the
-# appropriate session when showcase mode is enabled.
-
-.sessionContext <- new.env(parent=emptyenv())
-.beginShowcaseSessionContext <- function(session) {
-  assign("session", session, envir = .sessionContext)
-}
-
-.endShowcaseSessionContext <- function() {
-  if (exists("session", where = .sessionContext))
-    remove("session", envir = .sessionContext)
-}
-
-.getShowcaseSessionContext <- function() {
-  if (exists("session", where = .sessionContext))
-    .sessionContext$session
-  else
-    NULL
-}

R/shinyui.R

@@ -1,142 +1,5 @@
-#' @rdname builder
-#' @export
-p <- function(...) tags$p(...)
-
-#' @rdname builder
-#' @export
-h1 <- function(...) tags$h1(...)
-
-#' @rdname builder
-#' @export
-h2 <- function(...) tags$h2(...)
-
-#' @rdname builder
-#' @export
-h3 <- function(...) tags$h3(...)
-
-#' @rdname builder
-#' @export
-h4 <- function(...) tags$h4(...)
-
-#' @rdname builder
-#' @export
-h5 <- function(...) tags$h5(...)
-
-#' @rdname builder
-#' @export
-h6 <- function(...) tags$h6(...)
-
-#' @rdname builder
-#' @export
-a <- function(...) tags$a(...)
-
-#' @rdname builder
-#' @export
-br <- function(...) tags$br(...)
-
-#' @rdname builder
-#' @export
-div <- function(...) tags$div(...)
-
-#' @rdname builder
-#' @export
-span <- function(...) tags$span(...)
-
-#' @rdname builder
-#' @export
-pre <- function(...) tags$pre(...)
-
-#' @rdname builder
-#' @export
-code <- function(...) tags$code(...)
-
-#' @rdname builder
-#' @export
-img <- function(...) tags$img(...)
-
-#' @rdname builder
-#' @export
-strong <- function(...) tags$strong(...)
-
-#' @rdname builder
-#' @export
-em <- function(...) tags$em(...)
-
-#' @rdname builder
-#' @export
-hr <- function(...) tags$hr(...)
-
-#' 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
-#' @name include
-#' @aliases includeHTML
-#' @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 globals.R
+NULL
 
 #' Load the MathJax library and typeset math expressions
 #'
@@ -154,51 +17,49 @@ withMathJax <- function(...) {
   path <- 'https://c328740.ssl.cf1.rackcdn.com/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
   tagList(
     tags$head(
-      singleton(tags$script(HTML('window.MathJax = {skipStartupTypeset: true};'))),
       singleton(tags$script(src = path, type = 'text/javascript'))
     ),
     ...,
-    tags$script(HTML('$(function() {
-                        setTimeout(function() {MathJax.Hub.Typeset();}, 200);
-                      });'))
+    tags$script(HTML('MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
   )
 }
 
-#' Include Content Only Once
-#'
-#' Use \code{singleton} to wrap contents (tag, text, HTML, or lists) that should
-#' be included in the generated document only once, yet may appear in the
-#' document-generating code more than once. Only the first appearance of the
-#' content (in document order) will be used. Useful for custom components that
-#' have JavaScript files or stylesheets.
-#'
-#' @param x A \code{\link{tag}}, text, \code{\link{HTML}}, or list.
-#'
-#' @export
-singleton <- function(x) {
-  class(x) <- c(class(x), 'shiny.singleton')
-  return(x)
-}
-
 renderPage <- function(ui, connection, showcase=0) {
 
+  if (showcase > 0)
+    ui <- tagList(tags$head(showcaseHead()), ui)
+
   result <- renderTags(ui)
 
+  deps <- c(
+    list(
+      htmlDependency("jquery", "1.11.0", c(href="shared"), script = "jquery.js"),
+      htmlDependency("shiny", packageVersion("shiny"), c(href="shared"),
+        script = "shiny.js", stylesheet = "shiny.css")
+    ),
+    result$dependencies
+  )
+  deps <- resolveDependencies(deps)
+  deps <- lapply(deps, createWebDependency)
+  depStr <- paste(sapply(deps, function(dep) {
+    sprintf("%s[%s]", dep$name, dep$version)
+  }), collapse = ";")
+  depHtml <- renderDependencies(deps, "href")
+
   # write preamble
   writeLines(c('<!DOCTYPE html>',
                '<html>',
                '<head>',
                '  <meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>',
-               '  <script src="shared/jquery.js" type="text/javascript"></script>',
-               '  <script src="shared/shiny.js" type="text/javascript"></script>',
-               '  <link rel="stylesheet" type="text/css" href="shared/shiny.css"/>',
                sprintf('  <script type="application/shiny-singletons">%s</script>',
                        paste(result$singletons, collapse = ',')
-               )),
+               ),
+               sprintf('  <script type="application/html-dependencies">%s</script>',
+                       depStr
+               ),
+               depHtml
+              ),
               con = connection)
-  if (showcase > 0) {
-    writeLines(as.character(showcaseHead()), con = connection)
-  }
   writeLines(c(result$head,
                '</head>',
                '<body>',
@@ -222,67 +83,51 @@ renderPage <- function(ui, connection, showcase=0) {
 
 #' Create a Shiny UI handler
 #'
-#' Register a UI handler by providing a UI definition (created with e.g.
-#' \link{pageWithSidebar}) and web server path (typically "/", the default
-#' value).
+#' Historically this function was used in ui.R files to register a user
+#' interface with Shiny. It is no longer required; simply ensure that the last
+#' expression to be returned from ui.R is a user interface. This function is
+#' kept for backwards compatibility with older applications. It returns the
+#' value that is passed to it.
 #'
-#' @param ui A user-interace definition
-#' @param path The web server path to server the UI from
-#' @return Called for its side-effect of registering a UI handler
-#'
-#' @examples
-#' el <- div(HTML("I like <u>turtles</u>"))
-#' cat(as.character(el))
-#'
-#' @examples
-#' # Define UI
-#' shinyUI(pageWithSidebar(
-#'
-#'   # Application title
-#'   headerPanel("Hello Shiny!"),
-#'
-#'   # Sidebar with a slider input
-#'   sidebarPanel(
-#'     sliderInput("obs",
-#'                 "Number of observations:",
-#'                 min = 0,
-#'                 max = 1000,
-#'                 value = 500)
-#'   ),
-#'
-#'   # Show a plot of the generated distribution
-#'   mainPanel(
-#'     plotOutput("distPlot")
-#'   )
-#' ))
+#' @param ui A user interace definition
+#' @return The user interface definition, without modifications or side effects.
 #'
 #' @export
-shinyUI <- function(ui, path='/') {
+shinyUI <- function(ui) {
+  .globals$ui <- list(ui)
+  ui
+}
+
+uiHttpHandler <- function(ui, path = "/") {
 
   force(ui)
 
-  registerClient({
+  function(req) {
+    if (!identical(req$REQUEST_METHOD, 'GET'))
+      return(NULL)
 
-    function(req) {
-      if (!identical(req$REQUEST_METHOD, 'GET'))
-        return(NULL)
+    if (req$PATH_INFO != path)
+      return(NULL)
 
-      if (req$PATH_INFO != path)
-        return(NULL)
+    textConn <- textConnection(NULL, "w")
+    on.exit(close(textConn))
 
-      textConn <- textConnection(NULL, "w")
-      on.exit(close(textConn))
-
-      showcaseMode <- .globals$showcaseDefault
-      if (.globals$showcaseOverride) {
-        mode <- showcaseModeOfReq(req)
-        if (!is.null(mode))
-          showcaseMode <- mode
-      }
-      renderPage(ui, textConn, showcaseMode)
-      html <- paste(textConnectionValue(textConn), collapse='\n')
-      return(httpResponse(200, content=html))
+    showcaseMode <- .globals$showcaseDefault
+    if (.globals$showcaseOverride) {
+      mode <- showcaseModeOfReq(req)
+      if (!is.null(mode))
+        showcaseMode <- mode
     }
-  })
+    uiValue <- if (is.function(ui)) {
+      if (length(formals(ui)) > 0)
+        ui(req)
+      else
+        ui()
+    }
+    else
+      ui
+    renderPage(uiValue, textConn, showcaseMode)
+    html <- paste(textConnectionValue(textConn), collapse='\n')
+    return(httpResponse(200, content=html))
+  }
 }
-

R/shinywrappers.R

@@ -1,5 +1,40 @@
 globalVariables('func')
 
+#' Mark a function as a render function
+#'
+#' Should be called by implementers of \code{renderXXX} functions in order to
+#' mark their return values as Shiny render functions, and to provide a hint to
+#' Shiny regarding what UI function is most commonly used with this type of
+#' render function. This can be used in R Markdown documents to create complete
+#' output widgets out of just the render function.
+#'
+#' @param uiFunc A function that renders Shiny UI. Must take a single argument:
+#'   an output ID.
+#' @param renderFunc A function that is suitable for assigning to a Shiny output
+#'   slot.
+#' @return The \code{renderFunc} function, with annotations.
+#'
+#' @export
+markRenderFunction <- function(uiFunc, renderFunc) {
+  class(renderFunc) <- c("shiny.render.function", "function")
+  attr(renderFunc, "outputFunc") <- uiFunc
+  renderFunc
+}
+
+useRenderFunction <- function(renderFunc) {
+  outputFunction <- attr(renderFunc, "outputFunc")
+  id <- createUniqueId(8, "out")
+  o <- getDefaultReactiveDomain()$output
+  if (!is.null(o))
+    o[[id]] <- renderFunc
+  return(outputFunction(id))
+}
+
+#' @S3method as.tags shiny.render.function
+as.tags.shiny.render.function <- function(x, ...) {
+  useRenderFunction(x)
+}
+
 #' Plot Output
 #'
 #' Renders a reactive plot that is suitable for assigning to an \code{output}
@@ -54,7 +89,16 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   else
     heightWrapper <- NULL
 
-  return(function(shinysession, name, ...) {
+  # If renderPlot isn't going to adapt to the height of the div, then the
+  # div needs to adapt to the height of renderPlot. By default, plotOutput
+  # sets the height to 400px, so to make it adapt we need to override it
+  # with NULL.
+  outputFunc <- if (identical(height, 'auto'))
+    plotOutput
+  else
+    function(outputId) plotOutput(outputId, height = NULL)
+
+  return(markRenderFunction(outputFunc, function(shinysession, name, ...) {
     if (!is.null(widthWrapper))
       width <- widthWrapper()
     if (!is.null(heightWrapper))
@@ -80,7 +124,12 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
     coordmap <- NULL
     plotFunc <- function() {
       # Actually perform the plotting
-      func()
+      result <- withVisible(func())
+      if (result$visible) {
+        # Use capture.output to squelch printing to the actual console; we
+        # are only interested in plot output
+        capture.output(print(result$value))
+      }
 
       # Now capture some graphics device info before we close it
       usrCoords <- par('usr')
@@ -123,7 +172,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
       src=shinysession$fileUrl(name, outfile, contentType='image/png'),
       width=width, height=height, coordmap=coordmap
     ))
-  })
+  }))
 }
 
 #' Image file output
@@ -218,7 +267,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
                         deleteFile=TRUE) {
   installExprFunction(expr, "func", env, quoted)
 
-  return(function(shinysession, name, ...) {
+  return(markRenderFunction(imageOutput, 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.
@@ -239,7 +288,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
     # Return a list with src, and other img attributes
     c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
       extra_attr)
-  })
+  }))
 }
 
 
@@ -269,7 +318,7 @@ renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL)
     installExprFunction(expr, "func", env, quoted)
   }
 
-  function() {
+  markRenderFunction(tableOutput, function() {
     classNames <- getOption('shiny.table.class', 'data table table-bordered table-condensed')
     data <- func()
 
@@ -285,7 +334,7 @@ renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL)
                                           '"',
                                           sep=''), ...)),
       collapse="\n"))
-  }
+  })
 }
 
 #' Printable Output
@@ -312,27 +361,26 @@ renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL)
 #' @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).
-#'
+#' @param width The value for \code{\link{options}('width')}.
 #' @seealso \code{\link{renderText}} for displaying the value returned from a
 #'   function, instead of the printed output.
 #'
 #' @example res/text-example.R
 #'
 #' @export
-renderPrint <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
+renderPrint <- function(expr, env = parent.frame(), quoted = FALSE, func = NULL,
+                        width = getOption('width')) {
   if (!is.null(func)) {
     shinyDeprecated(msg="renderPrint: argument 'func' is deprecated. Please use 'expr' instead.")
   } else {
     installExprFunction(expr, "func", env, quoted)
   }
 
-  function() {
-    return(paste(capture.output({
-      result <- withVisible(func())
-      if (result$visible)
-        print(result$value)
-    }), collapse="\n"))
-  }
+  markRenderFunction(verbatimTextOutput, function() {
+    op <- options(width = width)
+    on.exit(options(op), add = TRUE)
+    paste(capture.output(func()), collapse = "\n")
+  })
 }
 
 #' Text Output
@@ -369,10 +417,10 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
     installExprFunction(expr, "func", env, quoted)
   }
 
-  function() {
+  markRenderFunction(textOutput, function() {
     value <- func()
     return(paste(capture.output(cat(value)), collapse="\n"))
-  }
+  })
 }
 
 #' UI Output
@@ -409,19 +457,25 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
     installExprFunction(expr, "func", env, quoted)
   }
 
-  function(shinysession, name, ...) {
+  markRenderFunction(uiOutput, function(shinysession, name, ...) {
     result <- func()
     if (is.null(result) || length(result) == 0)
       return(NULL)
 
     result <- takeSingletons(result, shinysession$singletons, desingleton=FALSE)$ui
     result <- surroundSingletons(result)
+    dependencies <- lapply(resolveDependencies(findDependencies(result)),
+      createWebDependency)
+    names(dependencies) <- NULL
 
     # renderTags returns a list with head, singletons, and html
-    output <- doRenderTags(result)
+    output <- list(
+      html = doRenderTags(result),
+      deps = dependencies
+    )
 
     return(output)
-  }
+  })
 }
 
 #' File Downloads
@@ -466,9 +520,9 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
 #'
 #' @export
 downloadHandler <- function(filename, content, contentType=NA) {
-  return(function(shinysession, name, ...) {
+  return(markRenderFunction(downloadButton, function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
-  })
+  }))
 }
 
 #' Table output with the JavaScript library DataTables
@@ -506,17 +560,17 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
                             env = parent.frame(), quoted = FALSE) {
   installExprFunction(expr, "func", env, quoted)
 
-  function(shinysession, name, ...) {
+  markRenderFunction(dataTableOutput, function(shinysession, name, ...) {
     res <- checkAsIs(if (is.function(options)) options() else options)
     data <- func()
     if (length(dim(data)) != 2) return() # expects a rectangular data object
-    action <- shinysession$registerDataTable(name, data)
+    action <- shinysession$registerDataObj(name, data, dataTablesJSON)
     list(
       colnames = colnames(data), action = action, options = res$options,
       evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
       callback = paste(callback, collapse = '\n')
     )
-  }
+  })
 }
 
 

R/showcase.R

@@ -1,3 +1,5 @@
+#' @include globals.R
+NULL
 
 # Given the name of a license, return the appropriate link HTML for the
 # license, which may just be the name of the license if the name is
@@ -27,23 +29,32 @@ licenseLink <- function(licenseName) {
 # Returns tags containing showcase directives intended for the <HEAD> of the
 # document.
 showcaseHead <- function() {
+
+  deps  <- list(
+    htmlDependency("jqueryui", "1.10.4", c(href="shared/jqueryui/1.10.4"),
+      script = "jquery-ui.min.js"),
+    htmlDependency("showdown", "0.3.1", c(href="shared/showdown/compressed"),
+      script = "showdown.js"),
+    htmlDependency("font-awesome", "4.0.3", c(href="shared/font-awesome"),
+      stylesheet = "css/font-awesome.min.css"),
+    htmlDependency("highlight.js", "6.2", c(href="shared/highlight"),
+      script = "highlight.pack.js")
+  )
+
   mdfile <- file.path.ci(getwd(), 'Readme.md')
-  with(tags, tagList(
-    script(src="shared/highlight/highlight.pack.js"),
-    script(src="shared/showdown/compressed/showdown.js"),
-    script(src="shared/jqueryui/1.10.3/jquery-ui.min.js"),
+  html <- with(tags, tagList(
     script(src="shared/shiny-showcase.js"),
     link(rel="stylesheet", type="text/css",
          href="shared/highlight/rstudio.css"),
     link(rel="stylesheet", type="text/css",
          href="shared/shiny-showcase.css"),
-    link(rel="stylesheet", type="text/css",
-         href="shared/font-awesome/css/font-awesome.min.css"),
     if (file.exists(mdfile))
       script(type="text/markdown", id="showcase-markdown-content",
-        paste(readLines(mdfile), collapse="\n"))
+        paste(readLines(mdfile, warn = FALSE), collapse="\n"))
     else ""
   ))
+
+  return(attachDependencies(html, deps))
 }
 
 # Returns tags containing the application metadata (title and author) in
@@ -95,7 +106,7 @@ showcaseCodeTabs <- function(codeLicense) {
                   # we need to prevent the indentation of <code> ... </code>
                   HTML(format(tags$code(
                     class="language-r",
-                    paste(readLines(file.path.ci(getwd(), rFile)),
+                    paste(readLines(file.path.ci(getwd(), rFile), warn=FALSE),
                           collapse="\n")
                   ), indent = FALSE))))
         })),

R/slider.R

@@ -33,7 +33,7 @@ animationOptions <- function(interval=1000,
 # (www/shared/slider contains js, css, and img dependencies)
 slider <- function(inputId, min, max, value, step = NULL, ...,
                    round=FALSE, format='#,##0.#####', locale='us',
-                   ticks=TRUE, animate=FALSE) {
+                   ticks=TRUE, animate=FALSE, width=NULL) {
   # validate inputId
   inputId <- as.character(inputId)
   if (!is.character(inputId))
@@ -99,21 +99,22 @@ slider <- function(inputId, min, max, value, step = NULL, ...,
   }
 
   # build slider
+  dep <- htmlDependency("jslider", "1", c(href="shared/slider"),
+    script = "js/jquery.slider.min.js",
+    stylesheet = "css/jquery.slider.min.css"
+  )
   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
+    attachDependencies(
+      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,
+        'data-width'=validateCssUnit(width)
+      ),
+      dep
     )
   )
 
@@ -137,5 +138,5 @@ slider <- function(inputId, min, max, value, step = NULL, ...,
                       tags$span(class='pause', animate$pauseButton)))
   }
 
-  return(sliderFragment)
+  return(tagList(sliderFragment))
 }

R/tags.R

@@ -1,616 +0,0 @@
-
-
-htmlEscape <- local({
-  .htmlSpecials <- list(
-    `&` = '&amp;',
-    `<` = '&lt;',
-    `>` = '&gt;'
-  )
-  .htmlSpecialsPattern <- paste(names(.htmlSpecials), collapse='|')
-  .htmlSpecialsAttrib <- c(
-    .htmlSpecials,
-    `'` = '&#39;',
-    `"` = '&quot;',
-    `\r` = '&#13;',
-    `\n` = '&#10;'
-  )
-  .htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse='|')
-
-  function(text, attribute=TRUE) {
-    pattern <- if(attribute)
-      .htmlSpecialsPatternAttrib
-    else
-      .htmlSpecialsPattern
-
-    # Short circuit in the common case that there's nothing to escape
-    if (!grepl(pattern, text))
-      return(text)
-
-    specials <- if(attribute)
-      .htmlSpecialsAttrib
-    else
-      .htmlSpecials
-
-    for (chr in names(specials)) {
-      text <- gsub(chr, specials[[chr]], text, fixed=TRUE)
-    }
-
-    return(text)
-  }
-})
-
-isTag <- function(x) {
-  inherits(x, "shiny.tag")
-}
-
-#' @S3method print shiny.tag
-print.shiny.tag <- function(x, ...) {
-  print(as.character(x), ...)
-  invisible(x)
-}
-
-# indent can be numeric to indicate an initial indent level,
-# or FALSE to suppress
-#' @S3method format shiny.tag
-format.shiny.tag <- function(x, ..., singletons = character(0), indent = 0) {
-  as.character(renderTags(x, singletons = singletons, indent = indent)$html)
-}
-
-#' @S3method as.character shiny.tag
-as.character.shiny.tag <- function(x, ...) {
-  renderTags(x)$html
-}
-
-#' @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
-
-#' @S3method print html
-print.html <- function(x, ...) {
-  cat(x, "\n")
-  invisible(x)
-}
-
-#' @S3method format html
-format.html <- function(x, ...) {
-  as.character(x)
-}
-
-normalizeText <- function(text) {
-  if (!is.null(attr(text, "html")))
-    text
-  else
-    htmlEscape(text, attribute=FALSE)
-
-}
-
-#' @rdname tag
-#' @export
-tagList <- function(...) {
-  lst <- list(...)
-  class(lst) <- c("shiny.tag.list", "list")
-  return(lst)
-}
-
-#' @rdname tag
-#' @export
-tagAppendAttributes <- function(tag, ...) {
-  tag$attribs <- c(tag$attribs, list(...))
-  tag
-}
-
-#' @rdname tag
-#' @export
-tagAppendChild <- function(tag, child) {
-  tag$children[[length(tag$children)+1]] <- child
-  tag
-}
-
-#' @rdname tag
-#' @export
-tagAppendChildren <- function(tag, ..., list = NULL) {
-  tag$children <- c(tag$children, c(list(...), list))
-  tag
-}
-
-#' @rdname tag
-#' @export
-tagSetChildren <- function(tag, ..., list = NULL) {
-  tag$children <- c(list(...), list)
-  tag
-}
-
-#' HTML Tag Object
-#'
-#' \code{tag()} creates an HTML tag definition. Note that all of the valid HTML5
-#' tags are already defined in the \code{\link{tags}} environment so these
-#' functions should only be used to generate additional tags.
-#' \code{tagAppendChild()} and \code{tagList()} are for supporting package
-#' authors who wish to create their own sets of tags; see the contents of
-#' bootstrap.R for examples.
-#' @param _tag_name HTML tag name
-#' @param varArgs List of attributes and children of the element. Named list
-#'   items become attributes, and unnamed list items become children. Valid
-#'   children are tags, single-character character vectors (which become text
-#'   nodes), and raw HTML (see \code{\link{HTML}}). You can also pass lists that
-#'   contain tags, text nodes, and HTML.
-#' @param tag A tag to append child elements to.
-#' @param child A child element to append to a parent tag.
-#' @param ...  Unnamed items that comprise this list of tags.
-#' @param list An optional list of elements. Can be used with or instead of the
-#'   \code{...} items.
-#' @return An HTML tag object that can be rendered as HTML using
-#'   \code{\link{as.character}()}.
-#' @export
-#' @examples
-#' tagList(tags$h1("Title"),
-#'         tags$h2("Header text"),
-#'         tags$p("Text here"))
-#'
-#' # Can also convert a regular list to a tagList (internal data structure isn't
-#' # exactly the same, but when rendered to HTML, the output is the same).
-#' x <- list(tags$h1("Title"),
-#'           tags$h2("Header text"),
-#'           tags$p("Text here"))
-#' tagList(x)
-tag <- function(`_tag_name`, 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])
-
-  # 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 <- unname(varArgs[!named_idx])
-
-  # Return tag data structure
-  structure(
-    list(name = `_tag_name`,
-         attribs = attribs,
-         children = children),
-    class = "shiny.tag"
-  )
-}
-
-tagWrite <- function(tag, textWriter, indent=0, eol = "\n") {
-
-  if (length(tag) == 0)
-    return (NULL)
-
-  # optionally process a list of tags
-  if (!isTag(tag) && is.list(tag)) {
-    tag <- dropNullsOrEmpty(flattenTags(tag))
-    lapply(tag, tagWrite, textWriter, indent)
-    return (NULL)
-  }
-
-  nextIndent <- if (is.numeric(indent)) indent + 1 else indent
-  indent <- if (is.numeric(indent)) indent else 0
-
-  # compute indent text
-  indentText <- paste(rep(" ", indent*2), collapse="")
-
-  # Check if it's just text (may either be plain-text or HTML)
-  if (is.character(tag)) {
-    textWriter(paste(indentText, normalizeText(tag), eol, sep=""))
-    return (NULL)
-  }
-
-  # write tag name
-  textWriter(paste(indentText, "<", tag$name, sep=""))
-
-  # Convert all attribs to chars explicitly; prevents us from messing up factors
-  attribs <- lapply(tag$attribs, as.character)
-  # concatenate attributes
-  # split() is very slow, so avoid it if possible
-  if (anyDuplicated(names(attribs)))
-    attribs <- lapply(split(attribs, names(attribs)), paste, collapse = " ")
-
-  # write attributes
-  for (attrib in names(attribs)) {
-    attribValue <- attribs[[attrib]]
-    if (!is.na(attribValue)) {
-      if (is.logical(attribValue))
-        attribValue <- tolower(attribValue)
-      text <- htmlEscape(attribValue, attribute=TRUE)
-      textWriter(paste(" ", attrib,"=\"", text, "\"", sep=""))
-    }
-    else {
-      textWriter(paste(" ", attrib, sep=""))
-    }
-  }
-
-  # write any children
-  children <- dropNullsOrEmpty(flattenTags(tag$children))
-  if (length(children) > 0) {
-    textWriter(">")
-
-    # special case for a single child text node (skip newlines and indentation)
-    if ((length(children) == 1) && is.character(children[[1]]) ) {
-      textWriter(paste(normalizeText(children[[1]]), "</", tag$name, ">", eol,
-        sep=""))
-    }
-    else {
-      textWriter("\n")
-      for (child in children)
-        tagWrite(child, textWriter, nextIndent)
-      textWriter(paste(indentText, "</", tag$name, ">", eol, sep=""))
-    }
-  }
-  else {
-    # only self-close void elements
-    # (see: http://dev.w3.org/html5/spec/single-page.html#void-elements)
-    if (tag$name %in% c("area", "base", "br", "col", "command", "embed", "hr",
-                        "img", "input", "keygen", "link", "meta", "param",
-                        "source", "track", "wbr")) {
-      textWriter(paste("/>", eol, sep=""))
-    }
-    else {
-      textWriter(paste("></", tag$name, ">", eol, sep=""))
-    }
-  }
-}
-
-doRenderTags <- function(ui, indent = 0) {
-  # Render the body--the bodyHtml variable will be created
-  conn <- file(open="w+")
-  connWriter <- function(text) writeChar(text, conn, eos = NULL)
-  htmlResult <- tryCatch({
-    tagWrite(ui, connWriter, indent)
-    flush(conn)
-    readLines(conn)
-  },
-    finally = close(conn)
-  )
-  return(HTML(paste(htmlResult, collapse = "\n")))
-}
-
-renderTags <- function(ui, singletons = character(0), indent = 0) {
-  # Do singleton and head processing before rendering
-  singletonInfo <- takeSingletons(ui, singletons)
-  headInfo <- takeHeads(singletonInfo$ui)
-
-  headIndent <- if (is.numeric(indent)) indent + 1 else indent
-  headHtml <- doRenderTags(headInfo$head, indent = headIndent)
-  bodyHtml <- doRenderTags(headInfo$ui, indent = indent)
-
-  return(list(head = headHtml,
-              singletons = singletonInfo$singletons,
-              html = bodyHtml))
-}
-
-# Walk a tree of tag objects, rewriting objects according to func.
-# preorder=TRUE means preorder tree traversal, that is, an object
-# should be rewritten before its children.
-rewriteTags <- function(ui, func, preorder) {
-  if (preorder)
-    ui <- func(ui)
-
-  if (isTag(ui)) {
-    ui$children[] <- lapply(ui$children, rewriteTags, func, preorder)
-  } else if (is.list(ui)) {
-    ui[] <- lapply(ui, rewriteTags, func, preorder)
-  }
-
-  if (!preorder)
-    ui <- func(ui)
-
-  return(ui)
-}
-
-# Preprocess a tag object by changing any singleton X into
-# <!--SHINY.SINGLETON[sig]-->X'<!--/SHINY.SINGLETON[sig]-->
-# where sig is the sha1 of X, and X' is X minus the singleton
-# attribute.
-#
-# In the case of nested singletons, outer singletons are processed
-# before inner singletons (otherwise the processing of inner
-# singletons would cause the sha1 of the outer singletons to be
-# different).
-surroundSingletons <- local({
-  surroundSingleton <- function(uiObj) {
-    if (inherits(uiObj, "shiny.singleton")) {
-      sig <- digest(uiObj, "sha1")
-      class(uiObj) <- class(uiObj)[class(uiObj) != "shiny.singleton"]
-      return(tagList(
-        HTML(sprintf("<!--SHINY.SINGLETON[%s]-->", sig)),
-        uiObj,
-        HTML(sprintf("<!--/SHINY.SINGLETON[%s]-->", sig))
-      ))
-    } else {
-      uiObj
-    }
-  }
-
-  function(ui) {
-    rewriteTags(ui, surroundSingleton, TRUE)
-  }
-})
-
-# Given a tag object, apply singleton logic (allow singleton objects
-# to appear no more than once per signature) and return the processed
-# HTML objects and also the list of known singletons.
-takeSingletons <- function(ui, singletons=character(0), desingleton=TRUE) {
-  result <- rewriteTags(ui, function(uiObj) {
-    if (inherits(uiObj, "shiny.singleton")) {
-      sig <- digest(uiObj, "sha1")
-      if (sig %in% singletons)
-        return(NULL)
-      singletons <<- append(singletons, sig)
-      if (desingleton)
-        class(uiObj) <- class(uiObj)[class(uiObj) != "shiny.singleton"]
-      return(uiObj)
-    } else {
-      return(uiObj)
-    }
-  }, TRUE)
-
-  return(list(ui=result, singletons=singletons))
-}
-
-# Given a tag object, extract out any children of tags$head
-# and return them separate from the body.
-takeHeads <- function(ui) {
-  headItems <- list()
-  result <- rewriteTags(ui, function(uiObj) {
-    if (isTag(uiObj) && tolower(uiObj$name) == "head") {
-      headItems <<- append(headItems, uiObj$children)
-      return(NULL)
-    }
-    return(uiObj)
-  }, FALSE)
-
-  return(list(ui=result, head=headItems))
-}
-
-#' HTML Builder Functions
-#'
-#' Simple functions for constructing HTML documents.
-#'
-#' The \code{tags} environment contains convenience functions for all valid
-#' HTML5 tags. To generate tags that are not part of the HTML5 specification,
-#' you can use the \code{\link{tag}()} function.
-#'
-#' Dedicated functions are available for the most common HTML tags that do not
-#' conflict with common R functions.
-#'
-#' The result from these functions is a tag object, which can be converted using
-#' \code{\link{as.character}()}.
-#'
-#' @name builder
-#' @param ... Attributes and children of the element. Named arguments become
-#'   attributes, and positional arguments become children. Valid children are
-#'   tags, single-character character vectors (which become text nodes), and raw
-#'   HTML (see \code{\link{HTML}}). You can also pass lists that contain tags,
-#'   text nodes, and HTML.
-#' @export tags
-#' @examples
-#' doc <- tags$html(
-#'   tags$head(
-#'     tags$title('My first page')
-#'   ),
-#'   tags$body(
-#'     h1('My first heading'),
-#'     p('My first paragraph, with some ',
-#'       strong('bold'),
-#'       ' text.'),
-#'     div(id='myDiv', class='simpleDiv',
-#'         'Here is a div with some attributes.')
-#'   )
-#' )
-#' cat(as.character(doc))
-NULL
-
-#' @rdname builder
-#' @format NULL
-#' @docType NULL
-#' @keywords NULL
-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
-#'
-#' Marks the given text as HTML, which means the \link{tag} functions will know
-#' not to perform HTML escaping on it.
-#'
-#' @param text The text value to mark with HTML
-#' @param ... Any additional values to be converted to character and
-#'   concatenated together
-#' @return The same value, but marked as HTML.
-#'
-#' @examples
-#' el <- div(HTML("I like <u>turtles</u>"))
-#' cat(as.character(el))
-#'
-#' @export
-HTML <- function(text, ...) {
-  htmlText <- c(text, as.character(list(...)))
-  htmlText <- paste(htmlText, collapse=" ")
-  attr(htmlText, "html") <- TRUE
-  class(htmlText) <- c("html", "character")
-  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/update-input.R

@@ -301,13 +301,8 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
   if (!is.null(selected))
     selected <- validateSelected(selected, choices, inputId)
 
-  options <- if (length(choices)) mapply(choices, names(choices),
-    SIMPLIFY = FALSE, USE.NAMES = FALSE,
-    FUN = function(value, name) {
-      list(value = value,
-           label = name)
-    }
-  )
+  options <- if (length(choices))
+    columnToRowData(list(value = choices, label = names(choices)))
 
   message <- dropNulls(list(label = label, options = options, value = selected))
 
@@ -392,3 +387,80 @@ updateRadioButtons <- updateCheckboxGroupInput
 #' }
 #' @export
 updateSelectInput <- updateCheckboxGroupInput
+
+#' @rdname updateSelectInput
+#' @param options a list of options (see \code{\link{selectizeInput}})
+#' @param server whether to store \code{choices} on the server side, and load
+#'   the select options dynamically on searching, instead of writing all
+#'   \code{choices} into the page at once (i.e., only use the client-side
+#'   version of \pkg{selectize.js})
+#' @export
+updateSelectizeInput <- function(
+  session, inputId, label = NULL, choices = NULL, selected = NULL,
+  options = list(), server = FALSE
+) {
+  if (length(options)) {
+    res <- checkAsIs(options)
+    cfg <- tags$script(
+      type = 'application/json',
+      `data-for` = inputId,
+      `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
+      HTML(toJSON(res$options))
+    )
+    session$sendInputMessage(inputId, list(newOptions = as.character(cfg)))
+  }
+  if (!server) {
+    return(updateSelectInput(session, inputId, label, choices, selected))
+  }
+  # in the server mode, the choices are not available before we type, so we
+  # cannot really pre-select any options, but here we insert the `selected`
+  # options into selectize forcibly
+  value <- unname(selected)
+  selected <- choicesWithNames(selected)
+  message <- dropNulls(list(
+    label = label,
+    value = value,
+    selected = if (length(selected)) {
+      columnToRowData(list(label = names(selected), value = selected))
+    },
+    url = session$registerDataObj(inputId, choices, selectizeJSON)
+  ))
+  session$sendInputMessage(inputId, message)
+}
+
+selectizeJSON <- function(data, req) {
+  query <- parseQueryString(req$QUERY_STRING)
+  # extract the query variables, conjunction (and/or), search string, maximum options
+  var <- fromJSON(query$field)
+  cjn <- if (query$conju == 'and') all else any
+  # all keywords in lower-case, for case-insensitive matching
+  key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])
+  if (identical(key, '')) key <- character(0)
+  mop <- query$maxop
+
+  # convert a single vector to a data frame so it returns {label: , value: }
+  # later in JSON; other objects return arbitrary JSON {x: , y: , foo: , ...}
+  data <- if (is.atomic(data)) {
+    data <- choicesWithNames(data)
+    data.frame(label = names(data), value = data, stringsAsFactors = FALSE)
+  } else as.data.frame(data, stringsAsFactors = FALSE)
+
+  # start searching for keywords in all specified columns
+  idx <- logical(nrow(data))
+  if (length(key)) for (v in var) {
+    matches <- do.call(
+      cbind,
+      lapply(key, function(k) {
+        grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
+      })
+    )
+    # merge column matches using OR, and match multiple keywords in one column
+    # using the conjunction setting (AND or OR)
+    idx <- idx | apply(matches, 1, cjn)
+  }
+  # only return the first n rows (n = maximum options in configuration)
+  idx <- head(which(idx), mop)
+  data <- data[idx, ]
+
+  httpResponse(200, 'application/json', toJSON(columnToRowData(data)))
+}

R/utils.R

@@ -1,3 +1,7 @@
+#' @include globals.R
+#' @include map.R
+NULL
+
 #' Make a random number generator repeatable
 #'
 #' Given a function that generates random data, returns a wrapped version of
@@ -40,8 +44,76 @@ repeatable <- function(rngfunc, seed = runif(1, 0, .Machine$integer.max)) {
   }
 }
 
+# Temporarily set x in env to value, evaluate expr, and
+# then restore x to its original state
+withTemporary <- function(env, x, value, expr, unset = FALSE) {
+
+  if (exists(x, envir = env, inherits = FALSE)) {
+    oldValue <- get(x, envir = env, inherits = FALSE)
+    on.exit(
+      assign(x, oldValue, envir = env, inherits = FALSE),
+      add = TRUE)
+  } else {
+    on.exit(
+      rm(list = x, envir = env, inherits = FALSE),
+      add = TRUE
+    )
+  }
+
+  if (!missing(value) && !isTRUE(unset))
+    assign(x, value, envir = env, inherits = FALSE)
+  else {
+    if (exists(x, envir = env, inherits = FALSE))
+      rm(list = x, envir = env, inherits = FALSE)
+  }
+  force(expr)
+}
+
+.globals$ownSeed <- NULL
+# Evaluate an expression using Shiny's own private stream of
+# randomness (not affected by set.seed).
+withPrivateSeed <- function(expr) {
+  withTemporary(.GlobalEnv, ".Random.seed",
+    .globals$ownSeed, unset=is.null(.globals$ownSeed), {
+      tryCatch({
+        expr
+      }, finally = {.globals$ownSeed <- .Random.seed})
+    }
+  )
+}
+
+# Version of runif that runs with private seed
+p_runif <- function(...) {
+  withPrivateSeed(runif(...))
+}
+
+# Version of sample that runs with private seed
+p_sample <- function(...) {
+  withPrivateSeed(sample(...))
+}
+
+# Return a random integral value in the range [min, max).
+# If only one argument is passed, then min=0 and max=argument.
+randomInt <- function(min, max) {
+  if (missing(max)) {
+    max <- min
+    min <- 0
+  }
+  if (min < 0 || max <= min)
+    stop("Invalid min/max values")
+
+  min + sample(max-min, 1)-1
+}
+
+p_randomInt <- function(...) {
+  withPrivateSeed(randomInt(...))
+}
+
 `%OR%` <- function(x, y) {
-  ifelse(is.null(x) || is.na(x), y, x)
+  if (is.null(x) || isTRUE(is.na(x)))
+    y
+  else
+    x
 }
 
 `%AND%` <- function(x, y) {
@@ -68,6 +140,99 @@ dropNullsOrEmpty <- function(x) {
   x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))]
 }
 
+# Combine dir and (file)name into a file path. If a file already exists with a
+# name differing only by case, then use it instead.
+file.path.ci <- function(dir, name) {
+  default <- file.path(dir, name)
+  if (file.exists(default))
+    return(default)
+  if (!file.exists(dir))
+    return(default)
+
+  matches <- list.files(dir, name, ignore.case=TRUE, full.names=TRUE,
+    include.dirs=TRUE)
+  if (length(matches) == 0)
+    return(default)
+  return(matches[[1]])
+}
+
+# Attempt to join a path and relative path, and turn the result into a
+# (normalized) absolute path. The result will only be returned if it is an
+# existing file/directory and is a descendant of dir.
+#
+# Example:
+# resolve("/Users/jcheng", "shiny")  # "/Users/jcheng/shiny"
+# resolve("/Users/jcheng", "./shiny")  # "/Users/jcheng/shiny"
+# resolve("/Users/jcheng", "shiny/../shiny/")  # "/Users/jcheng/shiny"
+# resolve("/Users/jcheng", ".")  # NULL
+# resolve("/Users/jcheng", "..")  # NULL
+# resolve("/Users/jcheng", "shiny/..")  # NULL
+resolve <- function(dir, relpath) {
+  abs.path <- file.path(dir, relpath)
+  if (!file.exists(abs.path))
+    return(NULL)
+  abs.path <- normalizePath(abs.path, winslash='/', mustWork=TRUE)
+  dir <- normalizePath(dir, winslash='/', mustWork=TRUE)
+  # trim the possible trailing slash under Windows (#306)
+  if (.Platform$OS.type == 'windows') dir <- sub('/$', '', dir)
+  if (nchar(abs.path) <= nchar(dir) + 1)
+    return(NULL)
+  if (substr(abs.path, 1, nchar(dir)) != dir ||
+      substr(abs.path, nchar(dir)+1, nchar(dir)+1) != '/') {
+    return(NULL)
+  }
+  return(abs.path)
+}
+
+# This is a wrapper for download.file and has the same interface.
+# The only difference is that, if the protocol is https, it changes the
+# download settings, depending on platform.
+download <- function(url, ...) {
+  # First, check protocol. If http or https, check platform:
+  if (grepl('^https?://', url)) {
+
+    # If Windows, call setInternet2, then use download.file with defaults.
+    if (.Platform$OS.type == "windows") {
+      # If we directly use setInternet2, R CMD CHECK gives a Note on Mac/Linux
+      mySI2 <- `::`(utils, 'setInternet2')
+      # Store initial settings
+      internet2_start <- mySI2(NA)
+      on.exit(mySI2(internet2_start))
+
+      # Needed for https
+      mySI2(TRUE)
+      download.file(url, ...)
+
+    } else {
+      # If non-Windows, check for curl/wget/lynx, then call download.file with
+      # appropriate method.
+
+      if (nzchar(Sys.which("wget")[1])) {
+        method <- "wget"
+      } else if (nzchar(Sys.which("curl")[1])) {
+        method <- "curl"
+
+        # curl needs to add a -L option to follow redirects.
+        # Save the original options and restore when we exit.
+        orig_extra_options <- getOption("download.file.extra")
+        on.exit(options(download.file.extra = orig_extra_options))
+
+        options(download.file.extra = paste("-L", orig_extra_options))
+
+      } else if (nzchar(Sys.which("lynx")[1])) {
+        method <- "lynx"
+      } else {
+        stop("no download method found")
+      }
+
+      download.file(url, method = method, ...)
+    }
+
+  } else {
+    download.file(url, ...)
+  }
+}
+
 knownContentTypes <- Map$new()
 knownContentTypes$mset(
   html='text/html; charset=UTF-8',
@@ -380,7 +545,8 @@ Callbacks <- setRefClass(
 )
 
 # convert a data frame to JSON as required by DataTables request
-dataTablesJSON <- function(data, query) {
+dataTablesJSON <- function(data, req) {
+  query <- req$QUERY_STRING
   n <- nrow(data)
   with(parseQueryString(query), {
     useRegex <- function(j, envir = parent.frame()) {
@@ -440,14 +606,19 @@ dataTablesJSON <- function(data, query) {
       fdata <- data[i, , drop = FALSE]  # filtered data
     } else fdata <- data
     fdata <- unname(as.matrix(fdata))
+    # WAT: toJSON(list(x = matrix(nrow = 0, ncol = 1))) => {"x": } (#299)
     if (nrow(fdata) == 0) fdata <- list()
+    # WAT: toJSON(list(x = matrix(1:2))) => {x: [ [1], [2] ]}, however,
+    # toJSON(list(x = matrix(1))) => {x: [ 1 ]} (loss of dimension, #429)
+    if (all(dim(fdata) == 1)) fdata <- list(list(fdata[1, 1]))
 
-    toJSON(list(
+    res <- toJSON(list(
       sEcho = as.integer(sEcho),
       iTotalRecords = n,
       iTotalDisplayRecords = nrow(data),
       aaData = fdata
     ))
+    httpResponse(200, 'application/json', res)
   })
 }
 
@@ -488,6 +659,8 @@ checkAsIs <- function(options) {
 srcrefFromShinyCall <- function(expr) {
   srcrefs <- attr(expr, "srcref")
   num_exprs <- length(srcrefs)
+  if (num_exprs < 1)
+    return(NULL)
   c(srcrefs[[1]][1], srcrefs[[1]][2],
     srcrefs[[num_exprs]][3], srcrefs[[num_exprs]][4],
     srcrefs[[1]][5], srcrefs[[num_exprs]][6])
@@ -530,3 +703,197 @@ formatNoSci <- function(x) {
   if (is.null(x)) return(NULL)
   format(x, scientific = FALSE, digits = 15)
 }
+
+# Returns a function that calls the given func and caches the result for
+# subsequent calls, unless the given file's mtime changes.
+cachedFuncWithFile <- function(dir, file, func, case.sensitive = FALSE) {
+  dir <- normalizePath(dir, mustWork=TRUE)
+  mtime <- NA
+  value <- NULL
+  function(...) {
+    fname <- if (case.sensitive)
+      file.path(dir, file)
+    else
+      file.path.ci(dir, file)
+
+    now <- file.info(fname)$mtime
+    if (!identical(mtime, now)) {
+      value <<- func(fname, ...)
+      mtime <<- now
+    }
+    value
+  }
+}
+
+# Returns a function that sources the file and caches the result for subsequent
+# calls, unless the file's mtime changes.
+cachedSource <- function(dir, file, case.sensitive = FALSE) {
+  dir <- normalizePath(dir, mustWork=TRUE)
+  cachedFuncWithFile(dir, file, function(fname, ...) {
+    if (file.exists(fname))
+      return(source(fname, ...))
+    else
+      return(NULL)
+  })
+}
+
+# turn column-based data to row-based data (mainly for JSON), e.g. data.frame(x
+# = 1:10, y = 10:1) ==> list(list(x = 1, y = 10), list(x = 2, y = 9), ...)
+columnToRowData <- function(data) {
+  do.call(
+    mapply, c(
+      list(FUN = function(...) list(...), SIMPLIFY = FALSE, USE.NAMES = FALSE),
+      as.list(data)
+    )
+  )
+}
+
+#' Validate input values and other conditions
+#'
+#' For an output rendering function (e.g. \code{\link{renderPlot}()}), you may
+#' need to check that certain input values are available and valid before you
+#' can render the output. \code{validate} gives you a convenient mechanism for
+#' doing so.
+#'
+#' The \code{validate} function takes any number of (unnamed) arguments, each of
+#' which represents a condition to test. If any of the conditions represent
+#' failure, then a special type of error is signaled which stops execution. If
+#' this error is not handled by application-specific code, it is displayed to
+#' the user by Shiny.
+#'
+#' An easy way to provide arguments to \code{validate} is to use the \code{need}
+#' function, which takes an expression and a string; if the expression is
+#' considered a failure, then the string will be used as the error message. The
+#' \code{need} function considers its expression to be a failure if it is any of
+#' the following:
+#'
+#' \itemize{
+#'   \item{\code{FALSE}}
+#'   \item{\code{NULL}}
+#'   \item{\code{""}}
+#'   \item{An empty atomic vector}
+#'   \item{An atomic vector that contains only missing values}
+#'   \item{A logical vector that contains all \code{FALSE} or missing values}
+#'   \item{An object of class \code{"try-error"}}
+#'   \item{A value that represents an unclicked \code{\link{actionButton}}}
+#' }
+#'
+#' If any of these values happen to be valid, you can explicitly turn them to
+#' logical values. For example, if you allow \code{NA} but not \code{NULL}, you
+#' can use the condition \code{!is.null(input$foo)}, because \code{!is.null(NA)
+#' == TRUE}.
+#'
+#' If you need validation logic that differs significantly from \code{need}, you
+#' can create other validation test functions. A passing test should return
+#' \code{NULL}. A failing test should return an error message as a
+#' single-element character vector, or if the failure should happen silently,
+#' \code{FALSE}.
+#'
+#' Because validation failure is signaled as an error, you can use
+#' \code{validate} in reactive expressions, and validation failures will
+#' automatically propagate to outputs that use the reactive expression. In
+#' other words, if reactive expression \code{a} needs \code{input$x}, and two
+#' outputs use \code{a} (and thus depend indirectly on \code{input$x}), it's
+#' not necessary for the outputs to validate \code{input$x} explicitly, as long
+#' as \code{a} does validate it.
+#'
+#' @param ... A list of tests. Each test should equal \code{NULL} for success,
+#'   \code{FALSE} for silent failure, or a string for failure with an error
+#'   message.
+#' @param errorClass A CSS class to apply. The actual CSS string will have
+#'   \code{shiny-output-error-} prepended to this value.
+#' @export
+#' @examples
+#' # in ui.R
+#' fluidPage(
+#'   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
+#'   selectizeInput('in2', 'Select a state', choices = state.name),
+#'   plotOutput('plot')
+#' )
+#'
+#' # in server.R
+#' function(input, output) {
+#'   output$plot <- renderPlot({
+#'     validate(
+#'       need(input$in1, 'Check at least one letter!'),
+#'       need(input$in2 == '', 'Please choose a state.')
+#'     )
+#'     plot(1:10, main = paste(c(input$in1, input$in2), collapse = ', '))
+#'   })
+#' }
+validate <- function(..., errorClass = character(0)) {
+  results <- sapply(list(...), function(x) {
+    # Detect NULL or NA
+    if (is.null(x))
+      return(NA_character_)
+    else if (identical(x, FALSE))
+      return("")
+    else if (is.character(x))
+      return(paste(as.character(x), collapse = "\n"))
+    else
+      stop("Unexpected validation result: ", as.character(x))
+  })
+
+  results <- na.omit(results)
+  if (length(results) == 0)
+    return(invisible())
+
+  # There may be empty strings remaining; these are message-less failures that
+  # started as FALSE
+  results <- results[nzchar(results)]
+
+  stopWithCondition(c("validation", errorClass), paste(results, collapse="\n"))
+}
+
+#' @param expr An expression to test. The condition will pass if the expression
+#'   meets the conditions spelled out in Details.
+#' @param message A message to convey to the user if the validation condition is
+#'   not met. If no message is provided, one will be created using \code{label}.
+#'   To fail with no message, use \code{FALSE} for the message.
+#' @param label A human-readable name for the field that may be missing. This
+#'   parameter is not needed if \code{message} is provided, but must be provided
+#'   otherwise.
+#' @export
+#' @rdname validate
+need <- function(expr, message = paste(label, "must be provided"), label) {
+
+  force(message) # Fail fast on message/label both being missing
+
+  if (!isTruthy(expr))
+    return(message)
+  else
+    return(invisible(NULL))
+}
+
+isTruthy <- function(x) {
+  if (inherits(x, 'try-error'))
+    return(FALSE)
+
+  if (!is.atomic(x))
+    return(TRUE)
+
+  if (is.null(x))
+    return(FALSE)
+  if (length(x) == 0)
+    return(FALSE)
+  if (all(is.na(x)))
+    return(FALSE)
+  if (is.character(x) && !any(nzchar(na.omit(x))))
+    return(FALSE)
+  if (inherits(x, 'shinyActionButtonValue') && x == 0)
+    return(FALSE)
+  if (is.logical(x) && !any(na.omit(x)))
+    return(FALSE)
+
+  return(TRUE)
+}
+
+# add class(es) to the error condition, which will be used as names of CSS
+# classes, e.g. shiny-output-error shiny-output-error-validation
+stopWithCondition <- function(class, message) {
+  cond <- structure(
+    list(message = message),
+    class = c(class, 'shiny.silent.error', 'error', 'condition')
+  )
+  stop(cond)
+}

inst/staticdocs/index.r

@@ -0,0 +1,164 @@
+sd_section("UI Layout",
+  "Functions for laying out the user interface for your application.",
+  c(
+    "absolutePanel",
+    "bootstrapPage",
+    "column",
+    "conditionalPanel",
+    "fixedPage",
+    "fluidPage",
+    "headerPanel",
+    "helpText",
+    "icon",
+    "mainPanel",
+    "navbarPage",
+    "navlistPanel",
+    "pageWithSidebar",
+    "sidebarLayout",
+    "sidebarPanel",
+    "tabPanel",
+    "tabsetPanel",
+    "titlePanel",
+    "inputPanel",
+    "flowLayout",
+    "splitLayout",
+    "verticalLayout",
+    "wellPanel",
+    "withMathJax"
+  )
+)
+sd_section("UI Inputs",
+  "Functions for creating user interface elements that prompt the user for input values or interaction.",
+  c(
+    "actionButton",
+    "checkboxGroupInput",
+    "checkboxInput",
+    "dateInput",
+    "dateRangeInput",
+    "fileInput",
+    "numericInput",
+    "radioButtons",
+    "selectInput",
+    "sliderInput",
+    "submitButton",
+    "textInput",
+    "updateCheckboxGroupInput",
+    "updateCheckboxInput",
+    "updateDateInput",
+    "updateDateRangeInput",
+    "updateNumericInput",
+    "updateRadioButtons",
+    "updateSelectInput",
+    "updateSliderInput",
+    "updateTabsetPanel",
+    "updateTextInput"
+  )
+)
+sd_section("UI Outputs",
+  "Functions for creating user interface elements that, in conjunction with rendering functions, display different kinds of output from your application.",
+  c(
+    "htmlOutput",
+    "imageOutput",
+    "plotOutput",
+    "outputOptions",
+    "tableOutput",
+    "textOutput",
+    "verbatimTextOutput",
+    "downloadButton"
+  )
+)
+sd_section("Interface builder functions",
+  "A sub-library for writing HTML using R functions. These functions form the foundation on which the higher level user interface functions are built, and can also be used in your Shiny UI to provide custom HTML, CSS, and JavaScript.",
+  c(
+    "builder",
+    "HTML",
+    "include",
+    "singleton",
+    "tag",
+    "validateCssUnit",
+    "withTags"
+  )
+)
+sd_section("Rendering functions",
+  "Functions that you use in your application's server side code, assigning them to outputs that appear in your user interface.",
+  c(
+    "renderPlot",
+    "renderText",
+    "renderPrint",
+    "renderDataTable",
+    "renderImage",
+    "renderTable",
+    "renderUI",
+    "downloadHandler",
+    "reactivePlot",
+    "reactivePrint",
+    "reactiveTable",
+    "reactiveText",
+    "reactiveUI"
+  )
+)
+sd_section("Reactive constructs",
+  "A sub-library that provides reactive programming facilities for R.",
+  c(
+    "invalidateLater",
+    "is.reactivevalues",
+    "isolate",
+    "makeReactiveBinding",
+    "observe",
+    "reactive",
+    "reactiveFileReader",
+    "reactivePoll",
+    "reactiveTimer",
+    "reactiveValues",
+    "reactiveValuesToList",
+    "domains",
+    "showReactLog"
+  )
+)
+sd_section("Boilerplate",
+  "Functions that are required boilerplate in ui.R and server.R.",
+  c(
+    "shinyUI",
+    "shinyServer"
+  )
+)
+sd_section("Running",
+  "Functions that are used to run or stop Shiny applications.",
+  c(
+    "runApp",
+    "runExample",
+    "runGist",
+    "runGitHub",
+    "runUrl",
+    "stopApp"
+  )
+)
+sd_section("Extending Shiny",
+  "Functions that are intended to be called by third-party packages that extend Shiny.",
+  c(
+    "addResourcePath",
+    "registerInputHandler",
+    "removeInputHandler",
+    "markRenderFunction"
+  )
+)
+sd_section("Utility functions",
+  "Miscellaneous utilities that may be useful to advanced users or when extending Shiny.",
+  c(
+    "validate",
+    "session",
+    "exprToFunction",
+    "installExprFunction",
+    "parseQueryString",
+    "plotPNG",
+    "repeatable",
+    "shinyDeprecated"
+  )
+)
+sd_section("Embedding",
+  "Functions that are intended for third-party packages that embed Shiny applications.",
+  c(
+    "shinyApp",
+    "maskReactiveContext"
+  )
+)

inst/tests/test-bootstrap.r

@@ -7,8 +7,8 @@ test_that("CSS unit validation", {
   }
 
   # 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)
+  strings  <- c("100x", "10px", "10.4px", ".4px", "1px0", "px", "5",  "%", "5%", "auto", "1auto", "")
+  expected <- c(NA,     "10px", "10.4px", ".4px", NA,       NA, "5px", NA, "5%", "auto", NA,      NA)
   results <- vapply(strings, validateCssUnit_wrap, character(1), USE.NAMES = FALSE)
   expect_equal(results, expected)
 
@@ -23,19 +23,8 @@ test_that("Repeated names for selectInput and radioButtons choices", {
 
   # Select input
   x <- selectInput('id','label', choices = c(a='x1', a='x2', b='x3'), selectize = FALSE)
-  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')
-  expect_equal(choices[[2]]$attribs$selected, NULL)
-
-  expect_equal(choices[[3]]$children[[1]], 'b')
-  expect_equal(choices[[3]]$attribs$value, 'x3')
-  expect_equal(choices[[3]]$attribs$selected, NULL)
+  expect_equal(format(x), '<label class="control-label" for="id">label</label>
+<select id="id"><option value="x1" selected>a</option>\n<option value="x2">a</option>\n<option value="x3">b</option></select>')
 
 
   # Radio buttons

inst/tests/test-reactivity.r

@@ -694,6 +694,8 @@ test_that("classes of reactive object", {
   expect_false(is.reactive(v))
   expect_true(is.reactive(r))
   expect_false(is.reactive(o))
+
+  o$destroy()
 })
 
 test_that("{} and NULL also work in reactive()", {
@@ -707,3 +709,115 @@ test_that("shiny.suppressMissingContextError option works", {
 
   expect_true(reactive(TRUE)())
 })
+
+test_that("reactive domains are inherited", {
+
+  domainA <- createMockDomain()
+  domainB <- createMockDomain()
+
+  local({
+    domainY <- NULL
+    domainZ <- NULL
+    x <- observe({
+
+      y <- observe({
+        # Should be domainA (inherited from observer x)
+        domainY <<- getDefaultReactiveDomain()
+      })
+
+      z <- observe({
+        # Should be domainB (explicitly passed in)
+        domainZ <<- getDefaultReactiveDomain()
+      }, domain = domainB)
+
+    }, domain = domainA)
+
+    flushReact()
+    flushReact()
+
+    expect_identical(domainY, domainA)
+    expect_identical(domainZ, domainB)
+  })
+
+  local({
+    domainY <- 1
+    x <- NULL
+    y <- NULL
+    z <- NULL
+    r3 <- NULL
+    domainR3 <- NULL
+
+    r1 <- reactive({
+      y <<- observe({
+        # Should be NULL (r1 has no domain)
+        domainY <<- getDefaultReactiveDomain()
+      })
+    })
+    r2 <- reactive({
+      z <<- observe({
+        # Should be domainB (r2 has explicit domainB)
+        domainZ <<- getDefaultReactiveDomain()
+      })
+    }, domain = domainB)
+
+    observe({
+      r3 <<- reactive({
+        # This should be domainA. Doesn't matter where r3 is invoked, it only
+        # matters where it was created.
+        domainR3 <<- getDefaultReactiveDomain()
+      })
+      r1()
+      r2()
+    }, domain = domainA)
+
+    flushReact()
+    flushReact()
+    isolate(r3())
+
+    expect_identical(execCount(y), 1L)
+    expect_identical(execCount(z), 1L)
+    expect_identical(domainY, NULL)
+    expect_identical(domainZ, domainB)
+    expect_identical(domainR3, domainA)
+  })
+})
+
+test_that("observers autodestroy (or not)", {
+
+  domainA <- createMockDomain()
+  local({
+    a <- observe(NULL, domain = domainA)
+
+    b <- observe(NULL, domain = domainA, autoDestroy = FALSE)
+
+    c <- observe(NULL, domain = domainA)
+    c$setAutoDestroy(FALSE)
+
+    d <- observe(NULL, domain = domainA, autoDestroy = FALSE)
+    d$setAutoDestroy(TRUE)
+
+    e <- observe(NULL)
+
+    domainA$end()
+
+    flushReact()
+
+    expect_identical(execCount(a), 0L)
+    expect_identical(execCount(b), 1L)
+    expect_identical(execCount(c), 1L)
+    expect_identical(execCount(d), 0L)
+    expect_identical(execCount(e), 1L)
+  })
+})
+
+test_that("maskReactiveContext blocks use of reactives", {
+  vals <- reactiveValues(x = 123)
+
+  # Block reactive contexts (created by isolate)
+  expect_error(isolate(maskReactiveContext(vals$x)))
+  expect_error(isolate(isolate(maskReactiveContext(vals$x))))
+
+  # Reactive contexts within maskReactiveContext shouldn't be blocked
+  expect_identical(maskReactiveContext(isolate(vals$x)), 123)
+  expect_identical(isolate(maskReactiveContext(isolate(vals$x))), 123)
+})

inst/tests/test-staticdocs.R

@@ -1,19 +1,19 @@
 context("staticdocs")
 
 test_that("All man pages have an entry in staticdocs/index.r", {
-  if (!all(file.exists(c('../../staticdocs', '../../man')))) {
+  if (!all(file.exists(c('../../inst/staticdocs', '../../man')))) {
     # This test works only when run against a package directory
     return()
   }
   # Known not to be indexed
-  known_unindexed <- c("shiny-package")
+  known_unindexed <- c("shiny-package", "knitr_methods")
 
   indexed_topics <- local({
     result <- character(0)
     sd_section <- function(dummy1, dummy2, section_topics) {
       result <<- c(result, section_topics)
     }
-    source("../../staticdocs/index.r", local = TRUE)
+    source("../../inst/staticdocs/index.r", local = TRUE)
     result
   })
 
@@ -22,5 +22,14 @@ test_that("All man pages have an entry in staticdocs/index.r", {
   # This test ensures that every documented topic is included in
   # staticdocs/index.r, unless explicitly waived by specifying it
   # in the known_unindexed variable above.
-  expect_equivalent(sort(all_topics), sort(c(known_unindexed, indexed_topics)))
+  missing <- setdiff(sort(all_topics), sort(c(known_unindexed, indexed_topics)))
+  unknown <- setdiff(sort(c(known_unindexed, indexed_topics)), sort(all_topics))
+  expect_equal(length(missing), 0,
+    info = paste("Functions missing from index:\n",
+      paste("  ", missing, sep = "", collapse = "\n"),
+      sep = ""))
+  expect_equal(length(unknown), 0,
+    info = paste("Unrecognized functions in index.r:\n",
+      paste("  ", unknown, sep = "", collapse = "\n"),
+      sep = ""))
 })

inst/tests/test-tags.r

@@ -1,432 +0,0 @@
-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), 1)
-  expect_equal(length(t1$children[[1]]), 3)
-  expect_equal(t1$children[[1]][[1]]$name, "p")
-  expect_equal(t1$children[[1]][[1]]$children[[1]], "tag1")
-  expect_equal(t1$children[[1]][[2]]$name, "b")
-  expect_equal(t1$children[[1]][[2]]$children[[1]], "tag2")
-  expect_equal(t1$children[[1]][[3]]$name, "i")
-  expect_equal(t1$children[[1]][[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]])
-  t2a <- do.call(tags$div, c(tag_list, class="foo"))
-  expect_identical(t2a, t2)
-
-
-  # tagSetChildren, using list argument
-  t2 <- tagSetChildren(div_tag, list = tag_list)
-  expect_identical(t2a, t2)
-
-  # tagSetChildren, using ... arguments
-  t2 <- tagSetChildren(div_tag, tag_list[[1]], tag_list[[2]], tag_list[[3]])
-  expect_identical(t2a, t2)
-
-  # tagSetChildren, using ... and list arguments
-  t2 <- tagSetChildren(div_tag, tag_list[[1]], list = tag_list[2:3])
-  expect_identical(t2a, t2)
-
-  # tagSetChildren overwrites existing children
-  t2 <- tagAppendChild(div_tag, p("should replace this tag"))
-  t2 <- tagSetChildren(div_tag, list = tag_list)
-  expect_identical(t2a, t2)
-
-
-  # tagAppendChildren, using list argument
-  t2 <- tagAppendChild(div_tag, tag_list[[1]])
-  t2 <- tagAppendChildren(t2, list = tag_list[2:3])
-  expect_identical(t2a, t2)
-
-  # tagAppendChildren, using ... arguments
-  t2 <- tagAppendChild(div_tag, tag_list[[1]])
-  t2 <- tagAppendChildren(t2, tag_list[[2]], tag_list[[3]])
-  expect_identical(t2a, 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(t2a, t2)
-
-  # tagAppendChildren can start with no children
-  t2 <- tagAppendChildren(div_tag, list = tag_list)
-  expect_identical(t2a, 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")
-  )
-
-  # NULL children are dropped
-  expect_identical(
-    renderTags(div("foo", NULL, list(NULL, list(NULL, "bar"))))$html,
-    renderTags(div("foo", "bar"))$html
-  )
-
-  # Numbers are coerced to strings
-  expect_identical(
-    renderTags(div(1234))$html,
-    renderTags(div("1234"))$html
-  )
-})
-
-
-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(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(renderTags(t1)$html, renderTags(t1_full)$html)
-})
-
-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]], HTML("<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]], HTML("<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)
-})
-
-test_that("Head and singleton behavior", {
-  result <- renderTags(tagList(
-    tags$head(singleton("hello"))
-  ))
-
-  expect_identical(result$html, HTML(""))
-  expect_identical(result$head, HTML("  hello"))
-  expect_identical(result$singletons, "60eed8231e688bcba7c275c58dd2e3b4dacb61f0")
-
-  # Ensure that "hello" actually behaves like a singleton
-  result2 <- renderTags(tagList(
-    tags$head(singleton("hello"))
-  ), singletons = result$singletons)
-
-  expect_identical(result$singletons, result2$singletons)
-  expect_identical(result2$head, HTML(""))
-  expect_identical(result2$html, HTML(""))
-
-  result3 <- renderTags(tagList(
-    tags$head(singleton("hello"), singleton("hello"))
-  ))
-  expect_identical(result$singletons, result3$singletons)
-  expect_identical(result3$head, HTML("  hello"))
-
-  # Ensure that singleton can be applied to lists, not just tags
-  result4 <- renderTags(list(singleton(list("hello")), singleton(list("hello"))))
-  expect_identical(result4$singletons, "d7319e3f14167c4c056dd7aa0b274c83fe2291f6")
-  expect_identical(result4$html, renderTags(HTML("hello"))$html)
-})
-
-test_that("Factors are treated as characters, not numbers", {
-  myfactors <- factor(LETTERS[1:3])
-  expect_identical(
-    as.character(tags$option(value=myfactors[[1]], myfactors[[1]])),
-    HTML('<option value="A">A</option>')
-  )
-
-  expect_identical(
-    as.character(tags$option(value=myfactors[[1]], value='B', value=3, myfactors[[1]])),
-    HTML('<option value="A B 3">A</option>')
-  )
-})
-
-test_that("Unusual list contents are rendered correctly", {
-  expect_identical(renderTags(list(NULL)), renderTags(HTML("")))
-  expect_identical(renderTags(list(100)), renderTags(HTML("100")))
-  expect_identical(renderTags(list(list(100))), renderTags(HTML("100")))
-  expect_identical(renderTags(list(list())), renderTags(HTML("")))
-  expect_identical(renderTags(NULL), renderTags(HTML("")))
-})
-
-test_that("Low-level singleton manipulation methods", {
-  # Default arguments drop singleton duplicates and strips the
-  # singletons it keeps of the singleton bit
-  result1 <- takeSingletons(tags$div(
-    singleton(tags$head(tags$script("foo"))),
-    singleton(tags$head(tags$script("foo")))
-  ))
-
-  expect_identical(result1$ui$children[[2]], NULL)
-  expect_false(is(result1$ui$children[[1]], "shiny.singleton"))
-
-  # desingleton=FALSE means drop duplicates but don't strip the
-  # singleton bit
-  result2 <- takeSingletons(tags$div(
-    singleton(tags$head(tags$script("foo"))),
-    singleton(tags$head(tags$script("foo")))
-  ), desingleton=FALSE)
-
-  expect_identical(result2$ui$children[[2]], NULL)
-  expect_is(result2$ui$children[[1]], "shiny.singleton")
-
-  result3 <- surroundSingletons(tags$div(
-    singleton(tags$script("foo")),
-    singleton(tags$script("foo"))
-  ))
-
-  expect_identical(
-    renderTags(result3)$html,
-    HTML("<div>
-  <!--SHINY.SINGLETON[58b302d493b50acb75e4a5606687cadccdf902d8]-->
-  <script>foo</script>
-  <!--/SHINY.SINGLETON[58b302d493b50acb75e4a5606687cadccdf902d8]-->
-  <!--SHINY.SINGLETON[58b302d493b50acb75e4a5606687cadccdf902d8]-->
-  <script>foo</script>
-  <!--/SHINY.SINGLETON[58b302d493b50acb75e4a5606687cadccdf902d8]-->
-</div>")
-  )
-})
-
-test_that("Indenting can be controlled/suppressed", {
-  expect_identical(
-    renderTags(tags$div("a", "b"))$html,
-    HTML("<div>\n  a\n  b\n</div>")
-  )
-  expect_identical(
-    format(tags$div("a", "b")),
-    "<div>\n  a\n  b\n</div>"
-  )
-
-  expect_identical(
-    renderTags(tags$div("a", "b"), indent = 2)$html,
-    HTML("    <div>\n      a\n      b\n    </div>")
-  )
-  expect_identical(
-    format(tags$div("a", "b"), indent = 2),
-    "    <div>\n      a\n      b\n    </div>"
-  )
-
-  expect_identical(
-    renderTags(tags$div("a", "b"), indent = FALSE)$html,
-    HTML("<div>\na\nb\n</div>")
-  )
-  expect_identical(
-    format(tags$div("a", "b"), indent = FALSE),
-    "<div>\na\nb\n</div>"
-  )
-
-  expect_identical(
-    renderTags(tagList(tags$div("a", "b")), indent = FALSE)$html,
-    HTML("<div>\na\nb\n</div>")
-  )
-  expect_identical(
-    format(tagList(tags$div("a", "b")), indent = FALSE),
-    "<div>\na\nb\n</div>"
-  )
-})

inst/tests/test-utils.R

@@ -0,0 +1,86 @@
+context("utils")
+
+test_that("Private randomness works at startup", {
+
+  if (exists(".Random.seed", envir = .GlobalEnv))
+    rm(".Random.seed", envir = .GlobalEnv)
+  .globals$ownSeed <- NULL
+  # Just make sure this doesn't blow up
+  createUniqueId(4)
+})
+
+test_that("Setting process-wide seed doesn't affect private randomness", {
+  set.seed(0)
+  id1 <- createUniqueId(4)
+  set.seed(0)
+  id2 <- createUniqueId(4)
+
+  expect_false(identical(id1, id2))
+})
+
+test_that("Resetting private seed doesn't result in dupes", {
+  .globals$ownSeed <- NULL
+  id3 <- createUniqueId(4)
+  set.seed(0)
+  .globals$ownSeed <- NULL
+  id4 <- createUniqueId(4)
+
+  expect_false(identical(id3, id4))
+})
+
+test_that("Clearing process-wide seed doesn't affect private randomness", {
+  set.seed(NULL)
+  id5 <- createUniqueId(4)
+  set.seed(NULL)
+  id6 <- createUniqueId(4)
+
+  expect_false(identical(id5, id6))
+})
+
+test_that("Setting the private seed explicitly results in identical values", {
+  set.seed(0)
+  .globals$ownSeed <- .Random.seed
+  id7 <- createUniqueId(4)
+  set.seed(0)
+  .globals$ownSeed <- .Random.seed
+  id8 <- createUniqueId(4)
+
+  expect_identical(id7, id8)
+})
+
+test_that("need() works as expected", {
+
+  # These are all falsy
+
+  expect_false(need(FALSE, FALSE))
+  expect_false(need(NULL, FALSE))
+  expect_false(need("", FALSE))
+
+  expect_false(need(character(0), FALSE))
+  expect_false(need(logical(0), FALSE))
+  expect_false(need(numeric(0), FALSE))
+  expect_false(need(integer(0), FALSE))
+  expect_false(need(complex(0), FALSE))
+  expect_false(need(matrix(), FALSE))
+
+  expect_false(need(NA, FALSE))
+  expect_false(need(NA_integer_, FALSE))
+  expect_false(need(NA_real_, FALSE))
+  expect_false(need(NA_complex_, FALSE))
+  expect_false(need(NA_character_, FALSE))
+
+  expect_false(need(c(NA, NA, FALSE), FALSE))
+  expect_false(need(c(FALSE), FALSE))
+
+  expect_false(need(try(stop("boom"), silent = TRUE), FALSE))
+
+  # These are all truthy
+
+  expect_null(need(0, FALSE))
+  expect_null(need(1:10, FALSE))
+  expect_null(need(LETTERS, FALSE))
+  expect_null(need("NA", FALSE))
+  expect_null(need(TRUE, FALSE))
+  expect_null(need(c(NA, NA, TRUE), FALSE))
+  expect_null(need(c(FALSE, FALSE, TRUE), FALSE))
+})

inst/www/shared/jqueryui/1.10.4/jquery-ui.css

@@ -1,7 +1,9 @@
-/*! jQuery UI - v1.10.3 - 2013-05-03
+/*! jQuery UI - v1.10.4 - 2014-05-05
 * http://jqueryui.com
-* Includes: jquery.ui.core.css, jquery.ui.accordion.css, jquery.ui.autocomplete.css, jquery.ui.button.css, jquery.ui.datepicker.css, jquery.ui.dialog.css, jquery.ui.menu.css, jquery.ui.progressbar.css, jquery.ui.resizable.css, jquery.ui.selectable.css, jquery.ui.slider.css, jquery.ui.spinner.css, jquery.ui.tabs.css, jquery.ui.tooltip.css, jquery.ui.theme.css
-* Copyright 2013 jQuery Foundation and other contributors; Licensed MIT */
+* Includes: jquery.ui.core.css, jquery.ui.resizable.css, jquery.ui.selectable.css, jquery.ui.accordion.css, jquery.ui.autocomplete.css, jquery.ui.button.css, jquery.ui.dialog.css, jquery.ui.menu.css, jquery.ui.progressbar.css, jquery.ui.spinner.css, jquery.ui.tabs.css, jquery.ui.tooltip.css, jquery.ui.theme.css
+* To view and modify this theme, visit http://jqueryui.com/themeroller/
+* Copyright 2014 jQuery Foundation and other contributors; Licensed MIT */
+
 /* Layout helpers
 ----------------------------------*/
 .ui-helper-hidden {
@@ -84,7 +86,79 @@
 	width: 100%;
 	height: 100%;
 }
-
+.ui-resizable {
+	position: relative;
+}
+.ui-resizable-handle {
+	position: absolute;
+	font-size: 0.1px;
+	display: block;
+}
+.ui-resizable-disabled .ui-resizable-handle,
+.ui-resizable-autohide .ui-resizable-handle {
+	display: none;
+}
+.ui-resizable-n {
+	cursor: n-resize;
+	height: 7px;
+	width: 100%;
+	top: -5px;
+	left: 0;
+}
+.ui-resizable-s {
+	cursor: s-resize;
+	height: 7px;
+	width: 100%;
+	bottom: -5px;
+	left: 0;
+}
+.ui-resizable-e {
+	cursor: e-resize;
+	width: 7px;
+	right: -5px;
+	top: 0;
+	height: 100%;
+}
+.ui-resizable-w {
+	cursor: w-resize;
+	width: 7px;
+	left: -5px;
+	top: 0;
+	height: 100%;
+}
+.ui-resizable-se {
+	cursor: se-resize;
+	width: 12px;
+	height: 12px;
+	right: 1px;
+	bottom: 1px;
+}
+.ui-resizable-sw {
+	cursor: sw-resize;
+	width: 9px;
+	height: 9px;
+	left: -5px;
+	bottom: -5px;
+}
+.ui-resizable-nw {
+	cursor: nw-resize;
+	width: 9px;
+	height: 9px;
+	left: -5px;
+	top: -5px;
+}
+.ui-resizable-ne {
+	cursor: ne-resize;
+	width: 9px;
+	height: 9px;
+	right: -5px;
+	top: -5px;
+}
+.ui-selectable-helper {
+	position: absolute;
+	z-index: 100;
+	border: 1px dotted black;
+}
 .ui-accordion .ui-accordion-header {
 	display: block;
 	cursor: pointer;
@@ -113,14 +187,12 @@
 	border-top: 0;
 	overflow: auto;
 }
-
 .ui-autocomplete {
 	position: absolute;
 	top: 0;
 	left: 0;
 	cursor: default;
 }
-
 .ui-button {
 	display: inline-block;
 	position: relative;
@@ -225,177 +297,8 @@ button.ui-button::-moz-focus-inner {
 	border: 0;
 	padding: 0;
 }
-
-.ui-datepicker {
-	width: 17em;
-	padding: .2em .2em 0;
-	display: none;
-}
-.ui-datepicker .ui-datepicker-header {
-	position: relative;
-	padding: .2em 0;
-}
-.ui-datepicker .ui-datepicker-prev,
-.ui-datepicker .ui-datepicker-next {
-	position: absolute;
-	top: 2px;
-	width: 1.8em;
-	height: 1.8em;
-}
-.ui-datepicker .ui-datepicker-prev-hover,
-.ui-datepicker .ui-datepicker-next-hover {
-	top: 1px;
-}
-.ui-datepicker .ui-datepicker-prev {
-	left: 2px;
-}
-.ui-datepicker .ui-datepicker-next {
-	right: 2px;
-}
-.ui-datepicker .ui-datepicker-prev-hover {
-	left: 1px;
-}
-.ui-datepicker .ui-datepicker-next-hover {
-	right: 1px;
-}
-.ui-datepicker .ui-datepicker-prev span,
-.ui-datepicker .ui-datepicker-next span {
-	display: block;
-	position: absolute;
-	left: 50%;
-	margin-left: -8px;
-	top: 50%;
-	margin-top: -8px;
-}
-.ui-datepicker .ui-datepicker-title {
-	margin: 0 2.3em;
-	line-height: 1.8em;
-	text-align: center;
-}
-.ui-datepicker .ui-datepicker-title select {
-	font-size: 1em;
-	margin: 1px 0;
-}
-.ui-datepicker select.ui-datepicker-month-year {
-	width: 100%;
-}
-.ui-datepicker select.ui-datepicker-month,
-.ui-datepicker select.ui-datepicker-year {
-	width: 49%;
-}
-.ui-datepicker table {
-	width: 100%;
-	font-size: .9em;
-	border-collapse: collapse;
-	margin: 0 0 .4em;
-}
-.ui-datepicker th {
-	padding: .7em .3em;
-	text-align: center;
-	font-weight: bold;
-	border: 0;
-}
-.ui-datepicker td {
-	border: 0;
-	padding: 1px;
-}
-.ui-datepicker td span,
-.ui-datepicker td a {
-	display: block;
-	padding: .2em;
-	text-align: right;
-	text-decoration: none;
-}
-.ui-datepicker .ui-datepicker-buttonpane {
-	background-image: none;
-	margin: .7em 0 0 0;
-	padding: 0 .2em;
-	border-left: 0;
-	border-right: 0;
-	border-bottom: 0;
-}
-.ui-datepicker .ui-datepicker-buttonpane button {
-	float: right;
-	margin: .5em .2em .4em;
-	cursor: pointer;
-	padding: .2em .6em .3em .6em;
-	width: auto;
-	overflow: visible;
-}
-.ui-datepicker .ui-datepicker-buttonpane button.ui-datepicker-current {
-	float: left;
-}
-
-/* with multiple calendars */
-.ui-datepicker.ui-datepicker-multi {
-	width: auto;
-}
-.ui-datepicker-multi .ui-datepicker-group {
-	float: left;
-}
-.ui-datepicker-multi .ui-datepicker-group table {
-	width: 95%;
-	margin: 0 auto .4em;
-}
-.ui-datepicker-multi-2 .ui-datepicker-group {
-	width: 50%;
-}
-.ui-datepicker-multi-3 .ui-datepicker-group {
-	width: 33.3%;
-}
-.ui-datepicker-multi-4 .ui-datepicker-group {
-	width: 25%;
-}
-.ui-datepicker-multi .ui-datepicker-group-last .ui-datepicker-header,
-.ui-datepicker-multi .ui-datepicker-group-middle .ui-datepicker-header {
-	border-left-width: 0;
-}
-.ui-datepicker-multi .ui-datepicker-buttonpane {
-	clear: left;
-}
-.ui-datepicker-row-break {
-	clear: both;
-	width: 100%;
-	font-size: 0;
-}
-
-/* RTL support */
-.ui-datepicker-rtl {
-	direction: rtl;
-}
-.ui-datepicker-rtl .ui-datepicker-prev {
-	right: 2px;
-	left: auto;
-}
-.ui-datepicker-rtl .ui-datepicker-next {
-	left: 2px;
-	right: auto;
-}
-.ui-datepicker-rtl .ui-datepicker-prev:hover {
-	right: 1px;
-	left: auto;
-}
-.ui-datepicker-rtl .ui-datepicker-next:hover {
-	left: 1px;
-	right: auto;
-}
-.ui-datepicker-rtl .ui-datepicker-buttonpane {
-	clear: right;
-}
-.ui-datepicker-rtl .ui-datepicker-buttonpane button {
-	float: left;
-}
-.ui-datepicker-rtl .ui-datepicker-buttonpane button.ui-datepicker-current,
-.ui-datepicker-rtl .ui-datepicker-group {
-	float: right;
-}
-.ui-datepicker-rtl .ui-datepicker-group-last .ui-datepicker-header,
-.ui-datepicker-rtl .ui-datepicker-group-middle .ui-datepicker-header {
-	border-right-width: 0;
-	border-left-width: 1px;
-}
-
 .ui-dialog {
+	overflow: hidden;
 	position: absolute;
 	top: 0;
 	left: 0;
@@ -418,7 +321,7 @@ button.ui-button::-moz-focus-inner {
 	position: absolute;
 	right: .3em;
 	top: 50%;
-	width: 21px;
+	width: 20px;
 	margin: -10px 0 0 0;
 	padding: 1px;
 	height: 20px;
@@ -454,7 +357,6 @@ button.ui-button::-moz-focus-inner {
 .ui-draggable .ui-dialog-titlebar {
 	cursor: move;
 }
-
 .ui-menu {
 	list-style: none;
 	padding: 2px;
@@ -524,7 +426,6 @@ button.ui-button::-moz-focus-inner {
 	position: static;
 	float: right;
 }
-
 .ui-progressbar {
 	height: 2em;
 	text-align: left;
@@ -543,146 +444,6 @@ button.ui-button::-moz-focus-inner {
 .ui-progressbar-indeterminate .ui-progressbar-value {
 	background-image: none;
 }
-
-.ui-resizable {
-	position: relative;
-}
-.ui-resizable-handle {
-	position: absolute;
-	font-size: 0.1px;
-	display: block;
-}
-.ui-resizable-disabled .ui-resizable-handle,
-.ui-resizable-autohide .ui-resizable-handle {
-	display: none;
-}
-.ui-resizable-n {
-	cursor: n-resize;
-	height: 7px;
-	width: 100%;
-	top: -5px;
-	left: 0;
-}
-.ui-resizable-s {
-	cursor: s-resize;
-	height: 7px;
-	width: 100%;
-	bottom: -5px;
-	left: 0;
-}
-.ui-resizable-e {
-	cursor: e-resize;
-	width: 7px;
-	right: -5px;
-	top: 0;
-	height: 100%;
-}
-.ui-resizable-w {
-	cursor: w-resize;
-	width: 7px;
-	left: -5px;
-	top: 0;
-	height: 100%;
-}
-.ui-resizable-se {
-	cursor: se-resize;
-	width: 12px;
-	height: 12px;
-	right: 1px;
-	bottom: 1px;
-}
-.ui-resizable-sw {
-	cursor: sw-resize;
-	width: 9px;
-	height: 9px;
-	left: -5px;
-	bottom: -5px;
-}
-.ui-resizable-nw {
-	cursor: nw-resize;
-	width: 9px;
-	height: 9px;
-	left: -5px;
-	top: -5px;
-}
-.ui-resizable-ne {
-	cursor: ne-resize;
-	width: 9px;
-	height: 9px;
-	right: -5px;
-	top: -5px;
-}
-
-.ui-selectable-helper {
-	position: absolute;
-	z-index: 100;
-	border: 1px dotted black;
-}
-
-.ui-slider {
-	position: relative;
-	text-align: left;
-}
-.ui-slider .ui-slider-handle {
-	position: absolute;
-	z-index: 2;
-	width: 1.2em;
-	height: 1.2em;
-	cursor: default;
-}
-.ui-slider .ui-slider-range {
-	position: absolute;
-	z-index: 1;
-	font-size: .7em;
-	display: block;
-	border: 0;
-	background-position: 0 0;
-}
-
-/* For IE8 - See #6727 */
-.ui-slider.ui-state-disabled .ui-slider-handle,
-.ui-slider.ui-state-disabled .ui-slider-range {
-	filter: inherit;
-}
-
-.ui-slider-horizontal {
-	height: .8em;
-}
-.ui-slider-horizontal .ui-slider-handle {
-	top: -.3em;
-	margin-left: -.6em;
-}
-.ui-slider-horizontal .ui-slider-range {
-	top: 0;
-	height: 100%;
-}
-.ui-slider-horizontal .ui-slider-range-min {
-	left: 0;
-}
-.ui-slider-horizontal .ui-slider-range-max {
-	right: 0;
-}
-
-.ui-slider-vertical {
-	width: .8em;
-	height: 100px;
-}
-.ui-slider-vertical .ui-slider-handle {
-	left: -.3em;
-	margin-left: 0;
-	margin-bottom: -.6em;
-}
-.ui-slider-vertical .ui-slider-range {
-	left: 0;
-	width: 100%;
-}
-.ui-slider-vertical .ui-slider-range-min {
-	bottom: 0;
-}
-.ui-slider-vertical .ui-slider-range-max {
-	top: 0;
-}
-
 .ui-spinner {
 	position: relative;
 	display: inline-block;
@@ -713,13 +474,13 @@ button.ui-button::-moz-focus-inner {
 	overflow: hidden;
 	right: 0;
 }
-/* more specificity required here to overide default borders */
+/* more specificity required here to override default borders */
 .ui-spinner a.ui-spinner-button {
 	border-top: none;
 	border-bottom: none;
 	border-right: none;
 }
-/* vertical centre icon */
+/* vertically center icon */
 .ui-spinner .ui-icon {
 	position: absolute;
 	margin-top: -8px;
@@ -738,7 +499,6 @@ button.ui-button::-moz-focus-inner {
 	/* need to fix icons sprite */
 	background-position: -65px -16px;
 }
-
 .ui-tabs {
 	position: relative;/* position: relative prevents IE scroll bug (element with position: relative inside container with overflow: auto appear as "fixed") */
 	padding: .2em;
@@ -757,7 +517,7 @@ button.ui-button::-moz-focus-inner {
 	padding: 0;
 	white-space: nowrap;
 }
-.ui-tabs .ui-tabs-nav li a {
+.ui-tabs .ui-tabs-nav .ui-tabs-anchor {
 	float: left;
 	padding: .5em 1em;
 	text-decoration: none;
@@ -766,13 +526,12 @@ button.ui-button::-moz-focus-inner {
 	margin-bottom: -1px;
 	padding-bottom: 1px;
 }
-.ui-tabs .ui-tabs-nav li.ui-tabs-active a,
-.ui-tabs .ui-tabs-nav li.ui-state-disabled a,
-.ui-tabs .ui-tabs-nav li.ui-tabs-loading a {
+.ui-tabs .ui-tabs-nav li.ui-tabs-active .ui-tabs-anchor,
+.ui-tabs .ui-tabs-nav li.ui-state-disabled .ui-tabs-anchor,
+.ui-tabs .ui-tabs-nav li.ui-tabs-loading .ui-tabs-anchor {
 	cursor: text;
 }
-.ui-tabs .ui-tabs-nav li a, /* first selector in group seems obsolete, but required to overcome bug in Opera applying cursor: text overall if defined elsewhere... */
-.ui-tabs-collapsible .ui-tabs-nav li.ui-tabs-active a {
+.ui-tabs-collapsible .ui-tabs-nav li.ui-tabs-active .ui-tabs-anchor {
 	cursor: pointer;
 }
 .ui-tabs .ui-tabs-panel {
@@ -781,7 +540,6 @@ button.ui-button::-moz-focus-inner {
 	padding: 1em 1.4em;
 	background: none;
 }
-
 .ui-tooltip {
 	padding: 8px;
 	position: absolute;
@@ -797,8 +555,8 @@ body .ui-tooltip {
 /* Component containers
 ----------------------------------*/
 .ui-widget {
-	font-family: Verdana,Arial,sans-serif/*{ffDefault}*/;
-	font-size: 1.1em/*{fsDefault}*/;
+	font-family: Verdana,Arial,sans-serif;
+	font-size: 1.1em;
 }
 .ui-widget .ui-widget {
 	font-size: 1em;
@@ -807,25 +565,25 @@ body .ui-tooltip {
 .ui-widget select,
 .ui-widget textarea,
 .ui-widget button {
-	font-family: Verdana,Arial,sans-serif/*{ffDefault}*/;
+	font-family: Verdana,Arial,sans-serif;
 	font-size: 1em;
 }
 .ui-widget-content {
-	border: 1px solid #aaaaaa/*{borderColorContent}*/;
-	background: #ffffff/*{bgColorContent}*/ url(images/ui-bg_flat_75_ffffff_40x100.png)/*{bgImgUrlContent}*/ 50%/*{bgContentXPos}*/ 50%/*{bgContentYPos}*/ repeat-x/*{bgContentRepeat}*/;
-	color: #222222/*{fcContent}*/;
+	border: 1px solid #aaaaaa;
+	background: #ffffff url("images/ui-bg_flat_75_ffffff_40x100.png") 50% 50% repeat-x;
+	color: #222222;
 }
 .ui-widget-content a {
-	color: #222222/*{fcContent}*/;
+	color: #222222;
 }
 .ui-widget-header {
-	border: 1px solid #aaaaaa/*{borderColorHeader}*/;
-	background: #cccccc/*{bgColorHeader}*/ url(images/ui-bg_highlight-soft_75_cccccc_1x100.png)/*{bgImgUrlHeader}*/ 50%/*{bgHeaderXPos}*/ 50%/*{bgHeaderYPos}*/ repeat-x/*{bgHeaderRepeat}*/;
-	color: #222222/*{fcHeader}*/;
+	border: 1px solid #aaaaaa;
+	background: #cccccc url("images/ui-bg_highlight-soft_75_cccccc_1x100.png") 50% 50% repeat-x;
+	color: #222222;
 	font-weight: bold;
 }
 .ui-widget-header a {
-	color: #222222/*{fcHeader}*/;
+	color: #222222;
 }
 
 /* Interaction states
@@ -833,15 +591,15 @@ body .ui-tooltip {
 .ui-state-default,
 .ui-widget-content .ui-state-default,
 .ui-widget-header .ui-state-default {
-	border: 1px solid #d3d3d3/*{borderColorDefault}*/;
-	background: #e6e6e6/*{bgColorDefault}*/ url(images/ui-bg_glass_75_e6e6e6_1x400.png)/*{bgImgUrlDefault}*/ 50%/*{bgDefaultXPos}*/ 50%/*{bgDefaultYPos}*/ repeat-x/*{bgDefaultRepeat}*/;
-	font-weight: normal/*{fwDefault}*/;
-	color: #555555/*{fcDefault}*/;
+	border: 1px solid #d3d3d3;
+	background: #e6e6e6 url("images/ui-bg_glass_75_e6e6e6_1x400.png") 50% 50% repeat-x;
+	font-weight: normal;
+	color: #555555;
 }
 .ui-state-default a,
 .ui-state-default a:link,
 .ui-state-default a:visited {
-	color: #555555/*{fcDefault}*/;
+	color: #555555;
 	text-decoration: none;
 }
 .ui-state-hover,
@@ -850,30 +608,34 @@ body .ui-tooltip {
 .ui-state-focus,
 .ui-widget-content .ui-state-focus,
 .ui-widget-header .ui-state-focus {
-	border: 1px solid #999999/*{borderColorHover}*/;
-	background: #dadada/*{bgColorHover}*/ url(images/ui-bg_glass_75_dadada_1x400.png)/*{bgImgUrlHover}*/ 50%/*{bgHoverXPos}*/ 50%/*{bgHoverYPos}*/ repeat-x/*{bgHoverRepeat}*/;
-	font-weight: normal/*{fwDefault}*/;
-	color: #212121/*{fcHover}*/;
+	border: 1px solid #999999;
+	background: #dadada url("images/ui-bg_glass_75_dadada_1x400.png") 50% 50% repeat-x;
+	font-weight: normal;
+	color: #212121;
 }
 .ui-state-hover a,
 .ui-state-hover a:hover,
 .ui-state-hover a:link,
-.ui-state-hover a:visited {
-	color: #212121/*{fcHover}*/;
+.ui-state-hover a:visited,
+.ui-state-focus a,
+.ui-state-focus a:hover,
+.ui-state-focus a:link,
+.ui-state-focus a:visited {
+	color: #212121;
 	text-decoration: none;
 }
 .ui-state-active,
 .ui-widget-content .ui-state-active,
 .ui-widget-header .ui-state-active {
-	border: 1px solid #aaaaaa/*{borderColorActive}*/;
-	background: #ffffff/*{bgColorActive}*/ url(images/ui-bg_glass_65_ffffff_1x400.png)/*{bgImgUrlActive}*/ 50%/*{bgActiveXPos}*/ 50%/*{bgActiveYPos}*/ repeat-x/*{bgActiveRepeat}*/;
-	font-weight: normal/*{fwDefault}*/;
-	color: #212121/*{fcActive}*/;
+	border: 1px solid #aaaaaa;
+	background: #ffffff url("images/ui-bg_glass_65_ffffff_1x400.png") 50% 50% repeat-x;
+	font-weight: normal;
+	color: #212121;
 }
 .ui-state-active a,
 .ui-state-active a:link,
 .ui-state-active a:visited {
-	color: #212121/*{fcActive}*/;
+	color: #212121;
 	text-decoration: none;
 }
 
@@ -882,31 +644,31 @@ body .ui-tooltip {
 .ui-state-highlight,
 .ui-widget-content .ui-state-highlight,
 .ui-widget-header .ui-state-highlight {
-	border: 1px solid #fcefa1/*{borderColorHighlight}*/;
-	background: #fbf9ee/*{bgColorHighlight}*/ url(images/ui-bg_glass_55_fbf9ee_1x400.png)/*{bgImgUrlHighlight}*/ 50%/*{bgHighlightXPos}*/ 50%/*{bgHighlightYPos}*/ repeat-x/*{bgHighlightRepeat}*/;
-	color: #363636/*{fcHighlight}*/;
+	border: 1px solid #fcefa1;
+	background: #fbf9ee url("images/ui-bg_glass_55_fbf9ee_1x400.png") 50% 50% repeat-x;
+	color: #363636;
 }
 .ui-state-highlight a,
 .ui-widget-content .ui-state-highlight a,
 .ui-widget-header .ui-state-highlight a {
-	color: #363636/*{fcHighlight}*/;
+	color: #363636;
 }
 .ui-state-error,
 .ui-widget-content .ui-state-error,
 .ui-widget-header .ui-state-error {
-	border: 1px solid #cd0a0a/*{borderColorError}*/;
-	background: #fef1ec/*{bgColorError}*/ url(images/ui-bg_glass_95_fef1ec_1x400.png)/*{bgImgUrlError}*/ 50%/*{bgErrorXPos}*/ 50%/*{bgErrorYPos}*/ repeat-x/*{bgErrorRepeat}*/;
-	color: #cd0a0a/*{fcError}*/;
+	border: 1px solid #cd0a0a;
+	background: #fef1ec url("images/ui-bg_glass_95_fef1ec_1x400.png") 50% 50% repeat-x;
+	color: #cd0a0a;
 }
 .ui-state-error a,
 .ui-widget-content .ui-state-error a,
 .ui-widget-header .ui-state-error a {
-	color: #cd0a0a/*{fcError}*/;
+	color: #cd0a0a;
 }
 .ui-state-error-text,
 .ui-widget-content .ui-state-error-text,
 .ui-widget-header .ui-state-error-text {
-	color: #cd0a0a/*{fcError}*/;
+	color: #cd0a0a;
 }
 .ui-priority-primary,
 .ui-widget-content .ui-priority-primary,
@@ -941,27 +703,27 @@ body .ui-tooltip {
 }
 .ui-icon,
 .ui-widget-content .ui-icon {
-	background-image: url(images/ui-icons_222222_256x240.png)/*{iconsContent}*/;
+	background-image: url("images/ui-icons_222222_256x240.png");
 }
 .ui-widget-header .ui-icon {
-	background-image: url(images/ui-icons_222222_256x240.png)/*{iconsHeader}*/;
+	background-image: url("images/ui-icons_222222_256x240.png");
 }
 .ui-state-default .ui-icon {
-	background-image: url(images/ui-icons_888888_256x240.png)/*{iconsDefault}*/;
+	background-image: url("images/ui-icons_888888_256x240.png");
 }
 .ui-state-hover .ui-icon,
 .ui-state-focus .ui-icon {
-	background-image: url(images/ui-icons_454545_256x240.png)/*{iconsHover}*/;
+	background-image: url("images/ui-icons_454545_256x240.png");
 }
 .ui-state-active .ui-icon {
-	background-image: url(images/ui-icons_454545_256x240.png)/*{iconsActive}*/;
+	background-image: url("images/ui-icons_454545_256x240.png");
 }
 .ui-state-highlight .ui-icon {
-	background-image: url(images/ui-icons_2e83ff_256x240.png)/*{iconsHighlight}*/;
+	background-image: url("images/ui-icons_2e83ff_256x240.png");
 }
 .ui-state-error .ui-icon,
 .ui-state-error-text .ui-icon {
-	background-image: url(images/ui-icons_cd0a0a_256x240.png)/*{iconsError}*/;
+	background-image: url("images/ui-icons_cd0a0a_256x240.png");
 }
 
 /* positioning */
@@ -1151,38 +913,38 @@ body .ui-tooltip {
 .ui-corner-top,
 .ui-corner-left,
 .ui-corner-tl {
-	border-top-left-radius: 4px/*{cornerRadius}*/;
+	border-top-left-radius: 4px;
 }
 .ui-corner-all,
 .ui-corner-top,
 .ui-corner-right,
 .ui-corner-tr {
-	border-top-right-radius: 4px/*{cornerRadius}*/;
+	border-top-right-radius: 4px;
 }
 .ui-corner-all,
 .ui-corner-bottom,
 .ui-corner-left,
 .ui-corner-bl {
-	border-bottom-left-radius: 4px/*{cornerRadius}*/;
+	border-bottom-left-radius: 4px;
 }
 .ui-corner-all,
 .ui-corner-bottom,
 .ui-corner-right,
 .ui-corner-br {
-	border-bottom-right-radius: 4px/*{cornerRadius}*/;
+	border-bottom-right-radius: 4px;
 }
 
 /* Overlays */
 .ui-widget-overlay {
-	background: #aaaaaa/*{bgColorOverlay}*/ url(images/ui-bg_flat_0_aaaaaa_40x100.png)/*{bgImgUrlOverlay}*/ 50%/*{bgOverlayXPos}*/ 50%/*{bgOverlayYPos}*/ repeat-x/*{bgOverlayRepeat}*/;
-	opacity: .3/*{opacityOverlay}*/;
-	filter: Alpha(Opacity=30)/*{opacityFilterOverlay}*/;
+	background: #aaaaaa url("images/ui-bg_flat_0_aaaaaa_40x100.png") 50% 50% repeat-x;
+	opacity: .3;
+	filter: Alpha(Opacity=30);
 }
 .ui-widget-shadow {
-	margin: -8px/*{offsetTopShadow}*/ 0 0 -8px/*{offsetLeftShadow}*/;
-	padding: 8px/*{thicknessShadow}*/;
-	background: #aaaaaa/*{bgColorShadow}*/ url(images/ui-bg_flat_0_aaaaaa_40x100.png)/*{bgImgUrlShadow}*/ 50%/*{bgShadowXPos}*/ 50%/*{bgShadowYPos}*/ repeat-x/*{bgShadowRepeat}*/;
-	opacity: .3/*{opacityShadow}*/;
-	filter: Alpha(Opacity=30)/*{opacityFilterShadow}*/;
-	border-radius: 8px/*{cornerRadiusShadow}*/;
+	margin: -8px 0 0 -8px;
+	padding: 8px;
+	background: #aaaaaa url("images/ui-bg_flat_0_aaaaaa_40x100.png") 50% 50% repeat-x;
+	opacity: .3;
+	filter: Alpha(Opacity=30);
+	border-radius: 8px;
 }

inst/www/shared/selectize/css/selectize.bootstrap2.css

@@ -1,5 +1,5 @@
 /**
- * selectize.bootstrap2.css (v0.8.0) - Bootstrap 2 Theme
+ * selectize.bootstrap2.css (v0.9.1) - Bootstrap 2 Theme
  * Copyright (c) 2013 Brian Reavis & contributors
  *
  * Licensed under the Apache License, Version 2.0 (the "License"); you may not use this
@@ -13,387 +13,337 @@
  *
  * @author Brian Reavis <brian@thirdroute.com>
  */
-
 .selectize-control.plugin-drag_drop.multi > .selectize-input > div.ui-sortable-placeholder {
+  visibility: visible !important;
   background: #f2f2f2 !important;
   background: rgba(0, 0, 0, 0.06) !important;
   border: 0 none !important;
-  visibility: visible !important;
   -webkit-box-shadow: inset 0 0 12px 4px #ffffff;
-          box-shadow: inset 0 0 12px 4px #ffffff;
+  box-shadow: inset 0 0 12px 4px #ffffff;
 }
-
 .selectize-control.plugin-drag_drop .ui-sortable-placeholder::after {
   content: '!';
   visibility: hidden;
 }
-
 .selectize-control.plugin-drag_drop .ui-sortable-helper {
   -webkit-box-shadow: 0 2px 5px rgba(0, 0, 0, 0.2);
-          box-shadow: 0 2px 5px rgba(0, 0, 0, 0.2);
+  box-shadow: 0 2px 5px rgba(0, 0, 0, 0.2);
 }
-
 .selectize-dropdown-header {
   position: relative;
   padding: 3px 10px;
-  background: #f8f8f8;
   border-bottom: 1px solid #d0d0d0;
+  background: #f8f8f8;
   -webkit-border-radius: 4px 4px 0 0;
-     -moz-border-radius: 4px 4px 0 0;
-          border-radius: 4px 4px 0 0;
+  -moz-border-radius: 4px 4px 0 0;
+  border-radius: 4px 4px 0 0;
 }
-
 .selectize-dropdown-header-close {
   position: absolute;
-  top: 50%;
   right: 10px;
-  margin-top: -12px;
-  font-size: 20px !important;
-  line-height: 20px;
+  top: 50%;
   color: #333333;
   opacity: 0.4;
+  margin-top: -12px;
+  line-height: 20px;
+  font-size: 20px !important;
 }
-
 .selectize-dropdown-header-close:hover {
   color: #000000;
 }
-
 .selectize-dropdown.plugin-optgroup_columns .optgroup {
-  float: left;
-  border-top: 0 none;
   border-right: 1px solid #f2f2f2;
+  border-top: 0 none;
+  float: left;
   -webkit-box-sizing: border-box;
-     -moz-box-sizing: border-box;
-          box-sizing: border-box;
+  -moz-box-sizing: border-box;
+  box-sizing: border-box;
 }
-
 .selectize-dropdown.plugin-optgroup_columns .optgroup:last-child {
   border-right: 0 none;
 }
-
 .selectize-dropdown.plugin-optgroup_columns .optgroup:before {
   display: none;
 }
-
 .selectize-dropdown.plugin-optgroup_columns .optgroup-header {
   border-top: 0 none;
 }
-
 .selectize-control.plugin-remove_button [data-value] {
   position: relative;
   padding-right: 24px !important;
 }
-
 .selectize-control.plugin-remove_button [data-value] .remove {
+  z-index: 1;
+  /* fixes ie bug (see #392) */
   position: absolute;
   top: 0;
   right: 0;
   bottom: 0;
-  display: inline-block;
   width: 17px;
-  padding: 1px 0 0 0;
-  font-size: 12px;
-  font-weight: bold;
-  color: inherit;
   text-align: center;
+  font-weight: bold;
+  font-size: 12px;
+  color: inherit;
   text-decoration: none;
   vertical-align: middle;
+  display: inline-block;
+  padding: 1px 0 0 0;
   border-left: 1px solid #cccccc;
   -webkit-border-radius: 0 2px 2px 0;
-     -moz-border-radius: 0 2px 2px 0;
-          border-radius: 0 2px 2px 0;
+  -moz-border-radius: 0 2px 2px 0;
+  border-radius: 0 2px 2px 0;
   -webkit-box-sizing: border-box;
-     -moz-box-sizing: border-box;
-          box-sizing: border-box;
+  -moz-box-sizing: border-box;
+  box-sizing: border-box;
 }
-
 .selectize-control.plugin-remove_button [data-value] .remove:hover {
   background: rgba(0, 0, 0, 0.05);
 }
-
 .selectize-control.plugin-remove_button [data-value].active .remove {
   border-left-color: #0077b3;
 }
-
 .selectize-control.plugin-remove_button .disabled [data-value] .remove:hover {
   background: none;
 }
-
 .selectize-control.plugin-remove_button .disabled [data-value] .remove {
   border-left-color: #e0e0e0;
 }
-
 .selectize-control {
   position: relative;
 }
-
 .selectize-dropdown,
 .selectize-input,
 .selectize-input input {
+  color: #333333;
   font-family: "Helvetica Neue", Helvetica, Arial, sans-serif;
   font-size: 14px;
-  -webkit-font-smoothing: inherit;
   line-height: 20px;
-  color: #333333;
+  -webkit-font-smoothing: inherit;
 }
-
 .selectize-input,
 .selectize-control.single .selectize-input.input-active {
-  display: inline-block;
-  cursor: text;
   background: #ffffff;
+  cursor: text;
+  display: inline-block;
 }
-
 .selectize-input {
-  position: relative;
-  z-index: 1;
+  border: 1px solid #d0d0d0;
+  padding: 7px 10px;
   display: inline-block;
   width: 100%;
-  padding: 7px 10px;
   overflow: hidden;
-  border: 1px solid #d0d0d0;
-  -webkit-border-radius: 4px;
-     -moz-border-radius: 4px;
-          border-radius: 4px;
-  -webkit-box-shadow: none;
-          box-shadow: none;
+  position: relative;
+  z-index: 1;
   -webkit-box-sizing: border-box;
-     -moz-box-sizing: border-box;
-          box-sizing: border-box;
+  -moz-box-sizing: border-box;
+  box-sizing: border-box;
+  -webkit-box-shadow: none;
+  box-shadow: none;
+  -webkit-border-radius: 4px;
+  -moz-border-radius: 4px;
+  border-radius: 4px;
 }
-
 .selectize-control.multi .selectize-input.has-items {
   padding: 5px 10px 2px;
 }
-
 .selectize-input.full {
   background-color: #ffffff;
 }
-
 .selectize-input.disabled,
 .selectize-input.disabled * {
   cursor: default !important;
 }
-
 .selectize-input.focus {
   -webkit-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.15);
-          box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.15);
+  box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.15);
 }
-
 .selectize-input.dropdown-active {
   -webkit-border-radius: 4px 4px 0 0;
-     -moz-border-radius: 4px 4px 0 0;
-          border-radius: 4px 4px 0 0;
+  -moz-border-radius: 4px 4px 0 0;
+  border-radius: 4px 4px 0 0;
 }
-
 .selectize-input > * {
+  vertical-align: baseline;
   display: -moz-inline-stack;
   display: inline-block;
-  *display: inline;
-  vertical-align: baseline;
   zoom: 1;
+  *display: inline;
 }
-
 .selectize-control.multi .selectize-input > div {
-  padding: 1px 3px;
-  margin: 0 3px 3px 0;
-  color: #333333;
   cursor: pointer;
+  margin: 0 3px 3px 0;
+  padding: 1px 3px;
   background: #e6e6e6;
+  color: #333333;
   border: 1px solid #cccccc;
 }
-
 .selectize-control.multi .selectize-input > div.active {
-  color: #ffffff;
   background: #0088cc;
+  color: #ffffff;
   border: 1px solid #0077b3;
 }
-
 .selectize-control.multi .selectize-input.disabled > div,
 .selectize-control.multi .selectize-input.disabled > div.active {
   color: #474747;
   background: #fafafa;
   border: 1px solid #e0e0e0;
 }
-
 .selectize-input > input {
-  max-width: 100% !important;
-  max-height: none !important;
-  min-height: 0 !important;
   padding: 0 !important;
+  min-height: 0 !important;
+  max-height: none !important;
+  max-width: 100% !important;
   margin: 0 !important;
-  line-height: inherit !important;
   text-indent: 0 !important;
-  background: none !important;
   border: 0 none !important;
-  -webkit-box-shadow: none !important;
-          box-shadow: none !important;
+  background: none !important;
+  line-height: inherit !important;
   -webkit-user-select: auto !important;
+  -webkit-box-shadow: none !important;
+  box-shadow: none !important;
+}
+.selectize-input > input::-ms-clear {
+  display: none;
 }
-
 .selectize-input > input:focus {
   outline: none !important;
 }
-
 .selectize-input::after {
+  content: ' ';
   display: block;
   clear: left;
-  content: ' ';
 }
-
 .selectize-input.dropdown-active::before {
+  content: ' ';
+  display: block;
   position: absolute;
-  right: 0;
+  background: #e5e5e5;
+  height: 1px;
   bottom: 0;
   left: 0;
-  display: block;
-  height: 1px;
-  background: #e5e5e5;
-  content: ' ';
+  right: 0;
 }
-
 .selectize-dropdown {
   position: absolute;
   z-index: 10;
-  margin: -1px 0 0 0;
-  background: #ffffff;
   border: 1px solid #d0d0d0;
+  background: #ffffff;
+  margin: -1px 0 0 0;
   border-top: 0 none;
-  -webkit-border-radius: 0 0 4px 4px;
-     -moz-border-radius: 0 0 4px 4px;
-          border-radius: 0 0 4px 4px;
-  -webkit-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.1);
-          box-shadow: 0 1px 3px rgba(0, 0, 0, 0.1);
   -webkit-box-sizing: border-box;
-     -moz-box-sizing: border-box;
-          box-sizing: border-box;
+  -moz-box-sizing: border-box;
+  box-sizing: border-box;
+  -webkit-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.1);
+  box-shadow: 0 1px 3px rgba(0, 0, 0, 0.1);
+  -webkit-border-radius: 0 0 4px 4px;
+  -moz-border-radius: 0 0 4px 4px;
+  border-radius: 0 0 4px 4px;
 }
-
 .selectize-dropdown [data-selectable] {
-  overflow: hidden;
   cursor: pointer;
+  overflow: hidden;
 }
-
 .selectize-dropdown [data-selectable] .highlight {
   background: rgba(255, 237, 40, 0.4);
   -webkit-border-radius: 1px;
-     -moz-border-radius: 1px;
-          border-radius: 1px;
+  -moz-border-radius: 1px;
+  border-radius: 1px;
 }
-
 .selectize-dropdown [data-selectable],
 .selectize-dropdown .optgroup-header {
   padding: 3px 10px;
 }
-
 .selectize-dropdown .optgroup:first-child .optgroup-header {
   border-top: 0 none;
 }
-
 .selectize-dropdown .optgroup-header {
   color: #999999;
-  cursor: default;
   background: #ffffff;
+  cursor: default;
 }
-
 .selectize-dropdown .active {
-  color: #ffffff;
   background-color: #0088cc;
+  color: #ffffff;
 }
-
 .selectize-dropdown .active.create {
   color: #ffffff;
 }
-
 .selectize-dropdown .create {
   color: rgba(51, 51, 51, 0.5);
 }
-
 .selectize-dropdown-content {
-  max-height: 200px;
-  overflow-x: hidden;
   overflow-y: auto;
+  overflow-x: hidden;
+  max-height: 200px;
 }
-
 .selectize-control.single .selectize-input,
 .selectize-control.single .selectize-input input {
   cursor: pointer;
 }
-
 .selectize-control.single .selectize-input.input-active,
 .selectize-control.single .selectize-input.input-active input {
   cursor: text;
 }
-
 .selectize-control.single .selectize-input:after {
+  content: ' ';
+  display: block;
   position: absolute;
   top: 50%;
   right: 15px;
-  display: block;
+  margin-top: -3px;
   width: 0;
   height: 0;
-  margin-top: -3px;
-  border-color: #000000 transparent transparent transparent;
   border-style: solid;
   border-width: 5px 5px 0 5px;
-  content: ' ';
+  border-color: #000000 transparent transparent transparent;
 }
-
 .selectize-control.single .selectize-input.dropdown-active:after {
   margin-top: -4px;
-  border-color: transparent transparent #000000 transparent;
   border-width: 0 5px 5px 5px;
+  border-color: transparent transparent #000000 transparent;
 }
-
 .selectize-control.rtl.single .selectize-input:after {
-  right: auto;
   left: 15px;
+  right: auto;
 }
-
 .selectize-control.rtl .selectize-input > input {
   margin: 0 4px 0 -2px !important;
 }
-
 .selectize-control .selectize-input.disabled {
-  background-color: #ffffff;
   opacity: 0.5;
+  background-color: #ffffff;
 }
-
 .selectize-dropdown {
-  z-index: 1000;
   margin: 2px 0 0 0;
+  z-index: 1000;
   border: 1px solid rgba(0, 0, 0, 0.2);
   border-radius: 4px;
   -webkit-box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2);
-     -moz-box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2);
-          box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2);
+  -moz-box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2);
+  box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2);
 }
-
 .selectize-dropdown .optgroup-header {
   font-size: 11px;
   font-weight: bold;
   text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5);
   text-transform: uppercase;
 }
-
 .selectize-dropdown .optgroup:first-child:before {
   display: none;
 }
-
 .selectize-dropdown .optgroup:before {
+  content: ' ';
   display: block;
   *width: 100%;
   height: 1px;
   margin: 9px 1px;
   *margin: -5px 0 5px;
-  margin-right: -10px;
-  margin-left: -10px;
   overflow: hidden;
   background-color: #e5e5e5;
   border-bottom: 1px solid #ffffff;
-  content: ' ';
+  margin-left: -10px;
+  margin-right: -10px;
 }
-
 .selectize-dropdown [data-selectable].active {
   background-color: #0081c2;
   background-image: -moz-linear-gradient(top, #0088cc, #0077b3);
@@ -404,32 +354,26 @@
   background-repeat: repeat-x;
   filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff0088cc', endColorstr='#ff0077b3', GradientType=0);
 }
-
 .selectize-dropdown-content {
   padding: 5px 0;
 }
-
 .selectize-dropdown-header {
   padding: 6px 10px;
 }
-
 .selectize-input {
-  -webkit-transition: border linear 0.2s, box-shadow linear 0.2s;
-     -moz-transition: border linear 0.2s, box-shadow linear 0.2s;
-       -o-transition: border linear 0.2s, box-shadow linear 0.2s;
-          transition: border linear 0.2s, box-shadow linear 0.2s;
+  -webkit-transition: border linear .2s, box-shadow linear .2s;
+  -moz-transition: border linear .2s, box-shadow linear .2s;
+  -o-transition: border linear .2s, box-shadow linear .2s;
+  transition: border linear .2s, box-shadow linear .2s;
 }
-
 .selectize-input.dropdown-active {
   -webkit-border-radius: 4px;
-     -moz-border-radius: 4px;
-          border-radius: 4px;
+  -moz-border-radius: 4px;
+  border-radius: 4px;
 }
-
 .selectize-input.dropdown-active::before {
   display: none;
 }
-
 .selectize-input.input-active,
 .selectize-input.input-active:hover,
 .selectize-control.multi .selectize-input.focus {
@@ -437,31 +381,30 @@
   border-color: rgba(82, 168, 236, 0.8) !important;
   outline: 0 !important;
   outline: thin dotted \9 !important;
-  -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 8px rgba(82, 168, 236, 0.6) !important;
-     -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 8px rgba(82, 168, 236, 0.6) !important;
-          box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 8px rgba(82, 168, 236, 0.6) !important;
+  -webkit-box-shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px rgba(82,168,236,.6) !important;
+  -moz-box-shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px rgba(82,168,236,.6) !important;
+  box-shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px rgba(82,168,236,.6) !important;
 }
-
 .selectize-control.single .selectize-input {
   color: #333333;
   text-shadow: 0 1px 1px rgba(255, 255, 255, 0.75);
   background-color: #f5f5f5;
-  *background-color: #e6e6e6;
   background-image: -moz-linear-gradient(top, #ffffff, #e6e6e6);
   background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ffffff), to(#e6e6e6));
   background-image: -webkit-linear-gradient(top, #ffffff, #e6e6e6);
   background-image: -o-linear-gradient(top, #ffffff, #e6e6e6);
   background-image: linear-gradient(to bottom, #ffffff, #e6e6e6);
   background-repeat: repeat-x;
+  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffffffff', endColorstr='#ffe6e6e6', GradientType=0);
   border-color: #e6e6e6 #e6e6e6 #bfbfbf;
   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(startColorstr='#ffffffff', endColorstr='#ffe6e6e6', GradientType=0);
-  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
-  -webkit-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05);
-     -moz-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05);
-          box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05);
+  *background-color: #e6e6e6;
+  /* Darken IE7 buttons by default so they stand out more given they won't have borders */
+  filter: progid:DXImageTransform.Microsoft.gradient(enabled = false);
+  -webkit-box-shadow: inset 0 1px 0 rgba(255,255,255,.2), 0 1px 2px rgba(0,0,0,.05);
+  -moz-box-shadow: inset 0 1px 0 rgba(255,255,255,.2), 0 1px 2px rgba(0,0,0,.05);
+  box-shadow: inset 0 1px 0 rgba(255,255,255,.2), 0 1px 2px rgba(0,0,0,.05);
 }
-
 .selectize-control.single .selectize-input:hover,
 .selectize-control.single .selectize-input:focus,
 .selectize-control.single .selectize-input:active,
@@ -472,79 +415,72 @@
   background-color: #e6e6e6;
   *background-color: #d9d9d9;
 }
-
 .selectize-control.single .selectize-input:active,
 .selectize-control.single .selectize-input.active {
   background-color: #cccccc \9;
 }
-
 .selectize-control.single .selectize-input:hover {
   color: #333333;
   text-decoration: none;
   background-position: 0 -15px;
   -webkit-transition: background-position 0.1s linear;
-     -moz-transition: background-position 0.1s linear;
-       -o-transition: background-position 0.1s linear;
-          transition: background-position 0.1s linear;
+  -moz-transition: background-position 0.1s linear;
+  -o-transition: background-position 0.1s linear;
+  transition: background-position 0.1s linear;
 }
-
 .selectize-control.single .selectize-input.disabled {
   background: #e6e6e6 !important;
   -webkit-box-shadow: none;
-     -moz-box-shadow: none;
-          box-shadow: none;
+  -moz-box-shadow: none;
+  box-shadow: none;
 }
-
 .selectize-control.multi .selectize-input {
   -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075);
-     -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075);
-          box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075);
+  -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075);
+  box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075);
 }
-
 .selectize-control.multi .selectize-input.has-items {
-  padding-right: 7px;
   padding-left: 7px;
+  padding-right: 7px;
 }
-
 .selectize-control.multi .selectize-input > div {
   color: #333333;
   text-shadow: none;
   background-color: #f5f5f5;
-  *background-color: #e6e6e6;
   background-image: -moz-linear-gradient(top, #ffffff, #e6e6e6);
   background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ffffff), to(#e6e6e6));
   background-image: -webkit-linear-gradient(top, #ffffff, #e6e6e6);
   background-image: -o-linear-gradient(top, #ffffff, #e6e6e6);
   background-image: linear-gradient(to bottom, #ffffff, #e6e6e6);
   background-repeat: repeat-x;
-  border: 1px solid #cccccc;
+  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffffffff', endColorstr='#ffe6e6e6', GradientType=0);
   border-color: #e6e6e6 #e6e6e6 #bfbfbf;
   border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
+  *background-color: #e6e6e6;
+  border: 1px solid #cccccc;
   -webkit-border-radius: 4px;
-     -moz-border-radius: 4px;
-          border-radius: 4px;
-  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffffffff', endColorstr='#ffe6e6e6', GradientType=0);
-  -webkit-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05);
-     -moz-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05);
-          box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05);
+  -moz-border-radius: 4px;
+  border-radius: 4px;
+  -webkit-box-shadow: inset 0 1px 0 rgba(255,255,255,.2), 0 1px 2px rgba(0,0,0,.05);
+  -moz-box-shadow: inset 0 1px 0 rgba(255,255,255,.2), 0 1px 2px rgba(0,0,0,.05);
+  box-shadow: inset 0 1px 0 rgba(255,255,255,.2), 0 1px 2px rgba(0,0,0,.05);
 }
-
 .selectize-control.multi .selectize-input > div.active {
+  -webkit-box-shadow: 0 1px 2px rgba(0,0,0,.05);
+  -moz-box-shadow: 0 1px 2px rgba(0,0,0,.05);
+  box-shadow: 0 1px 2px rgba(0,0,0,.05);
   color: #ffffff;
   text-shadow: none;
   background-color: #0081c2;
-  *background-color: #0088cc;
   background-image: -moz-linear-gradient(top, #0088cc, #0077b3);
   background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#0088cc), to(#0077b3));
   background-image: -webkit-linear-gradient(top, #0088cc, #0077b3);
   background-image: -o-linear-gradient(top, #0088cc, #0077b3);
   background-image: linear-gradient(to bottom, #0088cc, #0077b3);
   background-repeat: repeat-x;
-  border: 1px solid #0088cc;
+  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff0088cc', endColorstr='#ff0077b3', GradientType=0);
   border-color: #0077b3 #0077b3 #004466;
   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(startColorstr='#ff0088cc', endColorstr='#ff0077b3', GradientType=0);
-  -webkit-box-shadow: 0 1px 2px rgba(0, 0, 0, 0.05);
-     -moz-box-shadow: 0 1px 2px rgba(0, 0, 0, 0.05);
-          box-shadow: 0 1px 2px rgba(0, 0, 0, 0.05);
-}
+  *background-color: #0088cc;
+  border: 1px solid #0088cc;
+}

inst/www/shared/shiny.css

@@ -13,11 +13,19 @@ table.data td[align=right] {
 
 .shiny-output-error {
   color: red;
+  white-space: pre-wrap;
 }
 .shiny-output-error:before {
   content: 'Error: ';
   font-weight: bold;
 }
+.shiny-output-error-validation {
+  color: #888;
+}
+.shiny-output-error-validation:before {
+  content: '';
+  font-weight: inherit;
+}
 
 .jslider {
   /* Fix jslider running into the control above it */
@@ -28,6 +36,11 @@ table.data td[align=right] {
   background-color: transparent !important;
 }
 
+span.jslider, .selectize-control {
+  width: 220px;
+  max-width: 95%;
+}
+
 .recalculating {
   opacity: 0.3;
   transition: opacity 250ms ease 500ms;
@@ -102,3 +115,32 @@ span.jslider {
 .selectize-control {
   margin-bottom: 10px;
 }
+
+.shiny-frame {
+  border: none;
+}
+
+.shiny-flow-layout>div {
+  display: inline-block;
+  vertical-align: top;
+  padding-right: 12px;
+}
+.shiny-split-layout {
+  width: 100%;
+  white-space: nowrap;
+}
+.shiny-split-layout>div {
+  display: inline-block;
+  vertical-align: top;
+  box-sizing: border-box;
+  overflow: auto;
+}
+
+.shiny-input-panel {
+  padding: 6px 8px;
+  margin-top: 6px;
+  margin-bottom: 6px;
+  background-color: #f5f5f5;
+  border: 1px solid #e3e3e3;
+  border-radius: 2px;
+}

inst/www/shared/shiny.js

@@ -5,14 +5,19 @@
 
   var exports = window.Shiny = window.Shiny || {};
 
+  var isQt = false;
   // For easy handling of Qt quirks using CSS
   if (/\bQt\//.test(window.navigator.userAgent)) {
     $(document.documentElement).addClass('qt');
+    isQt = true;
   }
 
   $(document).on('submit', 'form:not([action])', function(e) {
     e.preventDefault();
   });
+  $(document).on('click', 'a.action-button', function(e) {
+    e.preventDefault();
+  });
 
   // Escape jQuery selector metacharacters: !"#$%&'()*+,./:;<=>?@[\]^`{|}~
   var $escape = exports.$escape = function(val) {
@@ -500,6 +505,15 @@
           protocol = 'wss:';
 
         var defaultPath = window.location.pathname;
+        // some older WebKit browsers return the pathname already decoded;
+        // if we find invalid URL characters in the path, encode them
+        if (!/^([$#!&-;=?-[\]_a-z~]|%[0-9a-fA-F]{2})+$/.test(defaultPath)) {
+          defaultPath = encodeURI(defaultPath);
+          // Bizarrely, QtWebKit requires us to encode these characters *twice*
+          if (isQt) {
+            defaultPath = encodeURI(defaultPath);
+          }
+        }
         if (!/\/$/.test(defaultPath))
           defaultPath += '/';
         defaultPath += 'websocket/';
@@ -1058,10 +1072,25 @@
       this.renderError(el, err);
     };
     this.renderError = function(el, err) {
-      $(el).addClass('shiny-output-error').text(err.message);
+      this.clearError(el);
+      if (err.message === '') {
+        // not really error, but we just need to wait (e.g. action buttons)
+        $(el).empty();
+        return;
+      }
+      var errClass = 'shiny-output-error';
+      if (err.type !== null) {
+        // use the classes of the error condition as CSS class names
+        errClass = errClass + ' ' + $.map(asArray(err.type), function(type) {
+          return errClass + '-' + type;
+        }).join(' ');
+      }
+      $(el).addClass(errClass).text(err.message);
     };
     this.clearError = function(el) {
-      $(el).removeClass('shiny-output-error');
+      $(el).attr('class', function(i, c) {
+        return c.replace(/(^|\s)shiny-output-error\S*/g, '');
+      });
     };
     this.showProgress = function(el, show) {
       var RECALC_CLASS = 'recalculating';
@@ -1209,13 +1238,17 @@
       exports.unbindAll(el);
 
       var html;
+      var dependencies = [];
       if (data === null) {
         html = '';
-      } else {
+      } else if (typeof(data) === 'string') {
         html = data;
+      } else if (typeof(data) === 'object') {
+        html = data.html;
+        dependencies = data.deps;
       }
 
-      exports.renderHtml(html, el);
+      exports.renderHtml(html, el, dependencies);
       exports.initializeInputs(el);
       exports.bindAll(el);
     }
@@ -1223,10 +1256,69 @@
   outputBindings.register(htmlOutputBinding, 'shiny.htmlOutput');
 
   // Render HTML in a DOM element, inserting singletons into head as needed
-  exports.renderHtml = function(html, el) {
+  exports.renderHtml = function(html, el, dependencies) {
+    if (dependencies) {
+      $.each(dependencies, function(i, dep) {
+        renderDependency(dep);
+      });
+    }
     return singletons.renderHtml(html, el);
   };
 
+  function asArray(value) {
+    if (value === null)
+      return [];
+    if ($.isArray(value))
+      return value;
+    return [value];
+  }
+
+  var htmlDependencies = {};
+  function registerDependency(name, version) {
+    htmlDependencies[name] = version;
+  }
+
+  // Client-side dependency resolution and rendering
+  function renderDependency(dep) {
+    if (htmlDependencies.hasOwnProperty(dep.name))
+      return false;
+
+    registerDependency(dep.name, dep.version);
+
+    var href = dep.src.href;
+
+    var $head = $("head").first();
+
+    if (dep.meta) {
+      var metas = $.map(asArray(dep.meta), function(content, name) {
+        return $("<meta>").attr("name", name).attr("content", content);
+      });
+      $head.append(metas);
+    }
+
+    if (dep.stylesheet) {
+      var stylesheets = $.map(asArray(dep.stylesheet), function(stylesheet) {
+        return $("<link rel='stylesheet' type='text/css'>")
+          .attr("href", href + "/" + stylesheet);
+      });
+      $head.append(stylesheets);
+    }
+
+    if (dep.script) {
+      var scripts = $.map(asArray(dep.script), function(scriptName) {
+        return $("<script>").attr("src", href + "/" + scriptName);
+      });
+      $head.append(scripts);
+    }
+
+    if (dep.head) {
+      var $newHead = $("<head></head>");
+      $newHead.html(dep.head);
+      $head.append($newHead.children());
+    }
+    return true;
+  }
+
   var singletons = {
     knownSingletons: {},
     renderHtml: function(html, el) {
@@ -1630,7 +1722,9 @@
              };
     },
     initialize: function(el) {
-      $(el).slider();
+      var $el = $(el);
+      $el.slider();
+      $el.next('span.jslider').css('width', $el.data('width'));
     }
   });
   inputBindings.register(sliderInputBinding, 'shiny.sliderInput');
@@ -1974,8 +2068,8 @@
     },
     setValue: function(el, value) {
       var selectize = this._selectize(el);
-      if (selectize) {
-        selectize[0].selectize.setValue(value);
+      if (selectize !== undefined) {
+        selectize.setValue(value);
       } else $(el).val(value);
     },
     getState: function(el) {
@@ -1993,15 +2087,14 @@
       };
     },
     receiveMessage: function(el, data) {
-      var $el = $(el);
+      var $el = $(el), selectize;
 
       // This will replace all the options
       if (data.hasOwnProperty('options')) {
         // Clear existing options and add each new one
         $el.empty();
-        var selectize = this._selectize(el);
-        if (selectize) {
-          selectize = selectize[0].selectize;
+        selectize = this._selectize(el);
+        if (selectize !== undefined) {
           selectize.clearOptions();
           // Selectize.js doesn't maintain insertion order on Chrome on Mac
           // with >10 items if inserted using addOption (versus being present
@@ -2024,6 +2117,41 @@
         }
       }
 
+      // re-initialize selectize
+      if (data.hasOwnProperty('newOptions')) {
+        $el.parent()
+           .find('script[data-for="' + $escape(el.id) + '"]')
+           .replaceWith(data.newOptions);
+        this._selectize(el, true);
+      }
+
+      // use server-side processing for selectize
+      if (data.hasOwnProperty('url')) {
+        selectize = this._selectize(el);
+        selectize.clearOptions();
+        selectize.settings.load = function(query, callback) {
+          if (!query.length) return callback();
+          $.ajax({
+            url: data.url,
+            data: {
+              query: query,
+              field: JSON.stringify(selectize.settings.searchField),
+              conju: selectize.settings.searchConjunction,
+              maxop: selectize.settings.maxOptions
+            },
+            type: 'GET',
+            error: function() {
+              callback();
+            },
+            success: function(res) {
+              callback(res);
+            }
+          });
+        };
+        if (data.hasOwnProperty('selected'))
+          selectize.addOption(data.selected);
+      }
+
       if (data.hasOwnProperty('value'))
         this.setValue(el, data.value);
 
@@ -2043,39 +2171,47 @@
     initialize: function(el) {
       this._selectize(el);
     },
-    _selectize: function(el) {
+    _selectize: function(el, update) {
       if (!$.fn.selectize) return;
       var $el = $(el);
       var config = $el.parent().find('script[data-for="' + $escape(el.id) + '"]');
-      if (config.length > 0) {
-        var options = $.extend({
-          labelField: 'label',
-          valueField: 'value',
-          searchField: ['label']
-        }, JSON.parse(config.html()));
-        if (config.data('nonempty') !== undefined) {
-          options = $.extend(options, {
-            onItemRemove: function(value) {
-              if (this.getValue() === "")
-                $("select#" + $escape(el.id)).empty().append($("<option/>", {
-                  "value": value, "selected": true
-                })).trigger("change");
-            },
-            onDropdownClose: function($dropdown) {
-              if (this.getValue() === "")
-                this.setValue($("select#" + $escape(el.id)).val());
-            }
-          });
-        }
-        // options that should be eval()ed
-        if (config.data('eval') instanceof Array)
-          $.each(config.data('eval'), function(i, x) {
-            /*jshint evil: true*/
-            options[x] = eval('(' + options[x] + ')');
-          });
-
-        return $el.selectize(options);
+      if (config.length === 0) return;
+      var options = $.extend({
+        labelField: 'label',
+        valueField: 'value',
+        searchField: ['label']
+      }, JSON.parse(config.html()));
+      // selectize created from selectInput()
+      if (config.data('nonempty') !== undefined) {
+        options = $.extend(options, {
+          onItemRemove: function(value) {
+            if (this.getValue() === "")
+              $("select#" + $escape(el.id)).empty().append($("<option/>", {
+                "value": value,
+                "selected": true
+              })).trigger("change");
+          },
+          onDropdownClose: function($dropdown) {
+            if (this.getValue() === "")
+              this.setValue($("select#" + $escape(el.id)).val());
+          }
+        });
       }
+      // options that should be eval()ed
+      if (config.data('eval') instanceof Array)
+        $.each(config.data('eval'), function(i, x) {
+          /*jshint evil: true*/
+          options[x] = eval('(' + options[x] + ')');
+        });
+      var control = $el.selectize(options)[0].selectize;
+      // .selectize() does not really update settings; must destroy and rebuild
+      if (update) {
+        var settings = $.extend(control.settings, options);
+        control.destroy();
+        control = $el.selectize(settings)[0].selectize;
+      }
+      $el.next('div.selectize-control').css('width', config.data('width'));
+      return control;
     }
   });
   inputBindings.register(selectInputBinding, 'shiny.selectInput');
@@ -2324,6 +2460,9 @@
     setValue: function(el, value) {
       $(el).data('val', value);
     },
+    getType: function(el) {
+      return 'shiny.action';
+    },
     subscribe: function(el, callback) {
       $(el).on("click.actionButtonInputBinding", function(e) {
         var $el = $(this);
@@ -2704,7 +2843,7 @@
           binding.subscribe(el, thisCallback);
           $(el).data('shiny-input-binding', binding);
           $(el).addClass('shiny-bound-input');
-          var ratePolicy = binding.getRatePolicy();
+          var ratePolicy = binding.getRatePolicy(el);
           if (ratePolicy !== null) {
             inputsRate.setRatePolicy(
               effectiveId,
@@ -2993,6 +3132,14 @@
         $('script[type="application/shiny-singletons"]').text();
     singletons.registerNames(singletonText.split(/,/));
 
+    var dependencyText = $('script[type="application/html-dependencies"]').text();
+    $.each(dependencyText.split(/;/), function(i, depStr) {
+      var match = /\s*^(.+)\[(.+)\]\s*$/.exec(depStr);
+      if (match) {
+        registerDependency(match[1], match[2]);
+      }
+    });
+
     // We've collected all the initial values--start the server process!
     inputsNoResend.reset(initialValues);
     shinyapp.connect(initialValues);

man/HTML.Rd

@@ -1,4 +1,3 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
 \name{HTML}
 \alias{HTML}
 \title{Mark Characters as HTML}
@@ -6,10 +5,10 @@
 HTML(text, ...)
 }
 \arguments{
-  \item{text}{The text value to mark with HTML}
+\item{text}{The text value to mark with HTML}
 
-  \item{...}{Any additional values to be converted to
-  character and concatenated together}
+\item{...}{Any additional values to be converted to character and
+concatenated together}
 }
 \value{
 The same value, but marked as HTML.

man/absolutePanel.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{absolutePanel}
 \alias{absolutePanel}
 \alias{fixedPanel}
@@ -13,41 +13,37 @@ fixedPanel(..., top = NULL, left = NULL, right = NULL, bottom = NULL,
   "default", "inherit"))
 }
 \arguments{
-  \item{...}{Attributes (named arguments) or children
-  (unnamed arguments) that should be included in the
-  panel.}
+\item{...}{Attributes (named arguments) or children (unnamed arguments) that
+  should be included in the panel.}
 
-  \item{top}{Distance between the top of the panel, and the
-  top of the page or parent container.}
+\item{top}{Distance between the top of the panel, and the top of the page or
+parent container.}
 
-  \item{left}{Distance between the left side of the panel,
-  and the left of the page or parent container.}
+\item{left}{Distance between the left side of the panel, and the left of the
+page or parent container.}
 
-  \item{right}{Distance between the right side of the
-  panel, and the right of the page or parent container.}
+\item{right}{Distance between the right side of the panel, and the right of
+the page or parent container.}
 
-  \item{bottom}{Distance between the bottom of the panel,
-  and the bottom of the page or parent container.}
+\item{bottom}{Distance between the bottom of the panel, and the bottom of the
+page or parent container.}
 
-  \item{width}{Width of the panel.}
+\item{width}{Width of the panel.}
 
-  \item{height}{Height of the panel.}
+\item{height}{Height of the panel.}
 
-  \item{draggable}{If \code{TRUE}, allows the user to move
-  the panel by clicking and dragging.}
+\item{draggable}{If \code{TRUE}, allows the user to move the panel by
+clicking and dragging.}
 
-  \item{fixed}{Positions the panel relative to the browser
-  window and prevents it from being scrolled with the rest
-  of the page.}
+\item{fixed}{Positions the panel relative to the browser window and prevents
+it from being scrolled with the rest of the page.}
 
-  \item{cursor}{The type of cursor that should appear when
-  the user mouses over the panel. Use \code{"move"} for a
-  north-east-south-west icon, \code{"default"} for the
-  usual cursor arrow, or \code{"inherit"} for the usual
-  cursor behavior (including changing to an I-beam when the
-  cursor is over text). The default is \code{"auto"}, which
-  is equivalent to \code{ifelse(draggable, "move",
-  "inherit")}.}
+\item{cursor}{The type of cursor that should appear when the user mouses over
+the panel. Use \code{"move"} for a north-east-south-west icon,
+\code{"default"} for the usual cursor arrow, or \code{"inherit"} for the
+usual cursor behavior (including changing to an I-beam when the cursor is
+over text). The default is \code{"auto"}, which is equivalent to
+\code{ifelse(draggable, "move", "inherit")}.}
 }
 \value{
 An HTML element or list of elements.

man/actionButton.Rd

@@ -1,23 +1,26 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{actionButton}
 \alias{actionButton}
-\title{Action button}
+\alias{actionLink}
+\title{Action button/link}
 \usage{
-actionButton(inputId, label, icon = NULL)
+actionButton(inputId, label, icon = NULL, ...)
+
+actionLink(inputId, label, icon = NULL, ...)
 }
 \arguments{
-  \item{inputId}{Specifies the input slot that will be used
-  to access the value.}
+\item{inputId}{Specifies the input slot that will be used to access the
+value.}
 
-  \item{label}{The contents of the button--usually a text
-  label, but you could also use any other HTML, like an
-  image.}
+\item{label}{The contents of the button or link--usually a text label, but
+you could also use any other HTML, like an image.}
 
-  \item{icon}{Optional \code{\link{icon}} to appear on the
-  button}
+\item{icon}{An optional \code{\link{icon}} to appear on the button.}
+
+\item{...}{Named attributes to be applied to the button or link.}
 }
 \description{
-Creates an action button whose value is initially zero, and increments by one
+Creates an action button or link whose value is initially zero, and increments by one
 each time it is pressed.
 }
 \examples{

man/addResourcePath.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{addResourcePath}
 \alias{addResourcePath}
 \title{Resource Publishing}
@@ -6,14 +6,13 @@
 addResourcePath(prefix, directoryPath)
 }
 \arguments{
-  \item{prefix}{The URL prefix (without slashes). Valid
-  characters are a-z, A-Z, 0-9, hyphen, and underscore; and
-  must begin with a-z or A-Z. For example, a value of 'foo'
-  means that any request paths that begin with '/foo' will
-  be mapped to the given directory.}
+\item{prefix}{The URL prefix (without slashes). Valid characters are a-z,
+A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
+For example, a value of 'foo' means that any request paths that begin with
+'/foo' will be mapped to the given directory.}
 
-  \item{directoryPath}{The directory that contains the
-  static resources to be served.}
+\item{directoryPath}{The directory that contains the static resources to be
+  served.}
 }
 \description{
 Adds a directory of static resources to Shiny's web server, with the given

man/bootstrapPage.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{bootstrapPage}
 \alias{basicPage}
 \alias{bootstrapPage}
@@ -9,18 +9,15 @@ bootstrapPage(..., title = NULL, responsive = TRUE, theme = NULL)
 basicPage(...)
 }
 \arguments{
-  \item{...}{The contents of the document body.}
+\item{...}{The contents of the document body.}
 
-  \item{title}{The browser window title (defaults to the
-  host URL of the page)}
+\item{title}{The browser window title (defaults to the host URL of the page)}
 
-  \item{responsive}{\code{TRUE} to use responsive layout
-  (automatically adapt and resize page elements based on
-  the size of the viewing device)}
+\item{responsive}{\code{TRUE} to use responsive layout (automatically adapt
+and resize page elements based on the size of the viewing device)}
 
-  \item{theme}{Alternative Bootstrap stylesheet (normally a
-  css file within the www directory, e.g.
-  \code{www/bootstrap.css})}
+\item{theme}{Alternative Bootstrap stylesheet (normally a css file within the
+  www directory, e.g. \code{www/bootstrap.css})}
 }
 \value{
 A UI defintion that can be passed to the \link{shinyUI} function.

man/builder.Rd

@@ -1,5 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
-\name{p}
+\name{builder}
 \alias{a}
 \alias{br}
 \alias{builder}
@@ -21,6 +20,8 @@
 \alias{tags}
 \title{HTML Builder Functions}
 \usage{
+tags
+
 p(...)
 
 h1(...)
@@ -54,16 +55,13 @@ strong(...)
 em(...)
 
 hr(...)
-
-tags
 }
 \arguments{
-  \item{...}{Attributes and children of the element. Named
-  arguments become attributes, and positional arguments
-  become children. Valid children are tags,
-  single-character character vectors (which become text
-  nodes), and raw HTML (see \code{\link{HTML}}). You can
-  also pass lists that contain tags, text nodes, and HTML.}
+\item{...}{Attributes and children of the element. Named arguments become
+attributes, and positional arguments become children. Valid children are
+tags, single-character character vectors (which become text nodes), and raw
+HTML (see \code{\link{HTML}}). You can also pass lists that contain tags,
+text nodes, and HTML.}
 }
 \description{
 Simple functions for constructing HTML documents.

man/checkboxGroupInput.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{checkboxGroupInput}
 \alias{checkboxGroupInput}
 \title{Checkbox Group Input Control}
@@ -6,17 +6,14 @@
 checkboxGroupInput(inputId, label, choices, selected = NULL)
 }
 \arguments{
-  \item{inputId}{Input variable to assign the control's
-  value to.}
+\item{inputId}{Input variable to assign the control's value to.}
 
-  \item{label}{Display label for the control.}
+\item{label}{Display label for the control, or \code{NULL}.}
 
-  \item{choices}{List of values to show checkboxes for. If
-  elements of the list are named then that name rather than
-  the value is displayed to the user.}
+\item{choices}{List of values to show checkboxes for. If elements of the list
+are named then that name rather than the value is displayed to the user.}
 
-  \item{selected}{The values that should be initially
-  selected, if any.}
+\item{selected}{The values that should be initially selected, if any.}
 }
 \value{
 A list of HTML elements that can be added to a UI definition.
@@ -35,8 +32,8 @@ checkboxGroupInput("variable", "Variable:",
 \seealso{
 \code{\link{checkboxInput}}, \code{\link{updateCheckboxGroupInput}}
 
-Other input.elements: \code{\link{actionButton}};
-  \code{\link{animationOptions}},
+Other input.elements: \code{\link{actionButton}},
+  \code{\link{actionLink}}; \code{\link{animationOptions}},
   \code{\link{sliderInput}}; \code{\link{checkboxInput}};
   \code{\link{dateInput}}; \code{\link{dateRangeInput}};
   \code{\link{fileInput}}; \code{\link{numericInput}};

man/checkboxInput.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{checkboxInput}
 \alias{checkboxInput}
 \title{Checkbox Input Control}
@@ -6,13 +6,11 @@
 checkboxInput(inputId, label, value = FALSE)
 }
 \arguments{
-  \item{inputId}{Input variable to assign the control's
-  value to.}
+\item{inputId}{Input variable to assign the control's value to.}
 
-  \item{label}{Display label for the control.}
+\item{label}{Display label for the control.}
 
-  \item{value}{Initial value (\code{TRUE} or
-  \code{FALSE}).}
+\item{value}{Initial value (\code{TRUE} or \code{FALSE}).}
 }
 \value{
 A checkbox control that can be added to a UI definition.
@@ -26,8 +24,8 @@ checkboxInput("outliers", "Show outliers", FALSE)
 \seealso{
 \code{\link{checkboxGroupInput}}, \code{\link{updateCheckboxInput}}
 
-Other input.elements: \code{\link{actionButton}};
-  \code{\link{animationOptions}},
+Other input.elements: \code{\link{actionButton}},
+  \code{\link{actionLink}}; \code{\link{animationOptions}},
   \code{\link{sliderInput}};
   \code{\link{checkboxGroupInput}};
   \code{\link{dateInput}}; \code{\link{dateRangeInput}};

man/column.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{column}
 \alias{column}
 \title{Create a column within a UI definition}
@@ -6,13 +6,12 @@
 column(width, ..., offset = 0)
 }
 \arguments{
-  \item{width}{The grid width of the column (must be
-  between 1 and 12)}
+\item{width}{The grid width of the column (must be between 1 and 12)}
 
-  \item{...}{Elements to include within the column}
+\item{...}{Elements to include within the column}
 
-  \item{offset}{The number of columns to offset this column
-  from the end of the previous column.}
+\item{offset}{The number of columns to offset this column from the end of the
+  previous column.}
 }
 \value{
 A column that can be included within a

man/conditionalPanel.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{conditionalPanel}
 \alias{conditionalPanel}
 \title{Conditional Panel}
@@ -6,11 +6,10 @@
 conditionalPanel(condition, ...)
 }
 \arguments{
-  \item{condition}{A JavaScript expression that will be
-  evaluated repeatedly to determine whether the panel
-  should be displayed.}
+\item{condition}{A JavaScript expression that will be evaluated repeatedly to
+determine whether the panel should be displayed.}
 
-  \item{...}{Elements to include in the panel.}
+\item{...}{Elements to include in the panel.}
 }
 \description{
 Creates a panel that is visible or not, depending on the value of a

man/dateInput.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{dateInput}
 \alias{dateInput}
 \title{Create date input}
@@ -8,39 +8,34 @@ dateInput(inputId, label, value = NULL, min = NULL, max = NULL,
   language = "en")
 }
 \arguments{
-  \item{inputId}{Input variable to assign the control's
-  value to.}
+\item{inputId}{Input variable to assign the control's value to.}
 
-  \item{label}{Display label for the control.}
+\item{label}{Display label for the control, or \code{NULL}.}
 
-  \item{value}{The starting date. Either a Date object, or
-  a string in \code{yyyy-mm-dd} format. If NULL (the
-  default), will use the current date in the client's time
-  zone.}
+\item{value}{The starting date. Either a Date object, or a string in
+\code{yyyy-mm-dd} format. If NULL (the default), will use the current
+date in the client's time zone.}
 
-  \item{min}{The minimum allowed date. Either a Date
-  object, or a string in \code{yyyy-mm-dd} format.}
+\item{min}{The minimum allowed date. Either a Date object, or a string in
+\code{yyyy-mm-dd} format.}
 
-  \item{max}{The maximum allowed date. Either a Date
-  object, or a string in \code{yyyy-mm-dd} format.}
+\item{max}{The maximum allowed date. Either a Date object, or a string in
+\code{yyyy-mm-dd} format.}
 
-  \item{format}{The format of the date to display in the
-  browser. Defaults to \code{"yyyy-mm-dd"}.}
+\item{format}{The format of the date to display in the browser. Defaults to
+\code{"yyyy-mm-dd"}.}
 
-  \item{startview}{The date range shown when the input
-  object is first clicked. Can be "month" (the default),
-  "year", or "decade".}
+\item{startview}{The date range shown when the input object is first
+clicked. Can be "month" (the default), "year", or "decade".}
 
-  \item{weekstart}{Which day is the start of the week.
-  Should be an integer from 0 (Sunday) to 6 (Saturday).}
+\item{weekstart}{Which day is the start of the week. Should be an integer
+from 0 (Sunday) to 6 (Saturday).}
 
-  \item{language}{The language used for month and day
-  names. Default is "en".  Other valid values include "bg",
-  "ca", "cs", "da", "de", "el", "es", "fi", "fr", "he",
-  "hr", "hu", "id", "is", "it", "ja", "kr", "lt", "lv",
-  "ms", "nb", "nl", "pl", "pt", "pt-BR", "ro", "rs",
-  "rs-latin", "ru", "sk", "sl", "sv", "sw", "th", "tr",
-  "uk", "zh-CN", and "zh-TW".}
+\item{language}{The language used for month and day names. Default is "en".
+  Other valid values include "bg", "ca", "cs", "da", "de", "el", "es", "fi",
+  "fr", "he", "hr", "hu", "id", "is", "it", "ja", "kr", "lt", "lv", "ms",
+  "nb", "nl", "pl", "pt", "pt-BR", "ro", "rs", "rs-latin", "ru", "sk", "sl",
+  "sv", "sw", "th", "tr", "uk", "zh-CN", and "zh-TW".}
 }
 \description{
 Creates a text input which, when clicked on, brings up a calendar that
@@ -87,8 +82,8 @@ dateInput("date", "Date:",
 \seealso{
 \code{\link{dateRangeInput}}, \code{\link{updateDateInput}}
 
-Other input.elements: \code{\link{actionButton}};
-  \code{\link{animationOptions}},
+Other input.elements: \code{\link{actionButton}},
+  \code{\link{actionLink}}; \code{\link{animationOptions}},
   \code{\link{sliderInput}};
   \code{\link{checkboxGroupInput}};
   \code{\link{checkboxInput}};

man/dateRangeInput.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{dateRangeInput}
 \alias{dateRangeInput}
 \title{Create date range input}
@@ -8,47 +8,40 @@ dateRangeInput(inputId, label, start = NULL, end = NULL, min = NULL,
   language = "en", separator = " to ")
 }
 \arguments{
-  \item{start}{The initial start date. Either a Date
-  object, or a string in \code{yyyy-mm-dd} format. If NULL
-  (the default), will use the current date in the client's
-  time zone.}
+\item{start}{The initial start date. Either a Date object, or a string in
+\code{yyyy-mm-dd} format. If NULL (the default), will use the current
+date in the client's time zone.}
 
-  \item{end}{The initial end date. Either a Date object, or
-  a string in \code{yyyy-mm-dd} format. If NULL (the
-  default), will use the current date in the client's time
-  zone.}
+\item{end}{The initial end date. Either a Date object, or a string in
+\code{yyyy-mm-dd} format. If NULL (the default), will use the current
+date in the client's time zone.}
 
-  \item{separator}{String to display between the start and
-  end input boxes.}
+\item{separator}{String to display between the start and end input boxes.}
 
-  \item{inputId}{Input variable to assign the control's
-  value to.}
+\item{inputId}{Input variable to assign the control's value to.}
 
-  \item{label}{Display label for the control.}
+\item{label}{Display label for the control, or \code{NULL}.}
 
-  \item{min}{The minimum allowed date. Either a Date
-  object, or a string in \code{yyyy-mm-dd} format.}
+\item{min}{The minimum allowed date. Either a Date object, or a string in
+\code{yyyy-mm-dd} format.}
 
-  \item{max}{The maximum allowed date. Either a Date
-  object, or a string in \code{yyyy-mm-dd} format.}
+\item{max}{The maximum allowed date. Either a Date object, or a string in
+\code{yyyy-mm-dd} format.}
 
-  \item{format}{The format of the date to display in the
-  browser. Defaults to \code{"yyyy-mm-dd"}.}
+\item{format}{The format of the date to display in the browser. Defaults to
+\code{"yyyy-mm-dd"}.}
 
-  \item{startview}{The date range shown when the input
-  object is first clicked. Can be "month" (the default),
-  "year", or "decade".}
+\item{startview}{The date range shown when the input object is first
+clicked. Can be "month" (the default), "year", or "decade".}
 
-  \item{weekstart}{Which day is the start of the week.
-  Should be an integer from 0 (Sunday) to 6 (Saturday).}
+\item{weekstart}{Which day is the start of the week. Should be an integer
+from 0 (Sunday) to 6 (Saturday).}
 
-  \item{language}{The language used for month and day
-  names. Default is "en".  Other valid values include "bg",
-  "ca", "cs", "da", "de", "el", "es", "fi", "fr", "he",
-  "hr", "hu", "id", "is", "it", "ja", "kr", "lt", "lv",
-  "ms", "nb", "nl", "pl", "pt", "pt-BR", "ro", "rs",
-  "rs-latin", "ru", "sk", "sl", "sv", "sw", "th", "tr",
-  "uk", "zh-CN", and "zh-TW".}
+\item{language}{The language used for month and day names. Default is "en".
+  Other valid values include "bg", "ca", "cs", "da", "de", "el", "es", "fi",
+  "fr", "he", "hr", "hu", "id", "is", "it", "ja", "kr", "lt", "lv", "ms",
+  "nb", "nl", "pl", "pt", "pt-BR", "ro", "rs", "rs-latin", "ru", "sk", "sl",
+  "sv", "sw", "th", "tr", "uk", "zh-CN", and "zh-TW".}
 }
 \description{
 Creates a pair of text inputs which, when clicked on, bring up calendars that
@@ -106,8 +99,8 @@ dateRangeInput("daterange", "Date range:",
 \seealso{
 \code{\link{dateInput}}, \code{\link{updateDateRangeInput}}
 
-Other input.elements: \code{\link{actionButton}};
-  \code{\link{animationOptions}},
+Other input.elements: \code{\link{actionButton}},
+  \code{\link{actionLink}}; \code{\link{animationOptions}},
   \code{\link{sliderInput}};
   \code{\link{checkboxGroupInput}};
   \code{\link{checkboxInput}}; \code{\link{dateInput}};

man/domains.Rd

@@ -0,0 +1,53 @@
+% Generated by roxygen2 (4.0.1): do not edit by hand
+\name{getDefaultReactiveDomain}
+\alias{domains}
+\alias{getDefaultReactiveDomain}
+\alias{onReactiveDomainEnded}
+\alias{withReactiveDomain}
+\title{Reactive domains}
+\usage{
+getDefaultReactiveDomain()
+
+withReactiveDomain(domain, expr)
+
+onReactiveDomainEnded(domain, callback, failIfNull = FALSE)
+}
+\arguments{
+\item{domain}{A valid domain object (for example, a Shiny session), or
+\code{NULL}}
+
+\item{expr}{An expression to evaluate under \code{domain}}
+
+\item{callback}{A callback function to be invoked}
+
+\item{failIfNull}{If \code{TRUE} then an error is given if the \code{domain}
+is \code{NULL}}
+}
+\description{
+Reactive domains are a mechanism for establishing ownership over reactive
+primitives (like reactive expressions and observers), even if the set of
+reactive primitives is dynamically created. This is useful for lifetime
+management (i.e. destroying observers when the Shiny session that created
+them ends) and error handling.
+}
+\details{
+At any given time, there can be either a single "default" reactive domain
+object, or none (i.e. the reactive domain object is \code{NULL}). You can
+access the current default reactive domain by calling
+\code{getDefaultReactiveDomain}.
+
+Unless you specify otherwise, newly created observers and reactive
+expressions will be assigned to the current default domain (if any). You can
+override this assignment by providing an explicit \code{domain} argument to
+\code{\link{reactive}} or \code{\link{observe}}.
+
+For advanced usage, it's possible to override the default domain using
+\code{withReactiveDomain}. The \code{domain} argument will be made the
+default domain while \code{expr} is evaluated.
+
+Implementers of new reactive primitives can use \code{onReactiveDomainEnded}
+as a convenience function for registering callbacks. If the reactive domain
+is \code{NULL} and \code{failIfNull} is \code{FALSE}, then the callback will
+never be invoked.
+}
+

man/downloadButton.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{downloadButton}
 \alias{downloadButton}
 \alias{downloadLink}
@@ -9,13 +9,12 @@ downloadButton(outputId, label = "Download", class = NULL)
 downloadLink(outputId, label = "Download", class = NULL)
 }
 \arguments{
-  \item{outputId}{The name of the output slot that the
-  \code{downloadHandler} is assigned to.}
+\item{outputId}{The name of the output slot that the \code{downloadHandler}
+is assigned to.}
 
-  \item{label}{The label that should appear on the button.}
+\item{label}{The label that should appear on the button.}
 
-  \item{class}{Additional CSS classes to apply to the tag,
-  if any.}
+\item{class}{Additional CSS classes to apply to the tag, if any.}
 }
 \description{
 Use these functions to create a download button or link; when clicked, it

man/downloadHandler.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{downloadHandler}
 \alias{downloadHandler}
 \title{File Downloads}
@@ -6,25 +6,21 @@
 downloadHandler(filename, content, contentType = NA)
 }
 \arguments{
-  \item{filename}{A string of the filename, including
-  extension, that the user's web browser should default to
-  when downloading the file; or a function that returns
-  such a string. (Reactive values and functions may be used
-  from this function.)}
+\item{filename}{A string of the filename, including extension, that the
+user's web browser should default to when downloading the file; or a
+function that returns such a string. (Reactive values and functions may be
+used from this function.)}
 
-  \item{content}{A function that takes a single argument
-  \code{file} that is a file path (string) of a nonexistent
-  temp file, and writes the content to that file path.
-  (Reactive values and functions may be used from this
-  function.)}
+\item{content}{A function that takes a single argument \code{file} that is a
+file path (string) of a nonexistent temp file, and writes the content to
+that file path. (Reactive values and functions may be used from this
+function.)}
 
-  \item{contentType}{A string of the download's
-  \href{http://en.wikipedia.org/wiki/Internet_media_type}{content
-  type}, for example \code{"text/csv"} or
-  \code{"image/png"}. If \code{NULL} or \code{NA}, the
-  content type will be guessed based on the filename
-  extension, or \code{application/octet-stream} if the
-  extension is unknown.}
+\item{contentType}{A string of the download's
+  \href{http://en.wikipedia.org/wiki/Internet_media_type}{content type}, for
+  example \code{"text/csv"} or \code{"image/png"}. If \code{NULL} or
+  \code{NA}, the content type will be guessed based on the filename
+  extension, or \code{application/octet-stream} if the extension is unknown.}
 }
 \description{
 Allows content from the Shiny application to be made available to the user as

man/exprToFunction.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{exprToFunction}
 \alias{exprToFunction}
 \title{Convert an expression to a function}
@@ -7,16 +7,15 @@ exprToFunction(expr, env = parent.frame(2), quoted = FALSE,
   caller_offset = 1)
 }
 \arguments{
-  \item{expr}{A quoted or unquoted expression, or a
-  function.}
+\item{expr}{A quoted or unquoted expression, or a function.}
 
-  \item{env}{The desired environment for the function.
-  Defaults to the calling environment two steps back.}
+\item{env}{The desired environment for the function. Defaults to the
+calling environment two steps back.}
 
-  \item{quoted}{Is the expression quoted?}
+\item{quoted}{Is the expression quoted?}
 
-  \item{caller_offset}{If specified, the offset in the
-  callstack of the functiont to be treated as the caller.}
+\item{caller_offset}{If specified, the offset in the callstack of the
+  functiont to be treated as the caller.}
 }
 \description{
 This is to be called from another function, because it will attempt to get

man/fileInput.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{fileInput}
 \alias{fileInput}
 \title{File Upload Control}
@@ -6,17 +6,15 @@
 fileInput(inputId, label, multiple = FALSE, accept = NULL)
 }
 \arguments{
-  \item{inputId}{Input variable to assign the control's
-  value to.}
+\item{inputId}{Input variable to assign the control's value to.}
 
-  \item{label}{Display label for the control.}
+\item{label}{Display label for the control.}
 
-  \item{multiple}{Whether the user should be allowed to
-  select and upload multiple files at once.}
+\item{multiple}{Whether the user should be allowed to select and upload
+multiple files at once.}
 
-  \item{accept}{A character vector of MIME types; gives the
-  browser a hint of what kind of files the server is
-  expecting.}
+\item{accept}{A character vector of MIME types; gives the browser a hint of
+  what kind of files the server is expecting.}
 }
 \description{
 Create a file upload control that can be used to upload one or more files.
@@ -42,8 +40,8 @@ the following columns:
 }
 }
 \seealso{
-Other input.elements: \code{\link{actionButton}};
-  \code{\link{animationOptions}},
+Other input.elements: \code{\link{actionButton}},
+  \code{\link{actionLink}}; \code{\link{animationOptions}},
   \code{\link{sliderInput}};
   \code{\link{checkboxGroupInput}};
   \code{\link{checkboxInput}}; \code{\link{dateInput}};

man/fixedPage.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{fixedPage}
 \alias{fixedPage}
 \alias{fixedRow}
@@ -9,19 +9,16 @@ fixedPage(..., title = NULL, responsive = TRUE, theme = NULL)
 fixedRow(...)
 }
 \arguments{
-  \item{...}{Elements to include within the container}
+\item{...}{Elements to include within the container}
 
-  \item{title}{The browser window title (defaults to the
-  host URL of the page)}
+\item{title}{The browser window title (defaults to the host URL of the page)}
 
-  \item{responsive}{\code{TRUE} to use responsive layout
-  (automatically adapt and resize page elements based on
-  the size of the viewing device)}
+\item{responsive}{\code{TRUE} to use responsive layout (automatically adapt
+and resize page elements based on the size of the viewing device)}
 
-  \item{theme}{Alternative Bootstrap stylesheet (normally a
-  css file within the www directory). For example, to use
-  the theme located at \code{www/bootstrap.css} you would
-  use \code{theme = "bootstrap.css"}.}
+\item{theme}{Alternative Bootstrap stylesheet (normally a css file within the
+  www directory). For example, to use the theme located at
+  \code{www/bootstrap.css} you would use \code{theme = "bootstrap.css"}.}
 }
 \value{
 A UI defintion that can be passed to the \link{shinyUI} function.

man/flowLayout.Rd

@@ -0,0 +1,33 @@
+% Generated by roxygen2 (4.0.1): do not edit by hand
+\name{flowLayout}
+\alias{flowLayout}
+\title{Flow layout}
+\usage{
+flowLayout(..., cellArgs = list())
+}
+\arguments{
+\item{...}{Unnamed arguments will become child elements of the layout. Named
+arguments will become HTML attributes on the outermost tag.}
+
+\item{cellArgs}{Any additional attributes that should be used for each cell
+  of the layout.}
+}
+\description{
+Lays out elements in a left-to-right, top-to-bottom arrangement. The elements
+on a given row will be top-aligned with each other. This layout will not work
+well with elements that have a percentage-based width (e.g. `plotOutput` at
+its default setting of `width = "100%"`).
+}
+\examples{
+flowLayout(
+  numericInput("rows", "How many rows?", 5),
+  selectInput("letter", "Which letter?", LETTERS),
+  sliderInput("value", "What value?", 0, 100, 50)
+)
+}
+\seealso{
+\code{\link{verticalLayout}}
+
+#'
+}
+

man/fluidPage.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{fluidPage}
 \alias{fluidPage}
 \alias{fluidRow}
@@ -9,20 +9,17 @@ fluidPage(..., title = NULL, responsive = TRUE, theme = NULL)
 fluidRow(...)
 }
 \arguments{
-  \item{...}{Elements to include within the page}
+\item{...}{Elements to include within the page}
 
-  \item{title}{The browser window title (defaults to the
-  host URL of the page).  Can also be set as a side effect
-  of the \code{\link{titlePanel}} function.}
+\item{title}{The browser window title (defaults to the host URL of the page).
+Can also be set as a side effect of the \code{\link{titlePanel}} function.}
 
-  \item{responsive}{\code{TRUE} to use responsive layout
-  (automatically adapt and resize page elements based on
-  the size of the viewing device)}
+\item{responsive}{\code{TRUE} to use responsive layout (automatically adapt
+and resize page elements based on the size of the viewing device)}
 
-  \item{theme}{Alternative Bootstrap stylesheet (normally a
-  css file within the www directory). For example, to use
-  the theme located at \code{www/bootstrap.css} you would
-  use \code{theme = "bootstrap.css"}.}
+\item{theme}{Alternative Bootstrap stylesheet (normally a css file within the
+  www directory). For example, to use the theme located at
+  \code{www/bootstrap.css} you would use \code{theme = "bootstrap.css"}.}
 }
 \value{
 A UI defintion that can be passed to the \link{shinyUI} function.

man/headerPanel.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{headerPanel}
 \alias{headerPanel}
 \title{Create a header panel}
@@ -6,11 +6,10 @@
 headerPanel(title, windowTitle = title)
 }
 \arguments{
-  \item{title}{An application title to display}
+\item{title}{An application title to display}
 
-  \item{windowTitle}{The title that should be displayed by
-  the browser window.  Useful if \code{title} is not a
-  string.}
+\item{windowTitle}{The title that should be displayed by the browser window.
+Useful if \code{title} is not a string.}
 }
 \value{
 A headerPanel that can be passed to \link{pageWithSidebar}

man/helpText.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{helpText}
 \alias{helpText}
 \title{Create a help text element}
@@ -6,8 +6,7 @@
 helpText(...)
 }
 \arguments{
-  \item{...}{One or more help text strings (or other inline
-  HTML elements)}
+\item{...}{One or more help text strings (or other inline HTML elements)}
 }
 \value{
 A help text element that can be added to a UI definition.

man/htmlOutput.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{htmlOutput}
 \alias{htmlOutput}
 \alias{uiOutput}
@@ -9,7 +9,7 @@ htmlOutput(outputId)
 uiOutput(outputId)
 }
 \arguments{
-  \item{outputId}{output variable to read the value from}
+\item{outputId}{output variable to read the value from}
 }
 \value{
 An HTML output element that can be included in a panel

man/icon.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{icon}
 \alias{icon}
 \title{Create an icon}
@@ -6,19 +6,17 @@
 icon(name, class = NULL, lib = "font-awesome")
 }
 \arguments{
-  \item{name}{Name of icon. Icons are drawn from the
-  \href{http://fontawesome.io/icons/}{Font Awesome}
-  library. Note that the "fa-" prefix should not be used in
-  icon names (i.e. the "fa-calendar" icon should be
-  referred to as "calendar")}
+\item{name}{Name of icon. Icons are drawn from the
+\href{http://fontawesome.io/icons/}{Font Awesome} library. Note that the
+"fa-" prefix should not be used in icon names (i.e. the "fa-calendar" icon
+should be referred to as "calendar")}
 
-  \item{class}{Additional classes to customize the style of
-  the icon (see the
-  \href{http://fontawesome.io/examples/}{usage examples}
-  for details on supported styles).}
+\item{class}{Additional classes to customize the style of the icon (see the
+\href{http://fontawesome.io/examples/}{usage examples} for
+ details on supported styles).}
 
-  \item{lib}{Icon library to use ("font-awesome" is only
-  one currently supported)}
+\item{lib}{Icon library to use ("font-awesome" is only one currently
+  supported)}
 }
 \value{
 An icon element

man/imageOutput.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{imageOutput}
 \alias{imageOutput}
 \title{Create a image output element}
@@ -6,14 +6,13 @@
 imageOutput(outputId, width = "100\%", height = "400px")
 }
 \arguments{
-  \item{outputId}{output variable to read the image from}
+\item{outputId}{output variable to read the image from}
 
-  \item{width}{Image width. Must be a valid CSS unit (like
-  \code{"100\%"}, \code{"400px"}, \code{"auto"}) or a
-  number, which will be coerced to a string and have
-  \code{"px"} appended.}
+\item{width}{Image width. Must be a valid CSS unit (like \code{"100\%"},
+\code{"400px"}, \code{"auto"}) or a number, which will be coerced to a
+string and have \code{"px"} appended.}
 
-  \item{height}{Image height}
+\item{height}{Image height}
 }
 \value{
 An image output element that can be included in a panel

man/include.Rd

@@ -1,4 +1,3 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
 \name{include}
 \alias{include}
 \alias{includeCSS}
@@ -19,16 +18,14 @@ includeCSS(path, ...)
 includeScript(path, ...)
 }
 \arguments{
-  \item{path}{The path of the file to be included. It is
-  highly recommended to use a relative path (the base path
-  being the Shiny application directory), not an absolute
-  path.}
+\item{path}{The path of the file to be included. It is highly recommended to
+  use a relative path (the base path being the Shiny application directory),
+  not an absolute path.}
 
-  \item{...}{Any additional attributes to be applied to the
-  generated tag.}
+\item{...}{Any additional attributes to be applied to the generated tag.}
 }
 \description{
-Include HTML, text, or rendered Markdown into a \link[=shinyUI]{Shiny UI}.
+Load HTML, text, or rendered Markdown from a file and turn into HTML.
 }
 \details{
 These functions provide a convenient way to include an extensive amount of

man/inputPanel.Rd

@@ -0,0 +1,15 @@
+% Generated by roxygen2 (4.0.1): do not edit by hand
+\name{inputPanel}
+\alias{inputPanel}
+\title{Input panel}
+\usage{
+inputPanel(...)
+}
+\arguments{
+\item{...}{Input controls or other HTML elements.}
+}
+\description{
+A \code{\link{flowLayout}} with a grey border and light grey background,
+suitable for wrapping inputs.
+}
+

man/installExprFunction.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{installExprFunction}
 \alias{installExprFunction}
 \title{Install an expression as a function}
@@ -7,20 +7,19 @@ installExprFunction(expr, name, eval.env = parent.frame(2), quoted = FALSE,
   assign.env = parent.frame(1), label = as.character(sys.call(-1)[[1]]))
 }
 \arguments{
-  \item{expr}{A quoted or unquoted expression}
+\item{expr}{A quoted or unquoted expression}
 
-  \item{name}{The name the function should be given}
+\item{name}{The name the function should be given}
 
-  \item{eval.env}{The desired environment for the function.
-  Defaults to the calling environment two steps back.}
+\item{eval.env}{The desired environment for the function. Defaults to the
+calling environment two steps back.}
 
-  \item{quoted}{Is the expression quoted?}
+\item{quoted}{Is the expression quoted?}
 
-  \item{assign.env}{The environment in which the function
-  should be assigned.}
+\item{assign.env}{The environment in which the function should be assigned.}
 
-  \item{label}{A label for the object to be shown in the
-  debugger. Defaults to the name of the calling function.}
+\item{label}{A label for the object to be shown in the debugger. Defaults to
+  the name of the calling function.}
 }
 \description{
 Installs an expression in the given environment as a function, and registers

man/invalidateLater.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{invalidateLater}
 \alias{invalidateLater}
 \title{Scheduled Invalidation}
@@ -6,13 +6,13 @@
 invalidateLater(millis, session)
 }
 \arguments{
-  \item{millis}{Approximate milliseconds to wait before
-  invalidating the current reactive context.}
+\item{millis}{Approximate milliseconds to wait before invalidating the
+current reactive context.}
 
-  \item{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.}
+\item{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.}
 }
 \description{
 Schedules the current reactive context to be invalidated in the given number

man/is.reactivevalues.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{is.reactivevalues}
 \alias{is.reactivevalues}
 \title{Checks whether an object is a reactivevalues object}
@@ -6,7 +6,7 @@
 is.reactivevalues(x)
 }
 \arguments{
-  \item{x}{The object to test.}
+\item{x}{The object to test.}
 }
 \description{
 Checks whether its argument is a reactivevalues object.

man/isolate.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{isolate}
 \alias{isolate}
 \title{Create a non-reactive scope for an expression}
@@ -6,8 +6,7 @@
 isolate(expr)
 }
 \arguments{
-  \item{expr}{An expression that can access reactive values
-  or expressions.}
+\item{expr}{An expression that can access reactive values or expressions.}
 }
 \description{
 Executes the given expression in a scope where reactive values or expression

man/knitr_methods.Rd

@@ -0,0 +1,21 @@
+% Generated by roxygen2 (4.0.1): do not edit by hand
+\name{knitr_methods}
+\alias{knit_print.shiny.appobj}
+\alias{knit_print.shiny.render.function}
+\alias{knitr_methods}
+\title{Knitr S3 methods}
+\usage{
+knit_print.shiny.appobj(x, ...)
+
+knit_print.shiny.render.function(x, ...)
+}
+\arguments{
+\item{x}{Object to knit_print}
+
+\item{...}{Additional knit_print arguments}
+}
+\description{
+These S3 methods are necessary to help Shiny applications and UI chunks embed
+themselves in knitr/rmarkdown documents.
+}
+

man/mainPanel.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
+% Generated by roxygen2 (4.0.1): do not edit by hand
 \name{mainPanel}
 \alias{mainPanel}
 \title{Create a main panel}
@@ -6,12 +6,11 @@
 mainPanel(..., width = 8)
 }
 \arguments{
-  \item{...}{Output elements to include in the main panel}
+\item{...}{Output elements to include in the main panel}
 
-  \item{width}{The width of the main panel. For fluid
-  layouts this is out of 12 total units; for fixed layouts
-  it is out of whatever the width of the main panel's
-  parent column is.}
+\item{width}{The width of the main panel. For fluid layouts this is out of 12
+total units; for fixed layouts it is out of whatever the width of the main
+panel's parent column is.}
 }
 \value{
 A main panel that can be passed to \code{\link{sidebarLayout}}.