Merge pull request #418 from BristolMyersSquibb/407-345-improve-submit

first pass at redesigning submit

.vscode/settings.json

@@ -0,0 +1,3 @@
+{
+    "makefile.configureOnOpen": false
+}

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: blockr
 Title: A block-based framework for data manipulation and visualization
-Version: 0.0.2.9010
+Version: 0.0.2.9020
 Authors@R: 
     c(person(given = "Nicolas",
              family = "Bennett",

NEWS.md

@@ -1,6 +1,31 @@
-# blockr 0.0.2.9000
+# blockr 0.0.2.9020
 
 ## Feature
+- Improved `submit` feature for blocks. Now submit isn't added as a class but as a special block attribute. When you design a block, you can pass the `submit` parameter like so:
+
+```r
+new_super_block <- function(submit = NA, ...) {
+  fields <- list()
+  new_block(
+    fields = fields,
+    expr = quote(print("test")),
+    submit = submit,
+    ...,
+    class = "my_block"
+  )
+}
+```
+
+When `submit = NA`, it will add a submit button but computations are blocked, as clicking on it is required. Internally, once the `input$submit` is clicked, the submit attribute is set to `TRUE`. This is useful when the stack is serialized, since this state is kept so that computations can be automatically re-triggered on restore. When `submit = TRUE`, a button is shown and the result is also computed. When `submit = FALSE`, no button is shown.
+
+```r
+# You can disable the submit button for filter block
+serve_stack(new_stack(new_dataset_block(), new_filter_block(columns = "Time", submit = FALSE)))
+serve_stack(new_stack(new_dataset_block(), new_filter_block(columns = "Time", submit = NA)))
+# Simulate what happens when restoring a serialised stack
+serve_stack(new_stack(new_dataset_block(), new_filter_block(columns = "Time", submit = TRUE)))
+```
+
 - Improved __add__ new block.
 - Added new `category` to the registry. Now when a block is registered, you may pass a category parameter (which is used by the add block feature to sort blocks):
 

R/block-core.R

@@ -9,13 +9,19 @@
 #' @param expr A quoted expression (compatible with partial substitution as
 #' implemented in [base::bquote()] and intended for evaluation in the context
 #' of the fields)
+#' @param submit Whether this block requires to press a submit button to get
+#' the results. Boolean, default to FALSE, which means no submit button.
+#' If NA, then no computation is triggered and the user needs to click on the button
+#' to see the block result. If TRUE, computation is automatically triggered and the button
+#' is shown (which is useful when restoring a stack).
 #' @param ... Further (metadata) attributes
 #' @param class Block subclass
 #'
 #' @export
 #' @import dplyr
 #' @importFrom stats setNames
-new_block <- function(fields, expr, name = rand_names(), ...,
+new_block <- function(fields, expr, name = rand_names(),
+                      submit = FALSE, ...,
                       class = character()) {
   stopifnot(
     is.list(fields),
@@ -24,16 +30,14 @@ new_block <- function(fields, expr, name = rand_names(), ...,
     is_string(name)
   )
 
-  # Add submit button
-  if ("submit_block" %in% class) {
-    fields <- c(
-      fields,
-      submit = list(new_submit_field())
-    )
+  if (is.na(submit)) {
+    submit <- 0
+  } else {
+    submit <- if (submit) 1 else -1
   }
 
   structure(fields,
-    name = name, expr = expr, result = NULL, ...,
+    name = name, expr = expr, result = NULL, submit = submit, ...,
     class = c(class, "block")
   )
 }

R/blocks.R

@@ -190,7 +190,7 @@ new_result_block <- function(...) {
 #' @param filter_fun Filter function for the expression
 #' @export
 new_filter_block <- function(columns = character(), values = character(),
-                             filter_fun = "==", ...) {
+                             filter_fun = "==", submit = NA, ...) {
   sub_fields <- function(data, columns) {
     determine_field <- function(x) {
       switch(class(x),
@@ -274,8 +274,9 @@ new_filter_block <- function(columns = character(), values = character(),
   new_block(
     fields = fields,
     expr = expr,
+    submit = submit,
     ...,
-    class = c("filter_block", "transform_block", "submit_block")
+    class = c("filter_block", "transform_block")
   )
 }
 
@@ -322,7 +323,7 @@ new_select_block <- function(columns = character(), ...) {
 #' as func.
 #' @export
 new_summarize_block <- function(func = character(),
-                                default_columns = character(), ...) {
+                                default_columns = character(), submit = NA, ...) {
   if (length(default_columns) > 0) {
     stopifnot(length(func) == length(default_columns))
   }
@@ -422,8 +423,9 @@ new_summarize_block <- function(func = character(),
   new_block(
     fields = fields,
     expr = quote(.(expression)),
+    submit = submit,
     ...,
-    class = c("summarize_block", "transform_block", "submit_block")
+    class = c("summarize_block", "transform_block")
   )
 }
 
@@ -495,7 +497,7 @@ new_group_by_block <- function(columns = character(), ...) {
 #'
 #' @export
 new_join_block <- function(y = NULL, type = character(), by = character(),
-                           ...) {
+                           submit = NA, ...) {
   by_choices <- function(data, y) {
     intersect(colnames(data), colnames(y))
   }
@@ -522,8 +524,9 @@ new_join_block <- function(y = NULL, type = character(), by = character(),
   new_block(
     fields = fields,
     expr = quote(.(join_func)(y = .(y), by = .(by))),
+    submit = submit,
     ...,
-    class = c("join_block", "transform_block", "submit_block")
+    class = c("join_block", "transform_block")
   )
 }
 

R/server.R

@@ -190,15 +190,29 @@ generate_server_block <- function(
       # join that can have computationally intense tasks
       # and have nested fields, we require to click on
       # the action button before doing anything.
-      out_dat <- if ("submit_block" %in% class(x)) {
+      if (attr(x, "submit") > -1) {
+        # Increment submit attribute for serialization
+        # So that if a block is serialised with submit = TRUE
+        # computations are automatically triggered on restore
+        # Only do it once.
+        observeEvent(input$submit, {
+          tmp <- blk()
+          attr(tmp, "submit") <- TRUE
+          blk(tmp)
+        }, once = TRUE)
+      }
+
+      out_dat <- if (attr(x, "submit") > -1) {
         eventReactive(input$submit, {
           req(is_valid$block)
           if (is.null(in_dat())) {
             evaluate_block(blk())
           } else {
             evaluate_block(blk(), data = in_dat())
           }
-        })
+          # Trigger computation if submit attr is > 0
+          # useful when restoring workspace
+        }, ignoreNULL = !attr(x, "submit") > 0)
       } else {
         reactive({
           req(is_valid$block)

R/ui.R

@@ -145,6 +145,18 @@ block_header <- function(x, ...) {
 block_header.block <- function(x, ns, hidden_class, ...) {
   title <- get_block_title(x)
 
+  submit_ui <- NULL
+  if (attr(x, "submit") > -1) {
+    submit_ui <- div(class = "flex-grow-1",
+      bslib::input_task_button(
+        ns("submit"),
+        "Run",
+        icon = iconPlay(),
+        class = "btn-sm btn-success"
+      )
+    )
+  }
+
   div(
     class = sprintf("m-0 card-title block-title %s", hidden_class),
     div(
@@ -157,10 +169,9 @@ block_header.block <- function(x, ns, hidden_class, ...) {
           class = "fw-bold m-0"
         )
       ),
+      submit_ui,
       data_info(x, ns),
-      div(
-        class = "block-tools flex-shrink-1"
-      )
+      div(class = "block-tools flex-shrink-1")
     )
   )
 }
@@ -331,7 +342,6 @@ add_block_ui.default <- function(x, id, ...) {
         tags$head(
           tags$script(HTML("
             function colorText(data) {
-              console.log(data);
               let text = `<span class='badge text-bg-secondary'>${data.label}</span>`;
               return text;
             }"
@@ -964,6 +974,10 @@ iconTrash <- function() {
   icon("trash")
 }
 
+iconPlay <- function() {
+  icon("play")
+}
+
 #' Block icon generic
 #'
 #' Create a block icon depending in the block class

R/utils.R

@@ -259,8 +259,7 @@ send_error_to_ui <- function(blk, is_valid, session) {
   )
 
   # Toggle submit field
-  # FIXME: maybe we want to handle this outside the function?
-  if ("submit_block" %in% class(blk)) {
+  if (!is.null(attr(blk, "submit"))) {
     session$sendCustomMessage(
       "toggle-submit",
       list(state = is_valid$block, id = ns("submit"))
@@ -281,7 +280,7 @@ send_error_to_ui <- function(blk, is_valid, session) {
   )
 
   # Send validation message
-  if (!is_valid$block) {
+  if (!is_valid$block && length(is_valid$message)) {
     insertUI(
       selector = sprintf("[data-value=\"%s\"] .block-validation", ns("block")),
       ui = div(

_pkgdown.yml

@@ -206,5 +206,6 @@ reference:
 
 news:
  releases:
+ - text: "blockr 0.0.2.9020"
  - text: "blockr 0.0.2"
  - text: "blockr 0.0.1.9000"

inst/examples/restore-workspace/app.R

@@ -2,12 +2,14 @@ library(blockr)
 
 set_workspace(
   stack_1 = new_stack(
+    # Won't autoclick on submit
     block_11 = new_dataset_block("anscombe"),
-    block_12 = new_select_block(c("x1", "y1"))
+    block_12 = new_filter_block("x1", 10, ">")
   ),
+  # Submit autoclick
   stack_2 = new_stack(
     block_21 = new_dataset_block("anscombe"),
-    block_22 = new_select_block(c("x2", "y2"))
+    block_22 = new_filter_block("x1", 10, ">", submit = TRUE)
   )
 )
 

srcjs/shiny.js

@@ -27,5 +27,7 @@ window.Shiny.addCustomMessageHandler("validate-block", (_msg) => {});
 window.Shiny.addCustomMessageHandler("validate-input", (_msg) => {});
 
 window.Shiny.addCustomMessageHandler("toggle-submit", (msg) => {
-  $(`#${msg.id}`).prop("disabled", !msg.state);
+  $(`#${msg.id}`)
+    .toggleClass("disabled", !msg.state)
+    .attr("aria-disabled", !msg.state)
 });