Merge pull request #424 from BristolMyersSquibb/423-addblock-hotfix

Add block for dynamically added stack

DESCRIPTION

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

NEWS.md

@@ -1,4 +1,4 @@
-# blockr 0.0.2.9021
+# blockr 0.0.2.9022
 
 ## 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/server.R

@@ -83,12 +83,11 @@ update_ui <- function(b, is_srv, session, l_init) {
 }
 
 generate_server_block <- function(
-  x,
-  in_dat = NULL,
-  id,
-  display = c("table", "plot"),
-  is_prev_valid
-) {
+    x,
+    in_dat = NULL,
+    id,
+    display = c("table", "plot"),
+    is_prev_valid) {
   display <- match.arg(display)
 
   # if in_dat is NULL (data block), turn it into a reactive expression that
@@ -157,28 +156,31 @@ generate_server_block <- function(
 
       # This will also trigger when the previous block
       # valid status changes.
-      obs$update_blk <- observeEvent(c(r_values(), in_dat(), is_prev_valid()), {
-        # 1. upd blk,
-        b <- update_blk(
-          b = blk(),
-          value = r_values(),
-          is_srv = is_srv,
-          input = input,
-          data = in_dat()
-        )
-        blk(b)
-        log_debug("Updating block ", class(x)[[1]])
-
-        # 2. Update UI
-        update_ui(b = blk(), is_srv = is_srv, session = session, l_init = l_init)
-        log_debug("Updating UI of block ", class(x)[[1]])
-
-        # Validating
-        is_valid$block <- validate_block(blk())
-        is_valid$message <- attr(is_valid$block, "msg")
-        is_valid$fields <- attr(is_valid$block, "fields")
-        log_debug("Validating block ", class(x)[[1]])
-      }, priority = 1000)
+      obs$update_blk <- observeEvent(c(r_values(), in_dat(), is_prev_valid()),
+        {
+          # 1. upd blk,
+          b <- update_blk(
+            b = blk(),
+            value = r_values(),
+            is_srv = is_srv,
+            input = input,
+            data = in_dat()
+          )
+          blk(b)
+          log_debug("Updating block ", class(x)[[1]])
+
+          # 2. Update UI
+          update_ui(b = blk(), is_srv = is_srv, session = session, l_init = l_init)
+          log_debug("Updating UI of block ", class(x)[[1]])
+
+          # Validating
+          is_valid$block <- validate_block(blk())
+          is_valid$message <- attr(is_valid$block, "msg")
+          is_valid$fields <- attr(is_valid$block, "fields")
+          log_debug("Validating block ", class(x)[[1]])
+        },
+        priority = 1000
+      )
 
       # Propagate message to user
       obs$surface_error <- observe({
@@ -195,24 +197,30 @@ generate_server_block <- function(
         # 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)
+        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)
+        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)
@@ -499,46 +507,48 @@ add_block_server <- function(x, ...) {
 #' @export
 add_block_server.default <- function(x, id, vals, ...) {
   moduleServer(id, function(input, output, session) {
-
     ns <- session$ns
 
     # Triggers on init
     blk_choices <- reactiveVal(NULL)
-    observeEvent(vals$blocks, {
-      # Pills are dynamically updated from the server
-      # depending on the block compatibility
-      blk_choices(get_compatible_blocks(vals$stack))
-
-      choices <- blk_choices()
-      choices$name <- paste(choices$package, sep = "::", choices$ctor)
-
-      shinyWidgets::updateVirtualSelect(
-        "search",
-        choices = shinyWidgets::prepare_choices(
-          choices,
-          .data$name,
-          .data$ctor,
-          group_by = .data$category,
-          description = .data$description
-        )
-      )
-
-      #create_block_choices(blk_choices(), ns)
-
-      if (length(vals$blocks) == 0) {
-        shiny::insertUI(
-          sprintf("#%s", ns("status-messages")),
-          ui = div(
-            class = "alert alert-primary",
-            role = "alert",
-            id = ns("status-message"),
-            "Stack has no blocks. Start by adding a data block."
+    observeEvent(
+      {
+        req(input$add > 0)
+        c(input$add, vals$blocks)
+      },
+      {
+        # Pills are dynamically updated from the server
+        # depending on the block compatibility
+        blk_choices(get_compatible_blocks(vals$stack))
+
+        choices <- blk_choices()
+        choices$name <- paste(choices$package, sep = "::", choices$ctor)
+
+        shinyWidgets::updateVirtualSelect(
+          "search",
+          choices = shinyWidgets::prepare_choices(
+            choices,
+            .data$name,
+            .data$ctor,
+            group_by = .data$category,
+            description = .data$description
           )
         )
-      } else {
+
         removeUI(sprintf("#%s", ns("status-message")))
+        if (length(vals$blocks) == 0) {
+          shiny::insertUI(
+            sprintf("#%s", ns("status-messages")),
+            ui = div(
+              class = "alert alert-primary",
+              role = "alert",
+              id = ns("status-message"),
+              "Stack has no blocks. Start by adding a data block."
+            )
+          )
+        }
       }
-    })
+    )
 
     return(
       list(
@@ -927,8 +937,8 @@ add_block_stack <- function(
   session$sendCustomMessage(
     "blockr-add-block",
     list(
-      stack =  ns(NULL),
-      block =  ns(attr(vals$stack[[p]], "name"))
+      stack = ns(NULL),
+      block = ns(attr(vals$stack[[p]], "name"))
     )
   )
 }

R/ui.R

@@ -147,7 +147,8 @@ block_header.block <- function(x, ns, hidden_class, ...) {
 
   submit_ui <- NULL
   if (attr(x, "submit") > -1) {
-    submit_ui <- div(class = "flex-grow-1",
+    submit_ui <- div(
+      class = "flex-grow-1",
       bslib::input_task_button(
         ns("submit"),
         "Run",
@@ -303,7 +304,8 @@ add_block_ui.default <- function(x, id, ...) {
   tagList(
     tags$a(
       icon("plus"),
-      class = "stack-add-block text-decoration-none",
+      id = ns("add"),
+      class = "stack-add-block text-decoration-none action-button",
       `data-bs-toggle` = "offcanvas",
       `data-bs-target` = sprintf("#%s", ns("addBlockCanvas")),
       `aria-controls` = ns("addBlockCanvas")
@@ -317,15 +319,18 @@ add_block_ui.default <- function(x, id, ...) {
         # Hide the select dropdown as we just need the searchbar
         tags$script(
           HTML(
-            sprintf("
-              $(document).one('shiny:inputchanged', function(e) {
-                if (e.name === 'my_stack-rendered') {
-                  $('#%s')
-                    .find('.vscomp-toggle-button')
-                    .css('display', 'none');
+            sprintf(
+              "$(document).on('shiny:inputchanged', function(e) {
+                if (e.name === '%s') {
+                  $('#%s').one('shown.bs.offcanvas', function() {
+                    $('#%s')
+                      .find('.vscomp-toggle-button')
+                      .css('display', 'none');
+                  });
                 }
-              });
-              ",
+              })",
+              ns("add"),
+              ns("addBlockCanvas"),
               ns("search")
             )
           )
@@ -339,13 +344,13 @@ add_block_ui.default <- function(x, id, ...) {
           }
           "
         ),
-        tags$head(
-          tags$script(HTML("
-            function colorText(data) {
+        tags$script(
+          HTML(
+            "function colorText(data) {
               let text = `<span class='badge text-bg-secondary'>${data.label}</span>`;
               return text;
             }"
-          ))
+          )
         )
       ),
       shinyWidgets::virtualSelectInput(
@@ -360,7 +365,7 @@ add_block_ui.default <- function(x, id, ...) {
         optionsCount = 10,
         keepAlwaysOpen = TRUE,
         searchGroup = TRUE,
-        #searchByStartsWith = TRUE,
+        # searchByStartsWith = TRUE,
         hasOptionDescription = TRUE,
         width = "100%",
         labelRenderer = "colorText"
@@ -726,7 +731,6 @@ input_ids.hidden_field <- function(x, name, ...) {
 #' @rdname ui_input
 #' @export
 ui_input.variable_field <- function(x, id, name) {
-
   field <- materialize_variable_field(x)
 
   div(
@@ -752,7 +756,6 @@ ui_input.hidden_field <- function(x, id, name) {
 #' @rdname ui_input
 #' @export
 ui_input.list_field <- function(x, id, name) {
-
   fields <- get_sub_fields(x)
 
   # TODO: indicate nesting of fields, nice version of

_pkgdown.yml

@@ -206,6 +206,6 @@ reference:
 
 news:
  releases:
- - text: "blockr 0.0.2.9021"
+ - text: "blockr 0.0.2.9022"
  - text: "blockr 0.0.2"
  - text: "blockr 0.0.1.9000"

tests/testthat/test-stack.R

@@ -36,7 +36,6 @@ test_that("stacks", {
 })
 
 test_that("Set stack title", {
-
   stack_test_server <- function(id, x, ...) {
     generate_server(x, id, ...)
   }
@@ -121,6 +120,9 @@ test_that("stacks demo works", {
   )
 
   # Add a block
+  # (need to click on the add block button to set the input value to 1)
+  # need also to click on the selector to trigger the offcanvas
+  app$click(input = "mystack-add-block-add")
   app$click(selector = ".stack-add-block")
   app$set_inputs("mystack-add-block-search" = "dataset_block")