R/server.R

In srtg4we5gsetrgwhreyt/tdyhsrgesrgaesrgfae: Save and restore the state of Shiny apps

options(scipen=999)

#' @details The \code{shinyURL.server} method contains server logic for encoding
#'   and restoring the widgets' values. It is called from inside the app's 
#'   server script, and can take the \code{session} objects as argument.
#'   
#'   The argument \code{options} can contain a named list of options. These are
#'   set by a call to \code{\link[base]{options}} as \sQuote{shinyURL.name}. See below for a list of available options.
#' @section ShinyURL options:  
#' \describe{
#'  \item{\code{debug = TRUE}}{Print debug messages to the console}
#' }
#' @param session Typically the same as the optional parameter passed into the 
#'   Shiny server function as an argument; if missing defaults to 
#'   \code{getDefaultReactiveDomain()}
#' @param options Named list of options
#' @return \code{shinyURL.server} returns a reactive expression evaluating to 
#'   the app's URL.
#' @rdname shinyURL
#' @export
shinyURL.server = function(session, options) {
  try({
    
  if (missing(session))
    session = getDefaultReactiveDomain()
  
  if (!missing(options))
    options(setNames(options, paste("shinyURL", names(options), sep=".")))
  
  debugMsg("ShinyURL initializes")
  
  
  ## initialize from query string
  init = .initFromURL(session, init)
  
  ## encode current app's state
  url = .encodeURL(session, inputId)
  
  ## use TinyURL for shortening the URL
  #.queryTinyURL(session)
  
  ## Initial invalidation needed to execute scheduled input updates when the 
  ## browser is refreshed switched off because it interferes with dynamic UIs 
  ## invalidate = .invalidateOnInit(session, invalidate)
  
  return(url)
    })
}


.initFromURL = function(session, self) {
  queryValues <- isolate(parseQueryString(session$clientData$url_search, nested=TRUE))
  observe({
    debugMsg(".initFromURL")
    queryValuesCopy = queryValues
    
    ## iterate through available inputs as long as there are any uninitialized 
    ## values in queryValues the expression below depends on inputs which is 
    ## neccassary to restore dynamic UIs
     try({
          inputValues = reactiveValuesToList(session$input, all.names=FALSE)
          updateValues = intersect(names(inputValues), names(queryValues))
          queryIds = match(updateValues, names(queryValues))
          inputIds = match(updateValues, names(inputValues))
       })
    
    if ( length(queryIds) > 0 ) queryValues <<- queryValues[-queryIds]
    
    ## schedule the update only after all input messages have been sent out (see
    ## the 'flushOutput' function in shiny.R). This is to avoid potential 
    ## overwriting by some update events from user code
    session$onFlushed(function() {
       try({.initInputs(session, queryValuesCopy[queryIds], inputValues[inputIds])})
    })
    
    ## suspend if nothing to do
    if ( length(queryValues) == 0L )
      self$suspend()
    
  }, priority = -99)
}


.initInputs = function(session, queryValues, inputValues) {
  try({
  for (i in seq_along(queryValues)) {
    q = queryValues[[i]]
    
    q = if (is.list(q)) {
      ## checkbox group or multiple select
      unlist(q, use.names=FALSE)
    }
    else {
      try({
            ## decode range vectors (sliders and dates)
            if (length(inputValues[[i]])>1L)
              q = unlist(strsplit(q, ","))
            ## use information about the class of the inputs when initializing them
            cl = class(inputValues[[i]])
            ## promote integer to numeric because numericInputs can contain either
            if (cl=="integer")
              cl = "numeric" 
            switch(cl,
                   ## selectInput without default value is initially set to NULL
                   NULL = q,
                   ## Dates need to be handled separately
                   Date = format(as.Date(as.numeric(q), "1970-01-01"), "%Y-%m-%d"),
                   ## default case; should allow to correctly decode TRUE/FALSE
                   as(q, cl)
            )
        })
    }
          
    debugMsg("init", names(queryValues)[i], "->", q)
    session$sendInputMessage(names(queryValues)[i], list(value=q))
  }
    })
}


