shiny/R/shiny.R

#' @docType package
#' @import websockets caTools RJSONIO xtable digest
NULL

suppressPackageStartupMessages({
  library(websockets)
  library(RJSONIO)
})

ShinyApp <- setRefClass(
  'ShinyApp',
  fields = list(
    .websocket = 'list',
    .invalidatedOutputValues = 'Map',
    .invalidatedOutputErrors = 'Map',
    .progressKeys = 'character',
    .fileUploadContext = 'FileUploadContext',
    session = 'Values'
  ),
  methods = list(
    initialize = function(ws) {
      .websocket <<- ws
      .invalidatedOutputValues <<- Map$new()
      .invalidatedOutputErrors <<- Map$new()
      .progressKeys <<- character(0)
      # TODO: Put file upload context in user/app-specific dir if possible
      .fileUploadContext <<- FileUploadContext$new()
      session <<- Values$new()
    },
    defineOutput = function(name, func) {
      "Binds an output generating function to this name. The function can either
      take no parameters, or have named parameters for \\code{name} and
      \\code{shinyapp} (in the future this list may expand, so it is a good idea
      to also include \\code{...} in your function signature)."
      
      # jcheng 08/31/2012: User submitted an example of a dynamically calculated
      # name not working unless name was eagerly evaluated. Yikes!
      force(name)
      
      if (is.function(func)) {
        if (length(formals(func)) != 0) {
          orig <- func
          func <- function() {
            orig(name=name, shinyapp=.self)
          }
        }

        obs <- Observer$new(function() {
          
          value <- try(func(), silent=FALSE)
          
          .invalidatedOutputErrors$remove(name)
          .invalidatedOutputValues$remove(name)
          
          if (inherits(value, 'try-error')) {
            cond <- attr(value, 'condition')
            .invalidatedOutputErrors$set(
              name, 
              list(message=cond$message,
                   call=capture.output(print(cond$call))))
          }
          else
            .invalidatedOutputValues$set(name, value)
        })
        
        obs$onInvalidateHint(function() {
          showProgress(name)
        })
      }
      else {
        stop(paste("Unexpected", class(func), "output for", name))
      }
    },
    flushOutput = function() {
      if (length(.progressKeys) == 0
          && length(.invalidatedOutputValues) == 0
          && length(.invalidatedOutputErrors) == 0) {
        return(invisible())
      }
      
      .progressKeys <<- character(0)
      
      values <- .invalidatedOutputValues
      .invalidatedOutputValues <<- Map$new()
      errors <- .invalidatedOutputErrors
      .invalidatedOutputErrors <<- Map$new()
      
      json <- toJSON(list(errors=as.list(errors),
                          values=as.list(values)))

      .write(json)
    },
    showProgress = function(id) {
      'Send a message to the client that recalculation of the output identified
      by \\code{id} is in progress. There is currently no mechanism for
      explicitly turning off progress for an output component; instead, all
      progress is implicitly turned off when flushOutput is next called.'
      if (id %in% .progressKeys)
        return()
      
      .progressKeys <<- c(.progressKeys, id)
      
      json <- toJSON(list(progress=list(id)))
      
      .write(json)
    },
    dispatch = function(msg) {
      method <- paste('@', msg$method, sep='')
      func <- try(do.call(`$`, list(.self, method)), silent=TRUE)
      if (inherits(func, 'try-error')) {
        .sendErrorResponse(msg, paste('Unknown method', msg$method))
      }
      
      value <- try(do.call(func, as.list(append(msg$args, msg$blobs))))
      if (inherits(value, 'try-error')) {
        .sendErrorResponse(msg, paste('Error:', as.character(value)))
      }
      else {
        .sendResponse(msg, value)
      }
    },
    .sendResponse = function(requestMsg, value) {
      if (is.null(requestMsg$tag)) {
        warning("Tried to send response for untagged message; method: ",
                requestMsg$method)
        return()
      }
      .write(toJSON(list(response=list(tag=requestMsg$tag, value=value))))
    },
    .sendErrorResponse = function(requestMsg, error) {
      if (is.null(requestMsg$tag))
        return()
      .write(toJSON(list(response=list(tag=requestMsg$tag, error=error))))
    },
    .write = function(json) {
      if (getOption('shiny.trace', FALSE))
        message('SEND ', json)
      if (getOption('shiny.transcode.json', TRUE))
        json <- iconv(json, to='UTF-8')
      websocket_write(json, .websocket)
    },
    
    # Public RPC methods
    `@uploadInit` = function() {
      return(list(jobId=.fileUploadContext$createUploadOperation()))
    },
    `@uploadFileBegin` = function(jobId, fileName, fileType, fileSize) {
      .fileUploadContext$getUploadOperation(jobId)$fileBegin(list(
        name=fileName, type=fileType, size=fileSize
      ))
      invisible()
    },
    `@uploadFileChunk` = function(jobId, ...) {
      args <- list(...)
      if (length(args) != 1)
        stop("Bad file chunk request")
      .fileUploadContext$getUploadOperation(jobId)$fileChunk(args[[1]])
      invisible()
    },
    `@uploadFileEnd` = function(jobId) {
      .fileUploadContext$getUploadOperation(jobId)$fileEnd()
      invisible()
    },
    `@uploadEnd` = function(jobId, inputId) {
      fileData <- .fileUploadContext$getUploadOperation(jobId)$finish()
      session$set(inputId, fileData)
      invisible()
    }
  )
)

