Merge pull request #421 from BristolMyersSquibb/366-result-field

Better result field

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: blockr
 Title: A block-based framework for data manipulation and visualization
-Version: 0.0.2.9023
+Version: 0.0.2.9030
 Authors@R: 
     c(person(given = "Nicolas",
              family = "Bennett",
@@ -26,10 +26,10 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2
 Imports:
     magrittr,
-    shiny,
+    shiny (>= 1.8.1),
     dplyr,
     utils,
-    bslib,
+    bslib (>= 0.7.0),
     methods,
     DT,
     htmltools,

NAMESPACE

@@ -113,6 +113,7 @@ S3method(ui_update,upload_field)
 S3method(ui_update,variable_field)
 S3method(update_field,field)
 S3method(update_field,hidden_field)
+S3method(update_field,result_field)
 S3method(update_fields,data_block)
 S3method(update_fields,plot_block)
 S3method(update_fields,transform_block)
@@ -123,13 +124,15 @@ S3method(validate_field,keyvalue_field)
 S3method(validate_field,list_field)
 S3method(validate_field,numeric_field)
 S3method(validate_field,range_field)
+S3method(validate_field,result_field)
 S3method(validate_field,select_field)
 S3method(validate_field,string_field)
 S3method(validate_field,switch_field)
 S3method(validate_field,upload_field)
 S3method(validate_field,variable_field)
 S3method(value,field)
 S3method(value,list_field)
+S3method(value,result_field)
 S3method(value,variable_field)
 export("%>%")
 export("value<-")

NEWS.md

@@ -1,4 +1,4 @@
-# blockr 0.0.2.9023
+# blockr 0.0.2.9030
 
 ## 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:
@@ -52,6 +52,10 @@ If not passed, the block will belong to `uncategorized` blocks (default).
 - Fix issue in `handle_remove.block`: `vals$stack` wasn't correctly updated
 when the last block was removed leading to wrong state.
 - Loading spinner is now correctly hidden when the block visual is updated.
+- Fix #366:
+  - We no longer need a reactive poll per result field for the data.
+  - The (serialized) field "value" is only the stack name the field refers to (not data).
+  - We no longer need a reactive poll for the stack selector drop-down
 - Fix [#358](https://github.com/BristolMyersSquibb/blockr/issues/358).
 
 # blockr 0.0.2

R/blocks.R

@@ -164,10 +164,13 @@ new_xpt_block <- function(...) {
 #' another one. This isn't relevant for single stack apps.
 #'
 #' @inheritParams new_block
+#' @param stack Stack name
+#'
 #' @export
-new_result_block <- function(...) {
+new_result_block <- function(stack = character(), ...) {
+
   fields <- list(
-    stack = new_result_field(title = "Stack")
+    stack = new_result_field(stack, title = "Stack")
   )
 
   new_block(

R/field-core.R

@@ -99,6 +99,12 @@ update_field.hidden_field <- function(x, new, env = list()) {
   eval_set_field_value(x, env)
 }
 
+#' @rdname update_field
+#' @export
+update_field.result_field <- function(x, new, env = list()) {
+  NextMethod(new = attr(new, "result_field_stack_name"))
+}
+
 eval_set_field_value <- function(x, env) {
 
   for (cmp in names(x)[lgl_ply(x, is.function)]) {
@@ -173,6 +179,35 @@ value.list_field <- function(x, name = "value") {
   NextMethod()
 }
 
+#' @rdname value
+#' @export
+value.result_field <- function(x, name = "value") {
+
+  stopifnot(identical(name, "value"))
+
+  field <- get_field_value(x, "value")
+
+  if (length(field) && field %in% list_workspace_stacks()) {
+
+    res <- get_stack_result(get_workspace_stack(field))
+
+    if (inherits(res, "reactive")) {
+
+      if (is.null(getDefaultReactiveDomain())) {
+        list()
+      } else {
+        res()
+      }
+
+    } else {
+      res
+    }
+
+  } else {
+    list()
+  }
+}
+
 #' Get all values from a field
 #'
 #' This calls \link{value} on all the field's names.

R/fields.R

@@ -289,6 +289,24 @@ validate_field.list_field <- function(x) {
 #' @inheritParams new_string_field
 #' @rdname result_field
 #' @export
-new_result_field <- function(value = list(), ...) {
+new_result_field <- function(value = character(), ...) {
   new_field(value, ..., class = "result_field")
 }
+
+#' @rdname validate_field
+#' @export
+validate_field.result_field <- function(x) {
+
+  field <- get_field_value(x, "value")
+
+  validate_string(field)
+
+  if (!field %in% list_workspace_stacks()) {
+    validation_failure(
+      "result fields have to refer to existing stack names",
+      class = "result_failure"
+    )
+  }
+
+  NextMethod()
+}

R/server.R

@@ -16,42 +16,41 @@ generate_server <- function(x, ...) {
 generate_server.result_field <- function(x, ...) {
   function(id, init = NULL, data = NULL) {
     moduleServer(id, function(input, output, session) {
-      get_result <- function() {
-        inp <- input[["select-stack"]]
+      get_result <- function(inp) {
+        res <- get_stack_result(
+          get_workspace_stack(inp)
+        )
 
-        if (length(inp) && inp %in% list_workspace_stacks()) {
-          get_stack_result(
-            get_workspace_stack(inp)
-          )
-        } else {
-          data.frame()
-        }
-      }
+        attr(res, "result_field_stack_name") <- inp
 
-      result_hash <- function() {
-        rlang::hash(get_result())
+        res
       }
 
-      current_stack <- function() {
-        res <- strsplit(session$ns(NULL), "-")[[1L]]
-        res[length(res) - 2L]
-      }
+      workspace_stacks <- attr(get_workspace(), "reactive_stack_directory")
 
-      stack_opts <- function() {
-        setdiff(list_workspace_stacks(), current_stack())
-      }
+      exportTestValues(
+        stacks = workspace_stacks()
+      )
 
-      opts <- reactivePoll(100, session, stack_opts, stack_opts)
+      if (is.null(workspace_stacks)) {
+        workspace_stacks <- function() {
+          list_workspace_stacks()
+        }
+      }
 
       observeEvent(
-        opts(),
-        updateSelectInput(session, "select-stack",
-          choices = opts(),
+        workspace_stacks(),
+        updateSelectInput(
+          session,
+          "select-stack",
+          choices = result_field_stack_opts(session$ns, workspace_stacks()),
           selected = input[["select-stack"]]
         )
       )
 
-      reactivePoll(100, session, result_hash, get_result)
+      reactive({
+        get_result(input[["select-stack"]])
+      })
     })
   }
 }
@@ -404,7 +403,7 @@ generate_server.stack <- function(x, id = NULL, new_block = NULL,
           vals$stack <- set_stack_blocks(
             vals$stack,
             get_block_vals(vals$blocks),
-            get_last_block_data(vals$blocks)()
+            get_last_block_data(vals$blocks)
           )
         }
       )
@@ -701,6 +700,12 @@ generate_server.workspace <- function(x, id, ...) {
         removeUI(".stack-col", multiple = TRUE)
       })
 
+      attr(x, "reactive_stack_directory") <- reactive({
+        names(vals$stacks)
+      }) |> bindEvent(
+        chr_ply(lapply(vals$stacks, `[[`, "stack"), attr, "title")
+      )
+
       # Serialize
       output$serialize <- downloadHandler(
         filename = function() {

R/ui.R

@@ -682,20 +682,43 @@ ui_input.filesbrowser_field <- function(x, id, name) {
 #' @rdname ui_input
 #' @export
 ui_input.result_field <- function(x, id, name) {
+
   ns <- NS(input_ids(x, id))
 
   selectizeInput(
     ns("select-stack"),
     name,
-    list_workspace_stacks(),
-    value(x),
+    result_field_stack_opts(ns),
+    get_field_value(x, "value"),
     options = list(
       dropdownParent = "body",
       placeholder = "Please select an option below"
     )
   )
 }
 
+result_field_stack_opts <- function(ns, stacks = list_workspace_stacks()) {
+
+  current_stack <- function(ns) {
+    res <- strsplit(ns(NULL), "-")[[1L]]
+    res[length(res) - 2L]
+  }
+
+  res <- setdiff(stacks, current_stack(ns))
+
+  set_names(res, stack_id_to_name(res))
+}
+
+stack_id_to_name <- function(id) {
+
+  do_one <- function(x) {
+    stk <- get_workspace_stack(x)
+    paste0(get_stack_title(stk), " (", get_stack_name(stk), ")")
+  }
+
+  chr_ply(id, do_one)
+}
+
 #' @rdname ui_input
 #' @export
 input_ids <- function(x, ...) {

inst/examples/result/app.R

@@ -0,0 +1,8 @@
+library(blockr)
+
+serve_workspace(
+  stack1 = new_stack(new_dataset_block("iris")),
+  stack2 = new_stack(new_dataset_block("mtcars")),
+  stack3 = new_stack(new_result_block("stack1")),
+  force = TRUE
+)

tests/testthat/_snaps/result/result-app-001.json

@@ -0,0 +1,8 @@
+{
+  "input": {
+
+  },
+  "export": {
+
+  }
+}

tests/testthat/_snaps/stack/stack-app-003.json

@@ -39,8 +39,8 @@
 
           ],
           "choices": [
-            "structure(function (data) ",
-            "colnames(data), result = c(\"Time\", \"demand\"))"
+            "function (data) ",
+            "colnames(data)"
           ],
           "multiple": true
         }

tests/testthat/_snaps/stack/stack-app-004.json

@@ -39,8 +39,8 @@
 
           ],
           "choices": [
-            "structure(function (data) ",
-            "colnames(data), result = c(\"Time\", \"demand\"))"
+            "function (data) ",
+            "colnames(data)"
           ],
           "multiple": true
         }