Simplified callback syntax and addtional utility functions (#270)

* Tag updates

* Added RStudio dash snippet

* Added simple_table

* Added flexible callbacks

* Documentation and NAMESPACE updates

* Updated DESCRIPTION

* Adding unittests

* Adding context tags to tests

* Updated CHANGELOG

CHANGELOG.md

@@ -4,7 +4,9 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ## [1.0.0] - UNRELEASED
 ### Added
-- Dash wrapper functions are included, which simplify the layout syntax for writing Dash apps. This includes the ability to pipe in the `app` object to layout and meta functions, as well as tags which simplify `html` component arguments and children. [#265](https://github.com/plotly/dashR/pull/265)
+- Dash layout wrapper functions are included, which simplify the layout syntax for writing Dash apps. This includes the ability to pipe in the `app` object to layout and meta functions, as well as tags which simplify `html` component arguments and children. [#265](https://github.com/plotly/dashR/pull/265)
+
+- Added simplified and flexible callbacks with the `add_callback` helper function. Included in this change are multiple additional helper functions to simplify Dash app configuration and tag usage. [#270](https://github.com/plotly/dashR/pull/270)
 
 ### Changed
 - Unified the core Dash packages (dash, dashCoreComponents, dashHtmlComponents, dashTable) for streamlined maintenance and accessibility. The namespaces of these packages will be combined under the `dash` namespace, and all artifacts from the ancillary dash packages will be included with Dash for R. [#243](https://github.com/plotly/dashr/pull/243)

DESCRIPTION

@@ -20,7 +20,10 @@ Imports:
   crayon,
   brotli,
   glue,
-  magrittr
+  magrittr,
+  methods,
+  rlang,
+  utils
 Suggests:
   testthat
 License: MIT + file LICENSE

NAMESPACE

@@ -1,16 +1,20 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(print,Dash)
 S3method(print,dash_component)
 export("%>%")
 export(ALL)
 export(ALLSMALLER)
 export(Dash)
 export(MATCH)
+export(a)
+export(add_callback)
 export(add_meta)
 export(add_script)
 export(add_stylesheet)
 export(br)
 export(button)
+export(callback_context)
 export(clientsideFunction)
 export(dashNoUpdate)
 export(dash_app)
@@ -21,11 +25,15 @@ export(h2)
 export(h3)
 export(h4)
 export(html)
+export(img)
 export(input)
+export(install_snippet)
 export(output)
 export(p)
+export(prevent_update)
 export(run_app)
 export(set_layout)
+export(simple_table)
 export(span)
 export(state)
 export(strong)

R/callbacks-advanced.R

@@ -0,0 +1,190 @@
+#' Add a callback to a Dash app
+#'
+#' @param app A dash application created with [`dash_app()`].
+#' @export
+add_callback <- function(app, outputs, params, callback) {
+  if (inherits(params, "dash_dependency")) {
+    params <- list(params)
+  }
+
+  params_flat <- flatten(params)
+
+  # determine if the callback arguments match the first level of parameters
+  cb_args <- methods::formalArgs(callback)
+  if (length(cb_args) != length(params)) {
+    stop("add_callback: Number of params does not match the number of arguments in the callback function", call. = FALSE)
+  }
+  if (!is.null(names(params))) {
+    if (!setequal(cb_args, names(params))) {
+      stop("add_callback: Arguments in callback do not match the names of the params",
+           call. = FALSE)
+    }
+  }
+
+  cb <- function(...) {
+    callback_params <- eval(substitute(alist(...)))
+
+    # the callback moves states to the end after inputs, so we need to fix the positions
+    state_idx <- which(unlist(lapply(params_flat, function(x) inherits(x, "state"))))
+    num_states <- length(state_idx)
+    if (num_states > 0) {
+      num_inputs <- length(callback_params) - num_states
+      for (i in seq_len(num_states)) {
+        idx <- num_inputs + i
+        callback_params <- append(callback_params, callback_params[[idx]], state_idx[i] - 1)
+        callback_params <- callback_params[-(idx + 1)]
+      }
+    }
+
+    callback_params <- params_to_keys(callback_params, params)
+    do.call(callback, callback_params)
+  }
+
+  app$callback(
+    output = outputs,
+    params = params_flat,
+    func = cb
+  )
+  invisible(app)
+}
+
+# test <- list(
+#   ab = list(
+#     input("a", "value"),
+#     state("b", "value")
+#   ),
+#   cdef = list(
+#     cde = list(
+#       input("c", "value"),
+#       state("d", "value"),
+#       input("e", "value")
+#     ),
+#     f = input("f", "value")
+#   ),
+#   g = input("g", "value")
+# )
+# str(flatten(test))
+flatten <- function(x) {
+  if (!inherits(x, "list")) return(list(x))
+
+  key_names <- rlang::names2(x)
+  key_names_exist <- nzchar(key_names)
+  if (all(key_names_exist)) {
+    if (any(duplicated(key_names))) {
+      stop("Named params must have unique names", call. = FALSE)
+    }
+    x <- unname(x)
+  } else if (any(key_names_exist)) {
+    stop("Cannot mix named and unnamed params", call. = FALSE)
+  }
+
+  unlist(lapply(x, flatten), recursive = FALSE)
+}
+
+# test <- list(
+#   ab = list(
+#     input("a", "value"),
+#     state("b", "value")
+#   ),
+#   cdef = list(
+#     cde = list(
+#       input("c", "value"),
+#       state("d", "value"),
+#       input("e", "value")
+#     ),
+#     f = input("f", "value")
+#   ),
+#   g = input("g", "value")
+# )
+# str(params_to_keys(as.list(LETTERS[1:7]), test))
+params_to_keys <- function(params, keys) {
+  params_to_key_helper <- function(keys) {
+    for (item_idx in seq_along(keys)) {
+      if (inherits(keys[[item_idx]], "dash_dependency")) {
+        keys[[item_idx]] <- params[[1]]
+        params <<- params[-1]
+      } else {
+        keys[[item_idx]] <- params_to_key_helper(keys[[item_idx]])
+      }
+    }
+    keys
+  }
+  params_to_key_helper(keys)
+}
+
+#' In addition to event properties like n_clicks that change whenever an event
+#' happens there is a global variable dash$callback_context, available only
+#' inside a callback. It has properties:
+#'
+#' `triggered`: list of changed properties. This will be empty on initial load,
+#' unless an input prop got its value from another initial callback. After a user
+#' action it is a length-1 list, unless two properties of a single component
+#' update simultaneously, such as a value and a timestamp or event counter.
+#'
+#' `inputs` and `states`: allow you to access the callback params by id and prop
+#' instead of through the function arguments.
+#'
+#' @examples
+#' dash_app() %>%
+#'   set_layout(
+#'     button('Button 1', id='btn1'),
+#'     button('Button 2', id='btn2'),
+#'     button('Button 3', id='btn3'),
+#'     div(id='container')
+#'   ) %>%
+#'   add_callback(
+#'     output("container", "children"),
+#'     list(
+#'       input("btn1", "n_clicks"),
+#'       input("btn2", "n_clicks"),
+#'       input("btn3", "n_clicks")
+#'     ),
+#'     function(btn1, btn2, btn3) {
+#'       ctx <- callback_context()
+#'       prevent_update(is.null(ctx))
+#'       sprintf("Triggered: %s, btn1: %s, btn2: %s, btn3: %s",
+#'               ctx$triggered$prop_id, btn1, btn2, btn3)
+#'     }
+#'   ) %>%
+#'   run_app()
+#' @export
+callback_context <- function() {
+  get("app", envir = parent.frame(2))$callback_context()
+}
+
+#' Prevent a callback from updating its output
+#'
+#' When used inside Dash callbacks, if any of the arguments evaluate to `TRUE`,
+#' then the callback's outputs do not update.
+#'
+#' @param ... Values to check
+#' @examples
+#' app <- dash_app()
+#'
+#' app %>% set_layout(
+#'   button('Click here', id = 'btn'),
+#'   p('The number of times the button was clicked does not update when the number is divisible by 5'),
+#'   div(id = 'body-div')
+#' )
+#' app %>% add_callback(
+#'   output(id='body-div', property='children'),
+#'   list(
+#'     input(id='btn', property='n_clicks')
+#'   ),
+#'   function(n_clicks) {
+#'     prevent_update(is.null(n_clicks[[1]]), n_clicks[[1]] %% 5 == 0)
+#'     paste(n_clicks[[1]], "clicks")
+#'   }
+#' )
+#'
+#' app %>% run_app()
+#'
+#' @export
+prevent_update <- function(...) {
+  checks <- unlist(list(...))
+  if (any(checks)) {
+    rlang::eval_bare(rlang::expr(invisible(return(structure(list(NULL), class = "no_update")))) , env = parent.frame())
+  } else {
+    return()
+  }
+}

R/install_snippet.R

@@ -0,0 +1,146 @@
+#' Install Dash RStudio snippet
+#'
+#' Install the Dash code snippet for RStudio, for quickly creating a new Dash
+#' app.
+#'
+#' @return boolean Whether or not the snippet was installed
+#' @export
+install_snippet <- function() {
+  # Modified code from https://stackoverflow.com/a/62223103/3943160 (user 'dario')
+
+  added <- FALSE
+
+  # if not on RStudio or RStudioServer exit
+  if (!nzchar(Sys.getenv("RSTUDIO_USER_IDENTITY"))) {
+    return(NULL)
+  }
+
+  # Name of files containing snippet code to copy
+  #
+  pckgSnippetsFiles <- "snippet.txt"
+
+  # Name of files to copy into. Order has to be the same
+  # as in 'pckgSnippetsFiles'
+  #
+  rstudioSnippetsFiles <- "r.snippets"
+
+  # Path to directory for RStudios user files depends on OS
+  #
+  if (rstudioapi::getVersion() < "1.3") {
+    rstudioSnippetsPathBase <- file.path(path.expand('~'),".R", "snippets")
+  } else {
+    if (.Platform$OS.type == "windows") {
+      rstudioSnippetsPathBase <- file.path(Sys.getenv("APPDATA"), "RStudio", "snippets")
+    } else {
+      rstudioSnippetsPathBase <- file.path(path.expand('~'), ".config/rstudio", "snippets")
+    }
+  }
+
+  # Read each file in pckgSnippetsFiles and add its contents
+  #
+  for (i in seq_along(pckgSnippetsFiles)) {
+
+    # Try to get template, if template is not found skip it
+    #
+    pckgSnippetsFilesPath <- system.file("rstudio", pckgSnippetsFiles[i], package = "dash")
+    if (pckgSnippetsFilesPath == "") {
+      next()
+    }
+
+    # load package snippets definitions
+    #
+    pckgSnippetsFileContent <- readLines(pckgSnippetsFilesPath, warn = FALSE)
+
+    # Extract names of package snippets
+    #
+    pckgSnippetsFileDefinitions <- pckgSnippetsFileContent[grepl("^snippet (.*)", pckgSnippetsFileContent)]
+
+
+    # Construct path for destination file
+    #
+    rstudioSnippetsFilePath <- file.path(rstudioSnippetsPathBase, rstudioSnippetsFiles[i])
+
+    # If targeted RStudios user file does not exist, raise error (otherwise we would 'remove')
+    # the default snippets from the 'user file'
+    #
+    if (!file.exists(rstudioSnippetsFilePath)) {
+      stop(paste0( "'", rstudioSnippetsFilePath, "' does not exist yet\n.",
+                   "Use RStudio -> Tools -> Global Options -> Code -> Edit Snippets\n",
+                   "To initalize user defined snippets file by adding dummy snippet\n"))
+    }
+
+    # Extract 'names' of already existing snitppets
+    #
+    rstudioSnippetsFileContent <- readLines(rstudioSnippetsFilePath, warn = FALSE)
+    rstudioSnippetDefinitions <- rstudioSnippetsFileContent[grepl("^snippet (.*)", rstudioSnippetsFileContent)]
+
+    # replace two spaces with tab, ONLY at beginning of string
+    #
+    pckgSnippetsFileContentSanitized <- gsub("(?:^ {2})|\\G {2}|\\G\t", "\t", pckgSnippetsFileContent, perl = TRUE)
+
+    # find defintions appearing in packageSnippets but not in rstudioSnippets
+    # if no snippets are missing go to next file
+    #
+    snippetsToCopy <- setdiff(trimws(pckgSnippetsFileDefinitions), trimws(rstudioSnippetDefinitions))
+    snippetsNotToCopy <- intersect(trimws(pckgSnippetsFileDefinitions), trimws(rstudioSnippetDefinitions))
+    if (length(snippetsToCopy) == 0) {
+      # cat(paste0("(\nFollowing snippets will NOT be added because there is already a snippet with that name: ",
+      #            paste0(snippetsNotToCopy, collapse=", ") ,")"))
+      next()
+    }
+
+    # Inform user about changes, ask to confirm action
+    #
+    if (interactive()) {
+      cat(paste0("You are about to add the following ", length(snippetsToCopy),
+                 " snippets to '", rstudioSnippetsFilePath, "':\n",
+                 paste0(paste0("-", snippetsToCopy), collapse="\n")))
+      if (length(snippetsNotToCopy) > 0) {
+        cat(paste0("\n(The following snippets will NOT be added because there is already a snippet with that name:\n",
+                   paste0(snippetsNotToCopy, collapse=", ") ,")"))
+      }
+      answer <- readline(prompt="Do you want to proceed (y/n): ")
+      if (substr(answer, 1, 1) == "n") {
+        next()
+      }
+    }
+
+    # Create list of line numbers where snippet definitons start
+    # This list is used to determine the end of each definition block
+    #
+    allPckgSnippetDefinitonStarts <- grep("^snippet .*", pckgSnippetsFileContentSanitized)
+
+    for (s in snippetsToCopy) {
+      startLine <- grep(paste0("^", s, ".*"), pckgSnippetsFileContentSanitized)
+
+      # Find last line of snippet definition:
+      # First find start of next defintion and return
+      # previous line number or lastline if already in last definiton
+      #
+      endLine <- allPckgSnippetDefinitonStarts[allPckgSnippetDefinitonStarts > startLine][1] -1
+      if (is.na(endLine)) {
+        endLine <- length(pckgSnippetsFileContentSanitized)
+      }
+
+      snippetText <- paste0(pckgSnippetsFileContentSanitized[startLine:endLine], collapse = "\n")
+
+      # Make sure there is at least one empty line between entries
+      #
+      if (tail(readLines(rstudioSnippetsFilePath, warn = FALSE), n=1) != "") {
+        snippetText <- paste0("\n", snippetText)
+      }
+
+      # Append snippet block, print message
+      #
+      cat(paste0(snippetText, "\n"), file = rstudioSnippetsFilePath, append = TRUE)
+      cat(paste0("* Added '", s, "' to '", rstudioSnippetsFilePath, "'\n"))
+      added <- TRUE
+    }
+  }
+
+  if (added) {
+    cat("Restart RStudio to use new snippets")
+  }
+
+  invisible(added)
+}