.createOutputWriter <- function(shinyapp) {
  ow <- list(impl=shinyapp)
  class(ow) <- 'shinyoutput'
  return(ow)
}

#' @S3method $<- shinyoutput
`$<-.shinyoutput` <- function(x, name, value) {
  x[['impl']]$defineOutput(name, value)
  return(invisible(x))
}

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)
  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) %in% c('/', '\\'))) {
    return(NULL)
  }
  return(abs.path)
}

httpResponse <- function(status = 200,
                         content_type = "text/html; charset=UTF-8", 
                         content = "") {
  resp <- list(status = status, content_type = content_type, content = content);
  class(resp) <- 'httpResponse'
  return(resp)
}

httpServer <- function(handlers) {
  handler <- joinHandlers(handlers)

  filter <- getOption('shiny.http.response.filter', NULL)
  if (is.null(filter))
    filter <- function(ws, header, response) response
  
  function(ws, header) {
    response <- handler(ws, header)
    if (is.null(response))
      response <- httpResponse(404, content="<h1>Not Found</h1>")
    
    response <- filter(ws, header, response)
    
    return(http_response(ws,
                         status=response$status,
                         content_type=response$content_type,
                         content=response$content))
  }
}

joinHandlers <- function(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(ws, header) NULL)
  if (length(handlers) == 1)
    return(handlers[[1]])
  
  function(ws, header) {
    for (handler in handlers) {
      response <- handler(ws, header)
      if (!is.null(response))
        return(response)
    }
    return(NULL)
  }
}

dynamicHandler <- function(filePath, dependencyFiles=filePath) {
  lastKnownTimestamps <- NA
  metaHandler <- function(ws, header) NULL
  
  if (!file.exists(filePath))
    return(metaHandler)
  
  cacheContext <- CacheContext$new()
  
  return (function(ws, header) {
    # 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() {
            source(filePath, local=TRUE)
          })
        })
      }
      metaHandler <<- joinHandlers(.globals$clients)
      clearClients()
    }
    
    return(metaHandler(ws, header))
  })
}

staticHandler <- function(root) {
  return(function(ws, header) {
    path <- header$RESOURCE
    
    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 <- switch(ext,
                           html='text/html; charset=UTF-8',
                           htm='text/html; charset=UTF-8',
                           js='text/javascript',
                           css='text/css',
                           png='image/png',
                           jpg='image/jpeg',
                           jpeg='image/jpeg',
                           gif='image/gif',
                           'application/octet-stream')
    response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
    return(httpResponse(200, content.type, response.content))
  })
}

apps <- Map$new()

# 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 <- new.env()

.globals$clients <- function(ws, header) NULL


clearClients <- function() {
  .globals$clients <- function(ws, header) NULL
}


