add stack validation utils

NAMESPACE

@@ -72,7 +72,9 @@ S3method(input_ids,hidden_field)
 S3method(input_ids,list_field)
 S3method(is_initialized,block)
 S3method(is_initialized,field)
+S3method(is_valid,block)
 S3method(is_valid,field)
+S3method(is_valid,stack)
 S3method(layout,block)
 S3method(remove_button,block)
 S3method(remove_button,stack)

NEWS.md

@@ -1,6 +1,7 @@
 # blockr 0.0.2.9031
 
 ## Feature
+- New validate stack function.
 - 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

R/server.R

@@ -14,13 +14,17 @@
 #' @rdname generate_server
 #' @export
 generate_server.result_field <- function(x, ...) {
-  function(id, init = NULL, data = NULL) {
+  function(id, init = NULL, data = NULL, is_link_valid = NULL) {
     moduleServer(id, function(input, output, session) {
-      get_result <- function(inp) {
-        req(inp)
-        res <- get_stack_result(
-          get_workspace_stack(inp)
-        )
+      get_result <- function(inp = NULL) {
+        if (is.null(inp)) {
+          res <- data.frame()
+          # Needed by ui_update
+          attr(res, "result_field_stack_name") <- ""
+          return(res)
+        }
+        stack <- workspace_stacks()[[inp]]$stack
+        res <- get_stack_result(stack)
 
         attr(res, "result_field_stack_name") <- inp
 
@@ -44,13 +48,17 @@
         updateSelectInput(
           session,
           "select-stack",
-          choices = result_field_stack_opts(session$ns, workspace_stacks()),
+          choices = result_field_stack_opts(session$ns, names(workspace_stacks())),
           selected = input[["select-stack"]]
         )
       )
 
       reactive({
-        get_result(input[["select-stack"]])
+        if (is_link_valid()) {
+          get_result(input[["select-stack"]])
+        } else {
+          get_result()
+        }
       })
     })
   }
@@ -82,19 +90,21 @@
   }
 }
 
 generate_server_block <- function(
     x,
     in_dat = NULL,
     id,
     display = c("table", "plot"),
-    is_prev_valid) {
+    is_prev_valid, linked_stack = NULL) {
   display <- match.arg(display)
 
   # if in_dat is NULL (data block), turn it into a reactive expression that
   # returns NULL
   if (is.null(in_dat)) {
     in_dat <- reactive(NULL)
     is_prev_valid <- reactive(NULL)
+  } else {
+    linked_stack <- reactive(NULL)
   }
 
   obs_expr <- function(x) {
@@ -136,12 +146,16 @@
       l_values_module <- list() # a list with reactive values (module server output)
       for (name in names(x_srv)) {
         l_values_module[[name]] <-
-          generate_server(x_srv[[name]])(name, init = l_init[[name]], data = in_dat)
+          generate_server(x_srv[[name]])(
+            name,
+            init = l_init[[name]],
+            data = in_dat, 
+            is_link_valid = reactive(linked_stack()$is_valid)
+          )
       }
 
       # proceed in standard fashion (if fields have no generate_server)
       r_values_default <- reactive({
-        # if (!is.null(is_prev_valid)) req(is_prev_valid)
         blk_no_srv <- blk()
         blk_no_srv[is_srv] <- NULL # to keep class etc
         eval(obs_expr(blk_no_srv))
@@ -156,7 +170,7 @@
 
       # This will also trigger when the previous block
       # valid status changes.
-      obs$update_blk <- observeEvent(c(r_values(), in_dat(), is_prev_valid()),
+      obs$update_blk <- observeEvent(c(r_values(), in_dat(), linked_stack()$is_valid),
         {
           # 1. upd blk,
           b <- update_blk(
@@ -174,7 +188,7 @@
           log_debug("Updating UI of block ", class(x)[[1]])
 
           # Validating
-          is_valid$block <- validate_block(blk())
+          is_valid$block <- is_valid(blk())
           is_valid$message <- attr(is_valid$block, "msg")
           is_valid$fields <- attr(is_valid$block, "fields")
           log_debug("Validating block ", class(x)[[1]])
@@ -210,7 +224,7 @@
       out_dat <- if (attr(x, "submit") > -1) {
         eventReactive(input$submit,
           {
-            req(is_valid$block)
+            if (!is_valid$block) return(data.frame())
             if (is.null(in_dat())) {
               evaluate_block(blk())
             } else {
@@ -223,7 +237,7 @@
         )
       } else {
         reactive({
-          req(is_valid$block)
+          if (!is_valid$block) return(data.frame())
           if (is.null(in_dat()) && !inherits(x, "transform_block")) {
             evaluate_block(blk())
           } else {
@@ -291,8 +305,8 @@
 
 #' @rdname generate_server
 #' @export
-generate_server.data_block <- function(x, id, ...) {
-  generate_server_block(x = x, in_dat = NULL, id = id, is_prev_valid = NULL)
+generate_server.data_block <- function(x, id, linked_stack, ...) {
+  generate_server_block(x = x, in_dat = NULL, id = id, is_prev_valid = NULL, linked_stack = linked_stack)
 }
 
 #' @param in_dat Reactive input data
@@ -322,7 +336,7 @@
 #' @rdname generate_server
 #' @export
 generate_server.stack <- function(x, id = NULL, new_block = NULL,
-                                  workspace = get_workspace(), ...) {
+                                  workspace = get_workspace(), prev_stack, ...) {
   stopifnot(...length() == 0L)
 
   id <- coal(id, get_stack_name(x))
@@ -339,10 +353,14 @@
   moduleServer(
     id = id,
     function(input, output, session) {
+      ns <- session$ns
+
       vals <- reactiveValues(
         stack = x,
         blocks = vector("list", length(x)),
-        removed = FALSE
+        removed = FALSE,
+        is_valid = NULL,
+        prev_stack = NULL
       )
       # Don't remove: needed by shinytest2
       exportTestValues(
@@ -396,19 +414,70 @@
       # Any block change: data or input should be sent
       # up to the stack so we can properly serialise.
       observeEvent(
-        c(
-          get_block_vals(vals$blocks),
-          get_last_block_data(vals$blocks)()
-        ),
         {
-          vals$stack <- set_stack_blocks(
-            vals$stack,
-            get_block_vals(vals$blocks),
-            get_last_block_data(vals$blocks)
+          req(length(vals$blocks) > 0)
+          c(
+            lapply(vals$blocks, \(block) {
+              block$is_valid()
+            }),
+            get_block_vals(vals$blocks)
           )
-        }
+        },
+        {
+          # get_last_block_data(vals$blocks)() errors
+          # if any block is invalid
+          tryCatch(
+            {
+              vals$stack <- set_stack_blocks(
+                vals$stack,
+                get_block_vals(vals$blocks),
+                get_last_block_data(vals$blocks)()
+              )
+            },
+            error = function(e) {
+              vals$stack <- set_stack_blocks(
+                vals$stack,
+                get_block_vals(vals$blocks),
+                list()
+              )
+            }
+          )
+          vals$is_valid <- is_valid(vals$stack)
+        }, priority = 1000
       )
 
+      # stack UI validation message
+      # We only display which block is invalid
+      observeEvent(c(vals$is_valid, prev_stack()$is_valid), {
+        vals$prev_stack <- prev_stack()
+        removeUI(sprintf("#%s .stack-validation-message", ns(NULL)))
+        msg <- if (is.null(prev_stack()$is_valid)) {
+          HTML(paste(
+            lapply(attr(vals$is_valid, "msgs"), \(msg) {
+              sprintf("Block %s is invalid", msg)
+            }),
+            collapse = ", </br>"
+          ))
+        } else {
+          if (!prev_stack()$is_valid) {
+            "Linked stack isn't valid. Please fix upstream errors."
+          }
+        }
+        insertUI(
+          sprintf("#%s .stack-validation", ns(NULL)),
+          ui = div(
+            class = "text-danger text-center stack-validation-message",
+            msg
+          )
+        )
+
+        # Disable copy code button
+        session$sendCustomMessage(
+          "toggle-copy-code",
+          list(state = vals$is_valid, id = ns("copy"))
+        )
+      })
+
       observeEvent(vals$stack, {
         log_debug("UPDADING WORKSPACE with stack ", id)
         add_workspace_stack(id, vals$stack,
@@ -424,7 +493,7 @@
         session$sendCustomMessage(
           "blockr-render-stack",
           list(
-            stack = session$ns(NULL),
+            stack = ns(NULL),
             locked = is_locked(session)
           )
         )
@@ -687,7 +756,12 @@
         vals$stacks[[stack_id]] <- generate_server(
           el,
           id = stack_id,
-          new_block = reactive(vals$new_block[[stack_id]])
+          new_block = reactive(vals$new_block[[stack_id]]),
+          prev_stack = if (length(vals$stacks) == 1) {
+            reactive(NULL)
+          } else {
+            reactive(vals$stacks[[length(vals$stacks) - 1]])
+          }
         )
 
         # Handle new block injection
@@ -702,9 +776,16 @@
       })
 
       attr(x, "reactive_stack_directory") <- reactive({
-        names(vals$stacks)
+        vals$stacks
       }) |> bindEvent(
-        chr_ply(lapply(vals$stacks, `[[`, "stack"), attr, "title")
+        c(
+          chr_ply(lapply(vals$stacks, `[[`, "stack"), attr, "title"),
+          lapply(vals$stacks, \(stack) {
+            lgl_ply(stack$blocks, \(block) {
+              block$is_valid()
+            })
+          })
+        )
       )
 
       # Serialize
@@ -741,10 +822,16 @@
 
   observeEvent(TRUE, {
     lapply(names(stacks), \(nme) {
+      idx <- which(nme == names(stacks))
       vals$stacks[[nme]] <- generate_server(
         stacks[[nme]],
         id = nme,
-        new_block = reactive(vals$new_block[[nme]])
+        new_block = reactive(vals$new_block[[nme]]),
+        prev_stack = if (idx == 1) {
+          reactive(NULL)
+        } else {
+          reactive(vals$stacks[[nme]])
+        }
       )
     })
   })
@@ -813,6 +900,11 @@
       NULL
     } else {
       vals$blocks[[i - 1]]$is_valid
+    },
+    linked_stack = if (i == 1) {
+      reactive(vals$prev_stack)
+    } else {
+      NULL
     }
   )
 }

R/ui.R

@@ -387,6 +387,7 @@ generate_ui.stack <- function(x, id = NULL, ...) {
       class = "card stack border",
       id = id,
       stack_header(x, id, ns),
+      div(class = "stack-validation"),
       div(
         class = "card-body p-1",
         id = sprintf("%s-body", id),

R/utils.R

@@ -259,7 +259,7 @@ send_error_to_ui <- function(blk, is_valid, session) {
   )
 
   # Toggle submit field
-  if (!is.null(attr(blk, "submit"))) {
+  if (attr(blk, "submit") > -1) {
     session$sendCustomMessage(
       "toggle-submit",
       list(state = is_valid$block, id = ns("submit"))

R/validation.R

@@ -43,9 +43,11 @@ is_valid.field <- function(x) {
   )
 }
 
-validate_block <- function(x) {
-  tmp <- lapply(names(x), \(name) {
-    is_valid(x[[name]])
+#' @rdname validate_field
+#' @export
+is_valid.block <- function(x) {
+  tmp <- lapply(x, \(field) {
+    is_valid(field)
   })
   structure(
     all(unlist(tmp) == TRUE),
@@ -54,6 +56,18 @@ validate_block <- function(x) {
   )
 }
 
+#' @rdname validate_field
+#' @export
+is_valid.stack <- function(x) {
+  tmp <- lapply(x, \(block) {
+    is_valid(block)
+  })
+  structure(
+    all(unlist(tmp) == TRUE),
+    msgs = which(tmp == FALSE) # captures invalid blocks
+  )
+}
+
 #' @param ... Message components (forwarded to [paste0()])
 #' @param class Condition class (will be a subclass of `validation_failure`)
 #' @rdname validate_field