Provide support for hot reloading in Dash for R

.circleci/config.yml

@@ -34,10 +34,15 @@ jobs:
           command: |
             python -m venv venv
             . venv/bin/activate
-            git clone --depth 1 https://github.com/plotly/dash.git
-            cd dash && pip install -e .[testing] --quiet && cd ..
+            pip install -e git+https://github.com/plotly/dash.git#egg=dash[testing]
             export PATH=$PATH:/home/circleci/.local/bin/
-            pytest tests/integration/
+            pytest --log-cli-level DEBUG --junitxml=test-reports/dashr.xml tests/integration/
+      - store_artifacts:
+          path: test-reports
+      - store_test_results:
+          path: test-reports
+      - store_artifacts:
+          path: /tmp/dash_artifacts
 
       - run:
           name: 🔎 Unit tests

CHANGELOG.md

@@ -1,6 +1,24 @@
 # Change Log for Dash for R
 All notable changes to this project will be documented in this file.
 
+## Unreleased
+### Added
+- Hot reloading now supported in debug mode [#127](https://github.com/plotly/dashR/pull/127)
+- Support for displaying Dash for R applications within RStudio's viewer pane when `use_viewer = TRUE`
+- Clientside callbacks written in JavaScript are now supported [#130](https://github.com/plotly/dashR/pull/130)
+- Multiple outputs are now supported [#119](https://github.com/plotly/dashR/pull/119)
+- Selective callback updates to properties now supported with `dashNoUpdate()` [#111](https://github.com/plotly/dashR/pull/111)
+- Additional line number context inserted when available within stack traces [#133](https://github.com/plotly/dashR/pull/133)
+- Integration and unit tests are now performed when commits are made to open pull requests
+
+### Changed
+- Dash for R no longer requires forked `reqres`, patch applied upstream [#9](https://github.com/thomasp85/reqres/pull/9)
+- The `pruned_errors` parameter has been renamed to `dev_tools_prune_errors` [#113](https://github.com/plotly/dashR/pull/113)
+
+### Fixed
+- Patch for `reqres` package to handle cookies containing multiple "=" [#122](https://github.com/plotly/dashR/pull/122)
+- Handling for user-defined errors in callbacks implemented [#116](https://github.com/plotly/dashR/pull/116)
+
 ## [0.1.0] - 2019-07-10
 ### Added
 - Initial release

DESCRIPTION

@@ -37,6 +37,7 @@ Remotes: plotly/dash-html-components@17da1f4,
 License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
+KeepSource: true
 RoxygenNote: 6.1.1
 Roxygen: list(markdown = TRUE)
 URL: https://github.com/plotly/dashR

NAMESPACE

@@ -8,6 +8,7 @@ export(clientsideFunction)
 export(input)
 export(output)
 export(state)
+export(dashLogger)
 import(dashCoreComponents)
 import(dashHtmlComponents)
 importFrom(R6,R6Class)

R/utils.R

@@ -684,7 +684,7 @@ encode_plotly <- function(layout_objs) {
 # so that it is pretty printed to stderr()
 printCallStack <- function(call_stack, header=TRUE) {
   if (header) {
-    write(crayon::yellow$bold(" ### DashR Traceback (most recent/innermost call last) ###"), stderr())
+    write(crayon::yellow$bold(" ### Dash for R Traceback (most recent/innermost call last) ###"), stderr())
   }
   write(
     crayon::white(
@@ -694,7 +694,9 @@ printCallStack <- function(call_stack, header=TRUE) {
           call_stack
           ),
         ": ",
-        call_stack
+        call_stack,
+        " ",
+        lapply(call_stack, attr, "flineref")
         )
     ),
     stderr()
@@ -707,7 +709,7 @@ stackTraceToHTML <- function(call_stack,
   if(is.null(call_stack)) {
     return(NULL)
   }
-  header <- " ### DashR Traceback (most recent/innermost call last) ###"
+  header <- " ### Dash for R Traceback (most recent/innermost call last) ###"
 
   formattedStack <- c(paste0(
     "    ",
@@ -716,6 +718,8 @@ stackTraceToHTML <- function(call_stack,
     ),
     ": ",
     call_stack,
+    " ",
+    lapply(call_stack, attr, "lineref"),
     collapse="<br>"
   )
   )
@@ -761,7 +765,19 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) {
           }
 
           functionsAsList <- lapply(calls, function(completeCall) {
-            currentCall <- completeCall[[1]]
+            # avoid attempting to cast closures as strings, which will fail
+            # some calls in the stack are symbol (name) objects, while others
+            # are calls, which must be deparsed; the first element in the vector
+            # should be the function signature
+            if (is.name(completeCall[[1]]))
+              currentCall <- as.character(completeCall[[1]])
+            else if (is.call(completeCall[[1]]))
+              currentCall <- deparse(completeCall)[1]
+            else
+              currentCall <- completeCall[[1]]
+
+            attr(currentCall, "flineref") <- getLineWithError(completeCall, formatted=TRUE)
+            attr(currentCall, "lineref") <- getLineWithError(completeCall, formatted=FALSE)
 
             if (is.function(currentCall) & !is.primitive(currentCall)) {
               constructedCall <- paste0("<anonymous> function(",
@@ -813,18 +829,16 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) {
             functionsAsList <- removeHandlers(functionsAsList)
           }
 
-          # use deparse in case the call throwing the error is a symbol,
-          # since this cannot be "printed" without deparsing the call
           warning(call. = FALSE, immediate. = TRUE, sprintf("Execution error in %s: %s",
-                                                            deparse(functionsAsList[[length(functionsAsList)]]),
+                                                            functionsAsList[[length(functionsAsList)]],
                                                             conditionMessage(e)))
 
           stack_message <- stackTraceToHTML(functionsAsList,
-                                            deparse(functionsAsList[[length(functionsAsList)]]),
+                                            functionsAsList[[length(functionsAsList)]],
                                             conditionMessage(e))
 
           assign("stack_message", value=stack_message,
-                 envir=sys.frame(1)$private)
+                 envir=sys.frame(countEnclosingFrames("private"))$private)
 
           printCallStack(functionsAsList)
         }
@@ -836,8 +850,22 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) {
     )
     } else {
       evalq(expr)
-    }
   }
+}
+
+getLineWithError <- function(currentCall, formatted=TRUE) {
+  srcref <- attr(currentCall, "srcref", exact = TRUE)
+  if (!is.null(srcref) & !(getAppPath()==FALSE)) {
+    # filename
+    srcfile <- attr(srcref, "srcfile", exact = TRUE)
+    # line number
+    context <- sprintf("-- %s, Line %s", srcfile$filename, srcref[[1]])
+    if (formatted)
+      context <- crayon::yellow$italic(context)
+    return(context)
+  } else
+    ""
+}
 
 # This helper function drops error
 # handling functions from the call
@@ -920,6 +948,157 @@ getIdProps <- function(output) {
   return(list(ids=ids, props=props))
 }
 
+modtimeFromPath <- function(path, recursive = FALSE, asset_path="") {
+  # ensure path is properly formatted
+  path <- normalizePath(path)
+
+  if (is.null(path)) {
+    return(NULL)
+  }
+
+  if (recursive) {
+    if (asset_path != "") {
+      all_files <- file.info(list.files(path, recursive = TRUE))
+      # need to exclude files which are in assets directory so we don't always hard reload
+      initpath <- vapply(strsplit(rownames(all_files), split = .Platform$file.sep), `[`, FUN.VALUE=character(1), 1)
+      # now subset the modtimes, and identify the most recently modified file
+      modtime <- as.integer(max(all_files$mtime[which(initpath != asset_path)], na.rm = TRUE))
+    } else {
+      # now identify the most recently modified file
+      all_files <- list.files(path, recursive = TRUE, full.names = TRUE)
+      modtime <- as.integer(max(file.info(all_files)$mtime, na.rm=TRUE))
+    }
+  } else {
+    # check if the path is for a directory or file, and handle accordingly
+    if (dir.exists(path)) 
+      modtime <- as.integer(max(file.info(list.files(path, full.names = TRUE))$mtime, na.rm=TRUE))
+    else
+      modtime <- as.integer(file.info(path)$mtime)
+  }
+
+  return(modtime)
+}
+
+getAppPath <- function() {
+  # attempt to retrieve path for Dash apps served via
+  # Rscript or source()
+  cmd_args <- commandArgs(trailingOnly = FALSE)
+  file_argument <- "--file="
+  matched_arg <- grep(file_argument, cmd_args)
+
+  # if app is instantiated via Rscript, cmd_args should contain path
+  if (length(matched_arg) > 0) {
+    # Rscript
+    return(normalizePath(sub(file_argument, "", cmd_args[matched_arg])))
+  }
+  # if app is instantiated via source(), sys.frames should contain path
+  else if (!is.null(sys.frames()[[1]]$ofile)) {
+    return(normalizePath(sys.frames()[[1]]$ofile))
+  }
+  else {
+    return(FALSE)
+  }
+}
+
+# this function enables Dash to set file modification times
+# as attributes on the vectors stored within the asset map
+#
+# this permits storing additional information on the object
+# without dramatically modifying the existing API, and makes
+# it somewhat trivial to request the set of modification times
+setModtimeAsAttr <- function(path) {
+  if (!is.null(path)) {
+    mtime <- modtimeFromPath(path)
+    attributes(path)$modtime <- mtime
+    return(path)
+  } else {
+    return(NULL)
+  }
+}
+
+countEnclosingFrames <- function(object) {
+  for (i in 1:sys.nframe()) {
+    objs <- ls(envir=sys.frame(i))
+    if (object %in% objs)
+      return(i)
+  }
+}
+
+changedAssets <- function(before, after) {
+  # identify files that used to exist in the asset map,
+  # but which have been removed
+  deletedElements <-  before[which(is.na(match(before, after)))]
+
+  # identify files which were added since the last refresh
+  addedElements <-  after[which(is.na(match(after, before)))]
+
+  # identify any items that have been updated since the last
+  # refresh based on modification time attributes set in map
+  #
+  # in R, attributes are discarded when subsetting, so it's
+  # necessary to subset the attributes being compared instead.
+  # here we only compare objects which overlap
+  before_modtimes <-attributes(before)$modtime[before %in% after]
+  after_modtimes <- attributes(after)$modtime[after %in% before]
+
+  changedElements <- after[which(after_modtimes > before_modtimes)]
+
+  if (length(deletedElements) == 0) {
+    deletedElements <- NULL
+  }
+  if (length(changedElements) == 0) {
+    changedElements <- NULL
+  }
+  if (length(addedElements) == 0) {
+    addedElements <- NULL
+  }
+  invisible(return(
+    list(deleted = deletedElements,
+         changed = changedElements,
+         new = addedElements)
+  )
+  )
+}
+
+dashLogger <- function(event = NULL,
+                       message = NULL,
+                       request = NULL,
+                       time = Sys.time(),
+                       ...) {
+  orange <- crayon::make_style("orange")
+
+  # dashLogger is being called from within fiery, and the Fire() object generator
+  # is called from a private method within the Dash() R6 class; this makes
+  # accessing variables set within Dash's private fields somewhat complicated
+  #
+  # the following line retrieves the value of the silence_route_logging parameter,
+  # which is nearly 20 frames up the stack; if it's not found, we'll assume FALSE
+  silence_routes_logging <- dynGet("self", ifnotfound = FALSE)$config$silence_routes_logging
+
+  if (!is.null(event)) {
+    msg <- sprintf("%s: %s", event, message)
+
+    msg <- switch(event, error = crayon::red(msg), warning = crayon::yellow(msg),
+                  message = crayon::blue(msg), msg)
+
+    # assign the status group for color coding
+    if (event == "request") {
+      status_group <- as.integer(cut(request$respond()$status,
+                                     breaks = c(100, 200, 300, 400, 500, 600), right = FALSE))
+
+      msg <- switch(status_group, crayon::blue$bold(msg), crayon::green$bold(msg),
+                    crayon::cyan$bold(msg), orange$bold(msg), crayon::red$bold(msg))
+    }
+
+    # if log messages are suppressed, report only server stop/start messages, errors, and warnings
+    # otherwise, print everything to console
+    if (event %in% c("start", "stop", "error", "warning") || !(silence_routes_logging)) {
+      cat(msg, file = stdout(), append = TRUE)
+      cat("\n", file = stdout(), append = TRUE)
+    }
+  }
+}
+
 clientsideFunction <- function(namespace, function_name) {
   return(list(namespace=namespace, function_name=function_name))
 }

tests/integration/devtools/assets/hot_reload.css

@@ -0,0 +1,3 @@
+#hot-reload-content {
+    background-color: blue; 
+}

tests/integration/devtools/hard_reload/app.R

@@ -0,0 +1,26 @@
+
+library(dash)
+library(dashHtmlComponents)
+library(dashCoreComponents)
+app <- Dash$new()
+
+app$layout(htmlDiv(list(
+htmlH3("Test hard reloading (when modifying any non-CSS resources)"),
+dccInput(id='input'),
+htmlDiv(id='output-serverside')
+),
+id="hot-reload-content"
+)
+)
+
+app$callback(
+  output(id = "output-serverside", property = "children"),
+  params = list(
+    input(id = "input", property = "value")
+  ),
+  function(value) {
+    sprintf("Pre-reloading test output should be %s", value)
+  }
+)
+
+app$run_server(dev_tools_hot_reload=TRUE, dev_tools_hot_reload_interval=0.1, dev_tools_silence_routes_logging=TRUE)