Attempt to fix Result block don't get updated properly #432

BristolMyersSquibb · Oct 14, 2024 · a9330aa · a9330aa
1 parent 061ac78
commit a9330aa
Show file tree

Hide file tree

Showing 2 changed files with 32 additions and 11 deletions.
diff --git a/.lintr b/.lintr
@@ -2,7 +2,8 @@ linters: linters_with_defaults(
   line_length_linter = line_length_linter(100L),
   object_name_linter = NULL, # Because we use S3 and end up with is_initialized.field
   object_usage_linter = NULL,   # When code is WIP this is annoying ...
-  commented_code_linter = NULL  # When code is WIP this is annoying ...
+  commented_code_linter = NULL,  # When code is WIP this is annoying ...
+  cyclocomp_linter = cyclocomp_linter(complexity_limit = 20)
   )
 exclusions: list(
     "inst/examples/cdisc-plot/example.R",

diff --git a/R/server.R b/R/server.R
@@ -44,13 +44,18 @@ generate_server.result_field <- function(x, ...) {
         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"]])
+        stacks <- workspace_stacks()
+        blocks <- stacks[[input[["select-stack"]]]]$blocks
+        all_valid <- lgl_ply(blocks, \(block) {
+          block$is_valid()
+        })
+        if (all(all_valid) == TRUE) get_result(input[["select-stack"]]) else data.frame()
       })
     })
   }
@@ -159,6 +164,7 @@ generate_server_block <- function(
       obs$update_blk <- observeEvent(c(r_values(), in_dat(), is_prev_valid()),
         {
           # 1. upd blk,
+          is_valid$block <- FALSE
           b <- update_blk(
             b = blk(),
             value = r_values(),
@@ -210,7 +216,7 @@ generate_server_block <- function(
       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,10 +229,11 @@ generate_server_block <- function(
         )
       } 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 {
+            if (nrow(in_dat()) == 0) return(data.frame())
             evaluate_block(blk(), data = in_dat())
           }
         })
@@ -396,10 +403,15 @@ generate_server.stack <- function(x, id = NULL, new_block = NULL,
       # 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)()
-        ),
+        {
+          lapply(vals$blocks, \(block) {
+            req(block)
+          })
+          c(
+            get_block_vals(vals$blocks),
+            get_last_block_data(vals$blocks)()
+          )
+        },
         {
           vals$stack <- set_stack_blocks(
             vals$stack,
@@ -702,9 +714,17 @@ generate_server.workspace <- function(x, id, ...) {
       })
 
       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$stack, \(stack) {
+            lgl_ply(stack$blocks, \(block) {
+              block$is_valid()
+              block$block
+            })
+          })
+        )
       )
 
       # Serialize