registerClient <- function(client) {
  .globals$clients <- append(.globals$clients, client)
}


.globals$resources <- list()

#' 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, 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 (existing$directoryPath != directoryPath) {
      warning("Overriding existing prefix ", prefix, " => ",
              existing$directoryPath)
    }
  }
  
  message('Shiny URLs starting with /', prefix, ' will mapped to ', directoryPath)
  
  .globals$resources[[prefix]] <- list(directoryPath=directoryPath,
                                       func=staticHandler(directoryPath))
}

resourcePathHandler <- function(ws, header) {
  path <- header$RESOURCE
  
  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))
  
  header$RESOURCE <- suffix
  
  return(resInfo$func(ws, header))
}

.globals$server <- NULL
#' 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.
#' 
#' 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) {
#'   output$uppercase <- reactiveText(function() {
#'     toupper(input$message)
#'   })
#' })
#' }
#' 
#' @export
shinyServer <- function(func) {
  .globals$server <- func
  invisible()
}

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)
}

# Takes a list-of-lists and returns a matrix. The lists
# must all be the same length. NULL is replaced by NA.
unpackMatrix <- 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)
}

# 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]])
}

# Instantiates the app in the current working directory.
# port - The TCP port that the application should listen on.
startApp <- function(port=8101L) {

  sys.www.root <- system.file('www', package='shiny')
  
  globalR <- file.path.ci(getwd(), 'global.R')
  uiR <- file.path.ci(getwd(), 'ui.R')
  serverR <- file.path.ci(getwd(), 'server.R')
  wwwDir <- file.path.ci(getwd(), 'www')
  
  if (!file.exists(uiR) && !file.exists(wwwDir))
    stop(paste("Neither ui.R nor a www subdirectory was found in", getwd()))
  if (!file.exists(serverR))
    stop(paste("server.R file was not found in", getwd()))
  
  if (file.exists(globalR))
    source(globalR, local=FALSE)
  
  shinyServer(NULL)
  serverFileTimestamp <- NULL
  local({
    serverFileTimestamp <<- file.info(serverR)$mtime
    source(serverR, local=TRUE)
    if (is.null(.globals$server))
      stop("No server was defined in server.R")
  })
  serverFunc <- .globals$server
  
  ws_env <- create_server(
    port=port,
    webpage=httpServer(c(dynamicHandler(uiR),
                         wwwDir,
                         sys.www.root,
                         resourcePathHandler)))
  
  set_callback('established', function(WS, ...) {
    shinyapp <- ShinyApp$new(WS)
    apps$set(wsToKey(WS), shinyapp)
  }, ws_env)
  
  set_callback('closed', function(WS, ...) {
    apps$remove(wsToKey(WS))
  }, ws_env)
  
  set_callback('receive', function(DATA, WS, ...) {
    if (getOption('shiny.trace', FALSE)) {
      if (as.raw(0) %in% DATA)
        message("RECV ", '$$binary data$$')
      else
        message("RECV ", rawToChar(DATA))
    }
    
    if (identical(charToRaw("\003\xe9"), DATA))
      return()
    
    shinyapp <- apps$get(wsToKey(WS))
    
    msg <- decodeMessage(DATA)

    # 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
          
          # TODO: Make the below a user-extensible registry of deserializers
          msg$data[[ splitName[[1]] ]] <- switch(
            splitName[[2]],
            matrix = unpackMatrix(val),
            stop('Unknown type specified for ', name)
          )
        }
        else if (is.list(val) && is.null(names(val)))
          msg$data[[name]] <- unlist(val, recursive=FALSE)
      }
    }
    
    switch(
      msg$method,
      init = {
        
        # Check if server.R has changed, and if so, reload
        mtime <- file.info(serverR)$mtime
        if (!identical(mtime, serverFileTimestamp)) {
          shinyServer(NULL)
          local({
            serverFileTimestamp <<- mtime
            source(serverR, local=TRUE)
            if (is.null(.globals$server))
              stop("No server was defined in server.R")
          })
          serverFunc <<- .globals$server
        }
        
        shinyapp$session$mset(msg$data)
        flushReact()
        local({
          serverFunc(input=.createValuesReader(shinyapp$session),
                     output=.createOutputWriter(shinyapp))
        })
      },
      update = {
        shinyapp$session$mset(msg$data)
      },
      shinyapp$dispatch(msg)
    )
    flushReact()
    shinyapp$flushOutput()
  }, ws_env)
  
  message('\n', 'Listening on port ', port)
  
  return(ws_env)
}