.encodeURL = function(session, inputId) {
  options(scipen=999)
  clientData = isolate(reactiveValuesToList(session$clientData))
  
  ## base URL which is not supposed to change
  baseURL = paste0(#"http://tools.rotationinvest.com",
                   clientData$url_hostname,
                   # ## add port number if present
                   # if( (port=clientData$url_port)!="" ) paste0(":", port),
                   clientData$url_pathname)
  
  queryString = reactive({
    ## all.names = FALSE excludes objects with a leading dot, in particular the
    ## ".url" field to avoid self-dependency
    inputValues = reactiveValuesToList(session$input, all.names=FALSE)
    
    ## quit if there is there are no inputs to encode
    if (length(inputValues)==0) return()
    
    ## remove actionButtons
    isActionButton = unlist(lapply(inputValues, inherits, "shinyActionButtonValue"), use.names=FALSE)
    inputValues = inputValues[!isActionButton]
    
    ## remove ggvis specific inputs
    idx = grep("_mouse_(over|out)$", names(inputValues))
    if ( length(idx) > 0 ) inputValues = inputValues[-idx]
    
    ## remove dygraph specific inputs
    idx = grep("_date_window$", names(inputValues))
    if ( length(idx) > 0 ) inputValues = inputValues[-idx]
    
    ## remove plotly specific inputs
    idx = grep("plotly_afterplot-A", names(inputValues))
    if ( length(idx) > 0 ) inputValues = inputValues[-idx]
    
    ## remove rank table specific inputs
    idx = grep("rankTable_rows_current", names(inputValues))
    if ( length(idx) > 0 ) inputValues = inputValues[-idx]
    idx = grep("rankTable_rows_all", names(inputValues))
    if ( length(idx) > 0 ) inputValues = inputValues[-idx]
    
    inputValues = mapply(function(name, value) {
      ## this is important to be able to have all checkboxes unchecked
      if (is.null(value))
        ""
      else {
        if (length(value) == 1L) {
          ## encode TRUE/FALSE as T/F
          if (is.logical(value)) {
            if (isTRUE(value)) "T" else "F"
          }
          else value
        }
        else {
          cl = class(value)
          ## expand checkbox group and multiple select vectors
          if (cl=="character") {
            setNames(as.list(value), sprintf("%s[%s]", name, seq_along(value)))
          }
          ## encode range vectors as comma separated string
          else {
            if (cl=="Date") value = as.integer(value)
            paste(value, collapse=",")
          } 
        }
      }
    }, names(inputValues), inputValues, SIMPLIFY=FALSE)
    
    ## remove names of sublists before flattening
    names(inputValues)[sapply(inputValues, is.list)] = ""
    inputValues = unlist(inputValues)
    
    URLencode(paste(names(inputValues), inputValues, sep = "=", collapse = "&"))
  })
  
  observe({
    debugMsg(".updateURL")
    updateTextInput(session, inputId, value = url())
    #updateTextInput(session, ".shinyURL.queryString", value = queryString())
  }, priority = -999)
  
  url = reactive({
    paste(c(baseURL, queryString()), collapse = "?")
  })
  
  url
}


# .queryTinyURL = function(session) {
#   input = session$input
#   .busyMsg = "Please wait..."
#   
#   ## construct a query string from the current URL
#   tinyURLquery = eventReactive(input$.getTinyURL, {
#     sprintf("http://tinyurl.com/api-create.php?url=%s", input[[inputId]]) 
#   })
#   
#   ## set busy message
#   observeEvent(tinyURLquery(), {
#     updateTextInput(session, inputId, value=.busyMsg)
#     
#     ## resume the observer only after .busyMsg is set
#     session$onFlushed(function() {
#       runTinyURLquery$resume()
#     })
#   })
#   
#   ## query TinyURL
#   runTinyURLquery = observe({
#     tinyurl = tryCatch(getURL(tinyURLquery()), error = function(e) "Error fetching tinyURL!")
#     updateTextInput(session, inputId, value=tinyurl)
#     runTinyURLquery$suspend()
#   }, suspended=TRUE)
#   
#   invisible()
# }