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

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

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

www/index.html

@@ -9,7 +9,7 @@
 
   <p>
     <label>Input:</label><br />
-    <input name="input1" value="Hello World!"/>
+    <input name="input1" value="cars"/>
     <input type="checkbox" name="addnewline" checked="checked"/> Append newline
   </p>
 
@@ -22,5 +22,9 @@
     <label>SHA-1:</label><br />
     <pre id="sha1_hash" class="live-text"></pre>
   </p>
+  
+  <div id="table1" class="live-html"></div>
+  
+  <div id="plot1" class="live-plot"></div>
 </body>
 </html>

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