# NOTE: we de-roxygenized this comment because the function isn't exported
# Run an application that was created by \code{\link{startApp}}. This
# function should normally be called in a \code{while(TRUE)} loop.
# 
# @param ws_env The return value from \code{\link{startApp}}.
serviceApp <- function(ws_env) {
  if (timerCallbacks$executeElapsed()) {
    flushReact()
     lapply(apps$values(), function(shinyapp) {
       shinyapp$flushOutput()
       NULL
     })
  }

  # 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, 5000)
  
  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent()))
  service(server=ws_env, timeout=timeout)
}

#' 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).
#' 
#' @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 
#'   port 8100.
#' @param launch.browser If true, the system's default web browser will be 
#'   launched automatically after the app is started. Defaults to true in 
#'   interactive sessions only.
#'   
#' @export
runApp <- function(appDir=getwd(),
                   port=8100L,
                   launch.browser=getOption('shiny.launch.browser',
                                            interactive())) {

  # Make warnings print immediately
  ops <- options(warn = 1)
  on.exit(options(ops))
  
  orig.wd <- getwd()
  setwd(appDir)
  on.exit(setwd(orig.wd))
  
  ws_env <- startApp(port=port)
  
  if (launch.browser) {
    appUrl <- paste("http://localhost:", port, sep="")
    utils::browseURL(appUrl)
  }
  
  tryCatch(
    while (TRUE) {
      serviceApp(ws_env)
    },
    finally = {
      timerCallbacks$clear()
      websocket_close(ws_env)
    }
  )
}

#' 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 
#'   port 8100.
#' @param launch.browser If true, the system's default web browser will be 
#'   launched automatically after the app is started. Defaults to true in 
#'   interactive sessions only.
#'   
#' @export
runExample <- function(example=NA,
                       port=8100L,
                       launch.browser=getOption('shiny.launch.browser',
                                                interactive())) {
  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, launch.browser = launch.browser)
  }
}

# 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 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, ...)
  }
}

#' Run a Shiny application from https://gist.github.com
#' 
#' Download and launch a Shiny application that is hosted on GitHub as a gist.
#' 
#' @param gist The identifier of the gist. For example, if the gist is
#'   https://gist.github.com/3239667, then \code{3239667}, \code{'3239667'}, and
#'   \code{'https://gist.github.com/3239667'} are all valid values.
#' @param port The TCP port that the application should listen on. Defaults to 
#'   port 8100.
#' @param launch.browser If true, the system's default web browser will be 
#'   launched automatically after the app is started. Defaults to true in 
#'   interactive sessions only.
#'   
#' @export
runGist <- function(gist,
                    port=8100L,
                    launch.browser=getOption('shiny.launch.browser',
                                             interactive())) {

  gistUrl <- if (is.numeric(gist) || grepl('^[0-9a-f]+$', gist)) {
    sprintf('https://gist.github.com/gists/%s/download', gist)
  } else if(grepl('^https://gist.github.com/([0-9a-f]+)$', gist)) {
    paste(sub('https://gist.github.com/',
              'https://gist.github.com/gists/',
              gist),
          '/download',
          sep='')
  } else {
    stop('Unrecognized gist identifier format')
  }
  filePath <- tempfile('shinygist', fileext='.tar.gz')
  if (download(gistUrl, filePath, mode = "wb", quiet = TRUE) != 0)
    stop("Failed to download URL ", gistUrl)
  on.exit(unlink(filePath))
  
  dirname <- untar(filePath, list=TRUE)[1]
  untar(filePath, exdir=dirname(filePath))
  
  appdir <- file.path(dirname(filePath), dirname)
  on.exit(unlink(appdir, recursive = TRUE))
  
  runApp(appdir, port=port, launch.browser=launch.browser)
}