Add example

DESCRIPTION

@@ -129,6 +129,7 @@ Collate:
     'reactives.R'
     'render-plot.R'
     'render-table.R'
+    'restore.R'
     'run-url.R'
     'server-input-handlers.R'
     'server.R'

NAMESPACE

@@ -165,6 +165,8 @@ export(renderText)
 export(renderUI)
 export(repeatable)
 export(req)
+export(restoreInput)
+export(restoreValue)
 export(runApp)
 export(runExample)
 export(runGadget)

R/restore.R

@@ -0,0 +1,71 @@
+readBookmarkDataURL <- function(url) {
+  values <- parseQueryString(url, nested = TRUE)
+  mapply(names(values), values,
+    FUN = function(name, value) {
+      tryCatch(
+        jsonlite::fromJSON(value),
+        error = function(e) {
+          stop("Failed to parse URL parameter \"", name, "\"")
+        }
+      )
+    }
+  )
+}
+
+saveBookmarkDataURL <- function(input, values, files) {
+  vals <- vapply(reactiveValuesToList(input), function(x) {
+    toJSON(x, strict_atomic = FALSE)
+  }, character(1), USE.NAMES = TRUE)
+  paste0(
+    encodeURIComponent(names(vals)),
+    "=",
+    encodeURIComponent(vals),
+    collapse = "&"
+  )
+}
+
+
+restoreCtxStack <- Stack$new()
+
+withRestoreContext <- function(ctx, expr) {
+  restoreCtxStack$push(ctx)
+  on.exit(restoreCtxStack$pop(), add = TRUE)
+
+  force(expr)
+}
+
+# Call to access the current restore context
+getCurrentRestoreContext <- function() {
+  ctx <- restoreCtxStack$peek()
+  if (is.null(ctx)) {
+    stop("No restore context found")
+  }
+  ctx
+}
+
+extractRestoreContext <- function(url) {
+  list(
+    input = readBookmarkDataURL(url),
+    values = list()
+  )
+}
+
+#' @export
+restoreInput <- function(id, defaultValue) {
+  ctx <- getCurrentRestoreContext()
+  if (id %in% names(ctx$input)) {
+    ctx$input[[id]]
+  } else {
+    defaultValue
+  }
+}
+
+#' @export
+restoreValue <- function(id, defaultValue) {
+  ctx <- getCurrentRestoreContext()
+  if (id %in% names(ctx$values)) {
+    ctx$input[[id]]
+  } else {
+    defaultValue
+  }
+}

R/shiny.R

@@ -115,10 +115,14 @@ createUniqueId <- function(bytes, prefix = "", suffix = "") {
 toJSON <- function(x, ...,  dataframe = "columns", null = "null", na = "null",
   auto_unbox = TRUE, digits = getOption("shiny.json.digits", 16),
   use_signif = TRUE, force = TRUE, POSIXt = "ISO8601", UTC = TRUE,
-  rownames = FALSE, keep_vec_names = TRUE) {
+  rownames = FALSE, keep_vec_names = TRUE, strict_atomic = TRUE) {
+
+  if (strict_atomic) {
+    x <- I(x)
+  }
 
   # I(x) is so that length-1 atomic vectors get put in [].
-  jsonlite::toJSON(I(x), dataframe = dataframe, null = null, na = na,
+  jsonlite::toJSON(x, dataframe = dataframe, null = null, na = na,
    auto_unbox = auto_unbox, digits = digits, use_signif = use_signif,
    force = force, POSIXt = POSIXt, UTC = UTC, rownames = rownames,
    keep_vec_names = keep_vec_names, json_verbatim = TRUE, ...)
@@ -766,6 +770,9 @@ ShinySession <- R6Class(
     reload = function() {
       private$sendMessage(reload = TRUE)
     },
+    updateUrl = function(url) {
+      private$sendMessage(historyReplaceState = list(url = url))
+    },
 
     # Public RPC methods
     `@uploadieFinish` = function() {

R/shinyui.R

@@ -92,13 +92,15 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
         showcaseMode <- mode
     }
     uiValue <- if (is.function(ui)) {
-      if (length(formals(ui)) > 0) {
-        # No corresponding ..stacktraceoff.., this is pure user code
-        ..stacktraceon..(ui(req))
-      } else {
-        # No corresponding ..stacktraceoff.., this is pure user code
-        ..stacktraceon..(ui())
-      }
+      withRestoreContext(extractRestoreContext(req$QUERY_STRING), {
+        if (length(formals(ui)) > 0) {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          ..stacktraceon..(ui(req))
+        } else {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          ..stacktraceon..(ui())
+        }
+      })
     } else {
       ui
     }

R/utils.R

@@ -539,7 +539,13 @@ shinyCallingHandlers <- function(expr) {
         return()
 
       handle <- getOption('shiny.error')
-      if (is.function(handle)) handle()
+      if (is.function(handle)) {
+        if ("condition" %in% names(formals(handle))) {
+          handle(condition = e)
+        } else {
+          handle()
+        }
+      }
     }
   )
 }
@@ -1295,3 +1301,17 @@ wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
 
   relabelWrapper
 }
+
+MutableValue <- R6Class("MutableValue",
+  public = list(
+    get = function() {
+      private$value
+    },
+    set = function(value) {
+      private$value <- value
+    }
+  ),
+  private = list(
+    value = NULL
+  )
+)

examples/bookmarkable-state.R

@@ -0,0 +1,48 @@
+library(shiny)
+
+mymodUI <- function(id, initialValue) {
+  ns <- NS(id)
+  textInput(ns("text"), "Text", restoreInput(ns("text"), initialValue))
+}
+
+
+ui <- function(req) {
+  fluidPage(
+    verbatimTextOutput("url"),
+    numericInput("n", "n", restoreInput("n", 10)),
+    mymodUI("a", "Hello"),
+    mymodUI("b", "World"),
+    sliderInput("slider", "Slider", 0, 100, restoreInput("slider", c(10, 20))),
+    tabsetPanel(id = "tabs", selected = restoreInput("tabs", NULL),
+      tabPanel("Letters",
+        selectInput("letter", "Letter", LETTERS, selected = restoreInput("letter", "A")),
+        textOutput("letterOut", h1)
+      ),
+      tabPanel("Random",
+        numericInput("runifCount", "How many?", restoreInput("runifCount", 10)),
+        tableOutput("runif")
+      )
+    )
+  )
+}
+
+server <- function(input, output, session) {
+  output$url <- renderText({
+    shiny:::saveBookmarkDataURL(input, NULL, NULL)
+  })
+  
+  output$letterOut <- renderText(input$letter)
+  
+  output$runif <- renderTable({
+    data.frame(
+      values = runif(input$runifCount)
+    )
+  })
+  
+  observe({
+    session$updateUrl(paste0("?", shiny:::saveBookmarkDataURL(input, NULL, NULL)))
+  })
+}
+
+shinyApp(ui, server)
+

inst/www/shared/shiny.js

@@ -1130,6 +1130,10 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
       window.location.reload();
     });
 
+    addMessageHandler('historyReplaceState', function (message) {
+      window.history.replaceState(null, null, message.url);
+    });
+
     // Progress reporting ====================================================
 
     var progressHandlers = {

srcjs/shinyapp.js

@@ -631,6 +631,10 @@ var ShinyApp = function() {
     window.location.reload();
   });
 
+  addMessageHandler('historyReplaceState', function(message) {
+    window.history.replaceState(null, null, message.url);
+  });
+
 
   // Progress reporting ====================================================