Stream box values with updateBoxValue

DESCRIPTION

@@ -18,6 +18,7 @@ Imports:
     utils,
     shiny (>= 1.0.0),
     htmltools (>= 0.2.6),
-    promises
+    promises,
+    rlang
 BugReports: https://github.com/rstudio/shinydashboard
-RoxygenNote: 6.0.1.9000
+RoxygenNote: 6.1.1

NAMESPACE

@@ -26,8 +26,10 @@ export(tabBox)
 export(tabItem)
 export(tabItems)
 export(taskItem)
+export(updateBoxValue)
 export(updateTabItems)
 export(valueBox)
 export(valueBoxOutput)
 import(htmltools)
 import(promises)
+importFrom(rlang,list2)

R/boxes.R

@@ -11,20 +11,21 @@
 #' @param color A color for the box. Valid colors are listed in
 #'   \link{validColors}.
 #' @param href An optional URL to link to.
+#' @param id An optional id to uniquely identify the box
 #'
 #' @family boxes
 #' @seealso \code{\link{box}} for usage examples.
 #'
 #' @export
 valueBox <- function(value, subtitle, icon = NULL, color = "aqua", width = 4,
-  href = NULL)
+  href = NULL, id = NULL)
 {
   validateColor(color)
   if (!is.null(icon)) tagAssert(icon, type = "i")
 
-  boxContent <- div(class = paste0("small-box bg-", color),
+  boxContent <- div(id = id, class = paste0("small-box bg-", color),
     div(class = "inner",
-      h3(value),
+      h3(class = "value-box-value", value),
       p(subtitle)
     ),
     if (!is.null(icon)) div(class = "icon-large", icon)
@@ -39,6 +40,7 @@ valueBox <- function(value, subtitle, icon = NULL, color = "aqua", width = 4,
 }
 
 
+
 #' Create an info box for the main body of a dashboard.
 #'
 #' An info box displays a large icon on the left side, and a title, value
@@ -58,21 +60,23 @@ valueBox <- function(value, subtitle, icon = NULL, color = "aqua", width = 4,
 #'   content; the icon will use the same color with a slightly darkened
 #'   background.
 #' @param href An optional URL to link to.
+#' @param id An optional id to uniquely identify the box
 #'
 #' @family boxes
 #' @seealso \code{\link{box}} for usage examples.
 #'
 #' @export
 infoBox <- function(title, value = NULL, subtitle = NULL,
   icon = shiny::icon("bar-chart"), color = "aqua", width = 4, href = NULL,
-  fill = FALSE) {
+  fill = FALSE, id = NULL) {
 
   validateColor(color)
   tagAssert(icon, type = "i")
 
   colorClass <- paste0("bg-", color)
 
   boxContent <- div(
+    id = id,
     class = "info-box",
     class = if (fill) colorClass,
     span(
@@ -404,3 +408,32 @@ tabBox <- function(..., id = NULL, selected = NULL, title = NULL,
 
   div(class = paste0("col-sm-", width), content)
 }
+
+#' Update the value of an infoBox or valueBox
+#'
+#' This function allows you to update the value of
+#' an infoBox or valuebox without re-rendering the
+#' entire box. It is useful for streaming data or
+#' very regularly updating values
+#'
+#' @param session The session object that the infoBox
+#' or valueBox belongs to
+#' @param ... name=value pairs, where name is the id
+#' (unique identifier) of an infoBox or valueBox, and
+#' value is the value the box should display
+#'
+#' @family boxes
+#' @seealso \code{\link{infoBox}}, \code{\link{valueBox}}
+#'
+#' @export
+updateBoxValue <- function(session, ...) {
+  if (missing(session)) {
+    stop("Must provide a session, a name, and a value")
+  }
+
+  li <- rlang::list2(...)
+
+  session$sendCustomMessage("streamBox", li)
+
+  invisible()
+}

R/shinydashboard-package.r

@@ -2,5 +2,6 @@
 #'
 #' @name shinydashboard
 #' @import htmltools
+#' @importFrom rlang list2
 #' @docType package
 NULL

srcjs/message_handler.js

@@ -0,0 +1,19 @@
+
+
+Shiny.addCustomMessageHandler('streamBox', function(data) {
+    $.each(data, function(key, val){
+      // get element
+      el = document.getElementById(key);
+
+      // TODO: Error handling... what if el does not exist?
+
+      // update value
+      if (el.classList.contains("small-box")) {
+        // for valueBox
+        el.getElementsByClassName("value-box-value")[0].innerText = val;
+      } else if (el.classList.contains("info-box")) {
+        // for infoBox
+        el.getElementsByClassName("info-box-number")[0].innerText = val;
+      }
+    });
+  });

tests-manual/boxStream.R

@@ -0,0 +1,37 @@
+library(shiny)
+library(shinydashboard)
+
+ui <- dashboardPage(
+    dashboardHeader(),
+    dashboardSidebar(),
+    dashboardBody(
+        valueBoxOutput("value_box"),
+        infoBoxOutput("info_box"),
+        infoBox("Title", 45, "Subtitle", icon = icon("bar-chart"), id = "testbox"),
+        valueBox(id = "someid", 45, "Subtitle", icon = icon("dashboard"))
+    ),
+    title = "Test Streaming"
+)
+
+server <- function(input, output, session) {
+  value <- reactiveVal(45)
+  output$value_box <- renderValueBox({
+      valueBox(value(), "Subtitle", icon = icon("dashboard"))
+  })
+  output$info_box <- renderInfoBox({
+      infoBox("Title", value(), "Subtitle", icon = icon("bar-chart"))
+  })
+    observe({
+        invalidateLater(1000)
+        isolate(value(value() + 1))
+        print(paste("Updated value:", value()))
+        updateBoxValue(
+          session,
+          someid = value(),
+          testbox = value()
+        )
+    })
+}
+
+# Run the application
+shinyApp(ui = ui, server = server)

tools/Gruntfile.js

@@ -41,6 +41,7 @@ module.exports = function(grunt) {
           srcdirjs + 'input_binding_tabItem.js',
           srcdirjs + 'input_binding_sidebarCollapsed.js',
           srcdirjs + 'input_binding_sidebarmenuExpanded.js',
+          srcdirjs + 'message_handler.js',
           srcdirjs + '_end.js'
         ],
         dest: destdirjs + 'shinydashboard.js'