From 141c57ad1e9230722ea012d71df82ce1c8580c88 Mon Sep 17 00:00:00 2001 From: Joe Cheng Date: Tue, 26 Jun 2012 17:53:28 -0700 Subject: [PATCH] Implement Shiny server in R - Use websockets package to implement Shiny server in R - NB: Current behavior is undefined if more than one client connects at the same time - Added HTML and plot (actually image) binding types on the client --- R/react.R | 29 +++++++- R/shiny.R | 178 +++++++++++++++++++++++++++++++++++++++++++++++++ www/index.html | 6 +- www/shiny.js | 29 +++++++- 4 files changed, 237 insertions(+), 5 deletions(-) create mode 100644 R/shiny.R diff --git a/R/react.R b/R/react.R index 913331166..3504854fd 100644 --- a/R/react.R +++ b/R/react.R @@ -26,13 +26,15 @@ Map <- setRefClass( }, set = function(key, value) { assign(key, value, pos=.env, inherits=F) + return(value) }, remove = function(key) { - if (contains.key(key)) { + if (.self$contains.key(key)) { + result <- .self$get(key) rm(list = key, pos=.env, inherits=F) - return(T) + return(result) } - return(F) + return(NULL) }, contains.key = function(key) { exists(key, where=.env, inherits=F) @@ -45,10 +47,23 @@ Map <- setRefClass( }, clear = function() { .env <<- new.env(parent=emptyenv()) + invisible(NULL) + }, + size = function() { + length(.env) } ) ) +as.list.Map <- function(map) { + sapply(map$keys(), + map$get, + simplify=F) +} +length.Map <- function(map) { + map$size() +} + Context <- setRefClass( 'Context', fields = list( @@ -174,6 +189,12 @@ Values <- setRefClass( } ) invisible() + }, + mset = function(lst) { + lapply(names(lst), + function(name) { + .self$set(name, lst[[name]]) + }) } ) ) @@ -277,4 +298,6 @@ test <- function () { flush.react() values$set('b', 300) flush.react() + values$mset(list(a = 10, b = 20)) + flush.react() } diff --git a/R/shiny.R b/R/shiny.R new file mode 100644 index 000000000..444d9eddc --- /dev/null +++ b/R/shiny.R @@ -0,0 +1,178 @@ +library(websockets) +library(RJSONIO) +library(caTools) +library(xtable) + +ShinyApp <- setRefClass( + 'ShinyApp', + fields = list( + .websocket = 'list', + .outputs = 'Map', + .invalidated.output.values = 'Map', + session = 'Values' + ), + methods = list( + initialize = function(ws) { + .websocket <<- ws + .outputs <<- Map$new() + .invalidated.output.values <<- Map$new() + session <<- Values$new() + }, + define.output = function(name, func) { + .outputs$set(name, func) + }, + define.plot.output = function(name, func, ...) { + .outputs$set(name, function() { + png.file <- tempfile(fileext='.png') + png(filename=png.file, ...) + func() + dev.off() + + bytes <- file.info(png.file)$size + if (is.na(bytes)) + return(NULL) + + b64 <- base64encode(readBin(png.file, 'raw', n=bytes)) + return(paste("data:image/png;base64,", b64, sep='')) + }) + }, + instantiate.outputs = function() { + lapply(.outputs$keys(), + function(key) { + func <- .outputs$remove(key) + Observer$new(function() { + value <- func() + .invalidated.output.values$set(key, value) + }) + }) + }, + flush.output = function() { + if (length(.invalidated.output.values) == 0) + return(invisible()) + + data <- .invalidated.output.values + .invalidated.output.values <<- Map$new() + cat(c("SEND", toJSON(as.list(data)), "\n")) + websocket_write(toJSON(as.list(data)), .websocket) + } + ) +) + +statics <- function(root) { + root <- normalizePath(root, mustWork=T) + + return(function(ws, header) { + # TODO: Stop using websockets' internal methods + path <- header$RESOURCE + + if (is.null(path)) + return(websockets:::.http_400(ws)) + + if (path == '/') + path <- '/index.html' + + abs.path <- file.path(root, path) + + if (!file.exists(abs.path)) { + # TODO: This should be 404, not 400 + return(websockets:::.http_400(ws)) + } + + abs.path <- normalizePath(abs.path, mustWork=T) + + if (nchar(abs.path) <= nchar(root) + 1) { + return(websockets:::.http_400(ws)) + } + + if (substr(abs.path, 1, nchar(root)) != root || + !(substr(abs.path, nchar(root)+1, nchar(root)+1) %in% c('/', '\\'))) { + return(websockets:::.http_400(ws)) + } + + 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(websockets:::.http_200(ws, content.type, response.content)) + }) +} + +start.app <- function(port = 8101L) { + + ws_env <- create_server(port=port, webpage=statics('./www')) + + set_callback('established', function(WS, ...) { + shinyapp <<- ShinyApp$new(WS) + + input <- Observable$new(function() { + str <- shinyapp$session$get('input1') + if (shinyapp$session$get('addnewline')) + str <- paste(str, "\n", sep='') + return(str) + }) + input.df <- Observable$new(function() { + varname <- shinyapp$session$get('input1') + if (nchar(varname) > 0 && exists(varname, where=.GlobalEnv)) { + df <- get(varname, pos=.GlobalEnv) + if (is.data.frame(df)) { + return(df) + } + } + return(NULL) + }) + shinyapp$define.output('md5_hash', function() { + digest(input$get.value(), algo='md5', serialize=F) + }) + shinyapp$define.output('sha1_hash', function() { + digest(input$get.value(), algo='sha1', serialize=F) + }) + shinyapp$define.output('table1', function() { + if (!is.null(input.df$get.value())) + print(xtable(input.df$get.value()), type='html') + }) + shinyapp$define.plot.output('plot1', function() { + if (!is.null(input.df$get.value())) + plot(input.df$get.value()) + }, width=800, height=600) + + }, ws_env) + + set_callback('closed', function(WS, ...) { + }, ws_env) + + set_callback('receive', function(DATA, WS, ...) { + cat(c("RECV", rawToChar(DATA), "\n")) + + if (identical(charToRaw("\003\xe9"), DATA)) + return() + + msg <- fromJSON(rawToChar(DATA), asText=T, simplify=F) + switch( + msg$method, + init = { + shinyapp$session$mset(msg$data) + flush.react() + shinyapp$instantiate.outputs() + }, + update = { + shinyapp$session$mset(msg$data) + }) + flush.react() + shinyapp$flush.output() + }, ws_env) + + return(ws_env) +} + +run.app <- function(ws_env) { + while (T) + service(server=ws_env) +} diff --git a/www/index.html b/www/index.html index 3b3dd240c..aa0100435 100644 --- a/www/index.html +++ b/www/index.html @@ -9,7 +9,7 @@


- + Append newline

@@ -22,5 +22,9 @@ 

   

+  
+  

+  
+  

 
 
diff --git a/www/shiny.js b/www/shiny.js
index 58a34d800..5a39bface 100644
--- a/www/shiny.js
+++ b/www/shiny.js
@@ -92,14 +92,35 @@
   var LiveTextBinding = function(el) {
     this.el = el;
   };
-
   (function() {
     this.onValueChange = function(data) {
       $(this.el).text(data);
     };
   }).call(LiveTextBinding.prototype);
 
+  var LivePlotBinding = function(el) {
+    this.el = el;
+  };
+  (function() {
+    this.onValueChange = function(data) {
+      $(this.el).empty();
+      if (!data)
+        return;
+      var img = document.createElement('img');
+      img.src = data;
+      this.el.appendChild(img);
+    };
+  }).call(LivePlotBinding.prototype);
 
+  var LiveHTMLBinding = function(el) {
+    this.el = el;
+  };
+  (function() {
+    this.onValueChange = function(data) {
+      $(this.el).html(data)
+    };
+  }).call(LiveHTMLBinding.prototype);
+  
   $(function() {
 
     var shinyapp = window.shinyapp = new ShinyApp();
@@ -107,6 +128,12 @@
     $('.live-text').each(function() {
       shinyapp.bind(this.id, new LiveTextBinding(this));
     });
+    $('.live-plot').each(function() {
+      shinyapp.bind(this.id, new LivePlotBinding(this));
+    });
+    $('.live-html').each(function() {
+      shinyapp.bind(this.id, new LiveHTMLBinding(this));
+    });
 
     function elementToValue(el) {
       if (el.type == 'checkbox')