Add support for progress indication

The CSS class 'recalculating' will be added to any output elements whose content might be affected by a change to one or more of the inputs.

R/react.R

@@ -3,19 +3,30 @@ Context <- setRefClass(
   fields = list(
     id = 'character',
     .invalidated = 'logical',
-    .callbacks = 'list'
+    .callbacks = 'list',
+    .hintCallbacks = 'list'
   ),
   methods = list(
     initialize = function() {
       id <<- .getReactiveEnvironment()$nextId()
       .invalidated <<- F
       .callbacks <<- list()
+      .hintCallbacks <<- list()
     },
     run = function(func) {
       "Run the provided function under this context."
       env <- .getReactiveEnvironment()
       env$runWith(.self, func)
     },
+    invalidateHint = function() {
+      "Let this context know it may or may not be invalidated very soon; that
+      is, something in its dependency graph has been invalidated but there's no
+      guarantee that the cascade of invalidations will reach all the way here.
+      This is used to show progress in the UI."
+      lapply(.hintCallbacks, function(func) {
+        func()
+      })
+    },
     invalidate = function() {
       "Schedule this context for invalidation. It will not actually be
         invalidated until the next call to \\code{\\link{flushReact}}."
@@ -35,6 +46,9 @@ Context <- setRefClass(
         .callbacks <<- c(.callbacks, func)
       NULL
     },
+    onInvalidateHint = function(func) {
+      .hintCallbacks <<- c(.hintCallbacks, func)
+    },
     executeCallbacks = function() {
       "For internal use only."
       lapply(.callbacks, function(func) {

R/reactives.R

@@ -40,6 +40,7 @@ Values <- setRefClass(
       lapply(
         mget(dep.keys, envir=.dependencies),
         function(ctx) {
+          ctx$invalidateHint()
           ctx$invalidate()
           NULL
         }
@@ -77,11 +78,11 @@ Values <- setRefClass(
 
 Observable <- setRefClass(
   'Observable',
-  fields = c(
-    '.func',         # function
-    '.dependencies', # Map
-    '.initialized',  # logical
-    '.value'         # any
+  fields = list(
+    .func = 'function',
+    .dependencies = 'Map',
+    .initialized = 'logical',
+    .value = 'ANY'
   ),
   methods = list(
     initialize = function(func) {
@@ -114,6 +115,14 @@ Observable <- setRefClass(
       ctx$onInvalidate(function() {
         .self$.updateValue()
       })
+      ctx$onInvalidateHint(function() {
+        lapply(
+          .dependencies$values(),
+          function(dep.ctx) {
+            dep.ctx$invalidateHint()
+            NULL
+          })
+      })
       ctx$run(function() {
         .value <<- try(.func(), silent=F)
       })
@@ -165,7 +174,8 @@ reactive.default <- function(x) {
 Observer <- setRefClass(
   'Observer',
   fields = list(
-    .func = 'function'
+    .func = 'function',
+    .hintCallbacks = 'list'
   ),
   methods = list(
     initialize = function(func) {
@@ -177,7 +187,16 @@ Observer <- setRefClass(
       ctx$onInvalidate(function() {
         run()
       })
+      ctx$onInvalidateHint(function() {
+        lapply(.hintCallbacks, function(func) {
+          func()
+          NULL
+        })
+      })
       ctx$run(.func)
+    },
+    onInvalidateHint = function(func) {
+      .hintCallbacks <<- c(.hintCallbacks, func)
     }
   )
 )

R/shiny.R

@@ -13,6 +13,7 @@ ShinyApp <- setRefClass(
     .outputs = 'Map',
     .invalidatedOutputValues = 'Map',
     .invalidatedOutputErrors = 'Map',
+    .progressKeys = 'character',
     session = 'Values'
   ),
   methods = list(
@@ -21,6 +22,7 @@ ShinyApp <- setRefClass(
       .outputs <<- Map$new()
       .invalidatedOutputValues <<- Map$new()
       .invalidatedOutputErrors <<- Map$new()
+      .progressKeys <<- character(0)
       session <<- Values$new()
     },
     defineOutput = function(name, func) {
@@ -45,11 +47,13 @@ ShinyApp <- setRefClass(
       lapply(.outputs$keys(),
              function(key) {
                func <- .outputs$remove(key)
-               Observer$new(function() {
+               obs <- Observer$new(function() {
+                 
+                 value <- try(func(), silent=F)
+
                  .invalidatedOutputErrors$remove(key)
                  .invalidatedOutputValues$remove(key)
                  
-                 value <- try(func(), silent=F)
                  if (identical(class(value), 'try-error')) {
                    cond <- attr(value, 'condition')
                    .invalidatedOutputErrors$set(
@@ -60,14 +64,21 @@ ShinyApp <- setRefClass(
                  else
                    .invalidatedOutputValues$set(key, value)
                })
+               
+               obs$onInvalidateHint(function() {
+                 showProgress(key)
+               })
              })
     },
     flushOutput = function() {
-      if (length(.invalidatedOutputValues) == 0
-          && length(.invalidatedOutputErrors)== 0) {
+      if (length(.progressKeys) == 0
+          && length(.invalidatedOutputValues) == 0
+          && length(.invalidatedOutputErrors) == 0) {
         return(invisible())
       }
       
+      .progressKeys <<- character(0)
+      
       values <- .invalidatedOutputValues
       .invalidatedOutputValues <<- Map$new()
       errors <- .invalidatedOutputErrors
@@ -79,6 +90,23 @@ ShinyApp <- setRefClass(
       if (getOption('shiny.trace', F))
         message("SEND ", json)
 
+      websocket_write(json, .websocket)
+    },
+    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)))
+      
+      if (getOption('shiny.trace', F))
+        message("SEND ", json)
+      
       websocket_write(json, .websocket)
     }
   )

inst/www/shared/shiny.css

@@ -16,4 +16,12 @@ table.data td[align=right] {
 
 .shiny-output-error {
   color: red;
+}
+
+.recalculating {
+  opacity: 0.3;
+  transition: opacity 250ms ease 500ms;
+  -moz-transition: opacity 250ms ease 500ms;
+  -webkit-transition: opacity 250ms ease 500ms;
+  -o-transition: opacity 250ms ease 500ms;
 }

inst/www/shared/shiny.js

@@ -151,8 +151,19 @@
         this.receiveError(key, msgObj.errors[key]);
       }
       for (key in msgObj.values) {
+        for (name in this.$bindings)
+          this.$bindings[name].showProgress(false);
         this.receiveOutput(key, msgObj.values[key]);
       }
+      if (msgObj.progress) {
+        for (var i = 0; i < msgObj.progress.length; i++) {
+          var key = msgObj.progress[i];
+          var binding = this.$bindings[key];
+          if (binding && binding.showProgress) {
+            binding.showProgress(true);
+          }
+        }
+      }
     };
 
     this.bind = function(id, binding) {
@@ -166,26 +177,49 @@
   }).call(ShinyApp.prototype);
 
 
-  var LiveTextBinding = function(el) {
+  var LiveBinding = function(el) {
     this.el = el;
   };
   (function() {
     this.onValueChange = function(data) {
-      $(this.el).removeClass('shiny-output-error');
-      $(this.el).text(data);
+      this.clearError();
+      this.renderValue(data);
     };
     this.onValueError = function(err) {
+      this.renderError(err);
+    };
+    this.renderError = function(err) {
       $(this.el).text('ERROR: ' + err.message);
       $(this.el).addClass('shiny-output-error');
-    }
+    };
+    this.clearError = function() {
+      $(this.el).removeClass('shiny-output-error');
+    };
+    this.showProgress = function(show) {
+      var RECALC_CLASS = 'recalculating';
+      if (show)
+        $(this.el).addClass(RECALC_CLASS);
+      else
+        $(this.el).removeClass(RECALC_CLASS);
+    };
+  }).call(LiveBinding.prototype);
+
+
+  var LiveTextBinding = function(el) {
+    this.el = el;
+  };
+  (function() {
+    this.renderValue = function(data) {
+      $(this.el).text(data);
+    };
   }).call(LiveTextBinding.prototype);
+  $.extend(LiveTextBinding.prototype, LiveBinding.prototype);
 
   var LivePlotBinding = function(el) {
     this.el = el;
   };
   (function() {
-    this.onValueChange = function(data) {
-      $(this.el).removeClass('shiny-output-error');
+    this.renderValue = function(data) {
       $(this.el).empty();
       if (!data)
         return;
@@ -193,26 +227,20 @@
       img.src = data;
       this.el.appendChild(img);
     };
-    this.onValueError = function(err) {
-      $(this.el).text('ERROR: ' + err.message);
-      $(this.el).addClass('shiny-output-error');
-    };
   }).call(LivePlotBinding.prototype);
+  $.extend(LivePlotBinding.prototype, LiveBinding.prototype);
 
   var LiveHTMLBinding = function(el) {
     this.el = el;
   };
   (function() {
-    this.onValueChange = function(data) {
-      $(this.el).removeClass('shiny-output-error');
+    this.renderValue = function(data) {
       $(this.el).html(data)
     };
-    this.onValueError = function(err) {
-      $(this.el).text('ERROR: ' + err.message);
-      $(this.el).addClass('shiny-output-error');
-    };
   }).call(LiveHTMLBinding.prototype);
-  
+  $.extend(LiveHTMLBinding.prototype, LiveBinding.prototype);
+
+
   $(function() {
 
     var shinyapp = window.shinyapp = new ShinyApp();