introduce generics for input/output

BristolMyersSquibb · Nov 7, 2024 · 1333924 · 1333924
1 parent ae2a2f0
commit 1333924
Show file tree

Hide file tree

Showing 9 changed files with 192 additions and 145 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -16,6 +16,14 @@ S3method(block_icon,data_block)
 S3method(block_icon,default)
 S3method(block_icon,plot_block)
 S3method(block_icon,transform_block)
+S3method(block_input_check,data_block)
+S3method(block_input_check,parser_block)
+S3method(block_input_check,transform_block)
+S3method(block_output_ptype,dataset_block)
+S3method(block_output_ptype,filesbrowser_block)
+S3method(block_output_ptype,result_block)
+S3method(block_output_ptype,transform_block)
+S3method(block_output_ptype,upload_block)
 S3method(blockr_serialize,block)
 S3method(blockr_serialize,field)
 S3method(blockr_serialize,stack)
@@ -148,8 +156,9 @@ export(block_combiner)
 export(block_descr)
 export(block_header)
 export(block_icon)
+export(block_input_check)
 export(block_name)
-export(block_reg_id)
+export(block_output_ptype)
 export(blockr_deserialize)
 export(blockr_serialize)
 export(cat_logger)
@@ -167,7 +176,6 @@ export(generate_server)
 export(generate_ui)
 export(get_compatible_blocks)
 export(get_field_name)
-export(get_registry)
 export(get_stack_name)
 export(get_stack_title)
 export(get_workspace)
@@ -181,6 +189,7 @@ export(init_lock)
 export(initialize_block)
 export(initialize_field)
 export(inject_remove_button)
+export(input_failure)
 export(input_ids)
 export(is_block)
 export(is_field)

diff --git a/R/block-core.R b/R/block-core.R
@@ -312,3 +312,75 @@ update_fields.transform_block <- function(x, session, data, ...) {
 #' @rdname update_fields
 #' @export
 update_fields.plot_block <- update_fields.transform_block
+
+#' Block input/output
+#'
+#' Used for checking whether blocks are compatible
+#'
+#' @param x Block
+#' @rdname block_io
+#' @export
+block_input_check <- function(x, data, ...) UseMethod("block_input_check")
+
+#' @rdname block_io
+#' @export
+block_input_check.data_block <- function(x, data, ...) {
+
+  if (missing(data) || is.null(data)) {
+    return(invisible(NULL))
+  }
+
+  input_failure("No (or empty) input expected.")
+}
+
+#' @rdname block_io
+#' @export
+block_input_check.transform_block <- function(x, data, ...) {
+
+  if (inherits(data, "data.frame")) {
+    return(invisible(NULL))
+  }
+
+  input_failure("Expecting data.frame input.")
+}
+
+#' @rdname block_io
+#' @export
+block_input_check.parser_block <- function(x, data, ...) {
+
+  if (is_string(data)) {
+    return(invisible(NULL))
+  }
+
+  input_failure("Expecting string-valued input.")
+}
+
+#' @rdname block_io
+#' @export
+input_failure <- function(..., class = character()) {
+  rlang::abort(paste0(...), class = c(class, "input_failure"))
+}
+
+#' @rdname block_io
+#' @export
+block_output_ptype <- function(x, ...) UseMethod("block_output_ptype")
+
+#' @rdname block_io
+#' @export
+block_output_ptype.dataset_block <- function(x, ...) data.frame()
+
+#' @rdname block_io
+#' @export
+block_output_ptype.result_block <- function(x, ...) value(x[["stack"]])
+
+#' @rdname block_io
+#' @export
+block_output_ptype.upload_block <- function(x, ...) character(1L)
+
+#' @rdname block_io
+#' @export
+block_output_ptype.filesbrowser_block <- function(x, ...) character(1L)
+
+#' @rdname block_io
+#' @export
+block_output_ptype.transform_block <- function(x, ...) data.frame()
diff --git a/R/registry.R b/R/registry.R
@@ -38,22 +38,16 @@ block_name <- block_descrs_getter(block_descr_getter("name"))
 #' @export
 block_descr <- block_descrs_getter(block_descr_getter("description"))
 
-#' @rdname available_blocks
-#' @export
-block_reg_id <- block_descrs_getter(block_descr_getter("id"))
-
 new_block_descr <- function(constructor, name, description, id, classes, input,
                             output, pkg, category) {
   stopifnot(
     is.function(constructor), is_string(name), is_string(description),
-    is_string(category),
-    is.character(classes), length(classes) >= 1L,
-    is_string(input), is_string(output), is_string(pkg), is_string(id)
+    is_string(category), is.character(classes), length(classes) >= 1L,
+    is.function(input), is_string(pkg), is_string(id)
   )
 
   structure(
-    constructor,
-    name = name, description = description, id = id,
+    constructor, name = name, description = description, id = id,
     classes = classes, input = input, output = output,
     package = pkg, category = category, class = "block_descr"
   )
@@ -63,9 +57,9 @@ block_registry <- new.env()
 
 #' @param constructor Block constructor
 #' @param name,description Metadata describing the block
+#' @param classes Block classes
 #' @param input,output Object types the block consumes and produces
 #' @param package Package where block is defined
-#' @param classes Block classes
 #' @param id Block registry ID
 #' @param category Useful to sort blocks by topics. If not specified,
 #' blocks are uncategorized.
@@ -76,9 +70,10 @@ register_block <- function(
     constructor,
     name,
     description,
-    input,
-    output,
-    classes = class(constructor()),
+    ptype = constructor(),
+    classes = class(ptype),
+    input = get_s3_method("block_input_check", ptype),
+    output = block_output_ptype(ptype),
     id = classes[1L],
     package = NA_character_,
     category = "uncategorized") {
@@ -101,6 +96,19 @@ register_block <- function(
   assign(id, descr, envir = block_registry)
 }
 
+get_s3_method <- function(generic, obj) {
+
+  for (cls in class(obj)) {
+    res <- try(utils::getS3method("block_input_check", cls), silent = TRUE)
+    if (!inherits(res, "try-error")) {
+      return(res)
+    }
+  }
+
+  stop("no method found for generic ", generic, "and classes ",
+       paste0(class(obj), collapse = ", "))
+}
+
 #' @param ... Forwarded to `register_block()`
 #' @rdname available_blocks
 #' @export
@@ -215,42 +223,6 @@ register_blockr_blocks <- function(pkg) {
       "Select n first rows of dataset",
       "Mutate block"
     ),
-    input = c(
-      NA_character_,
-      NA_character_,
-      NA_character_,
-      NA_character_,
-      "string",
-      "string",
-      "string",
-      "string",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame"
-    ),
-    output = c(
-      "data.frame",
-      "data.frame",
-      "string",
-      "string",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame",
-      "data.frame"
-    ),
     package = pkg,
     category = c(
       "data",
@@ -284,32 +256,32 @@ construct_block <- function(block, ...) {
 
   stopifnot(inherits(block, "block_descr"))
 
-  block(..., registry_id = block_reg_id(block))
+  block(...)
 }
 
-#' List available blocks as a data.frame
+#' Find stack compatible blocks
+#'
+#' Given a stack, we use the registry to find
+#' what are the blocks compatible with the last stack block.
+#' If the stack is empy, we return data blocks.
 #'
-#' Provides an alternate way of displaying
-#' the registry information.
-#' This can be useful to create dynamic UI elements
-#' like in \link{add_block_ui}.
+#' @param stack Stack object.
 #'
-#' @return A dataframe.
+#' @return a dataframe.
 #'
 #' @export
-get_registry <- function() {
-  res <- lapply(seq_along(available_blocks()), \(i) {
-    blk <- available_blocks()[[i]]
-    attrs <- attributes(blk)
-    data.frame(
-      ctor = names(available_blocks())[[i]],
-      description = attrs[["description"]],
-      category = attrs[["category"]],
-      classes = paste(c(attrs[["classes"]], "block"), collapse = ", "),
-      input = attrs[["input"]],
-      output = attrs[["output"]],
-      package = attrs[["package"]]
-    )
-  })
-  do.call(rbind, res)
+get_compatible_blocks <- function(stack) {
+
+  is_compat <- function(x, y) {
+    !inherits(try(attr(x, "input")(x(), y), silent = TRUE), "try-error")
+  }
+
+  if (length(stack)) {
+    dat <- block_output_ptype(stack[[length(stack)]])
+  } else {
+    dat <- NULL
+  }
+
+  blocks <- available_blocks()
+  blocks[lgl_ply(blocks, is_compat, dat)]
 }
diff --git a/R/server.R b/R/server.R
@@ -210,8 +210,9 @@ generate_server_block <- function(
       out_dat <- if (attr(x, "submit") > -1) {
         eventReactive(input$submit,
           {
-            req(is_valid$block)
-            if (is.null(in_dat())) {
+            if (!isTruthy(is_valid$block)) {
+              block_output_ptype(blk())
+            } else if (is.null(in_dat())) {
               evaluate_block(blk())
             } else {
               evaluate_block(blk(), data = in_dat())
@@ -223,8 +224,9 @@ generate_server_block <- function(
         )
       } else {
         reactive({
-          req(is_valid$block)
-          if (is.null(in_dat()) && !inherits(x, "transform_block")) {
+          if (!isTruthy(is_valid$block)) {
+            block_output_ptype(blk())
+          } else if (is.null(in_dat()) && !inherits(x, "transform_block")) {
             evaluate_block(blk())
           } else {
             evaluate_block(blk(), data = in_dat())
@@ -522,14 +524,20 @@ add_block_server.default <- function(x, id, vals, ...) {
         blk_choices(get_compatible_blocks(vals$stack))
 
         choices <- blk_choices()
-        choices$name <- paste(choices$package, sep = "::", choices$ctor)
+
+        choices <- lapply(
+          set_names(nm = c("name", "package", "id", "category", "description")),
+          function(x) chr_ply(choices, attr, x)
+        )
+
+        choices$name <- paste0(choices$name, " (", choices$package, ")")
 
         shinyWidgets::updateVirtualSelect(
           "search",
           choices = shinyWidgets::prepare_choices(
-            choices,
+            as.data.frame(choices),
             .data$name,
-            .data$ctor,
+            .data$id,
             group_by = .data$category,
             description = .data$description
           )

diff --git a/R/stack.R b/R/stack.R
@@ -262,45 +262,6 @@ add_block <- function(stack, block, position = NULL) {
   set_stack_blocks(stack, append(stack, list(tmp), position), data)
 }
 
-#' Find stack compatible blocks
-#'
-#' Given a stack, we use the registry to find
-#' what are the blocks compatible with the last stack block.
-#' If the stack is empy, we return data blocks.
-#'
-#' @param stack Stack object.
-#'
-#' @return a dataframe.
-#'
-#' @export
-get_compatible_blocks <- function(stack) {
-  registry <- get_registry()
-  # Only data blocks can be used for a 0 length stack
-  if (length(stack) == 0) {
-    tmp <- registry[is.na(registry$input), ]
-    # Drop result block if there are no other stacks
-    if (length(get_workspace_stacks()) <= 1) {
-      tmp <- tmp[tmp$ctor != "result_block", ]
-    }
-    return(tmp)
-  }
-  # Otherwise we compare the output of the last block
-  # and propose any of the block that have compatible input
-  cls <- paste(class(stack[[length(stack)]]), collapse = ", ")
-  last_blk_output <- registry[grep(cls, registry$classes), "output"]
-
-  tmp <- registry[!is.na(registry$input) & registry$input == last_blk_output, ]
-
-  # Insert result block if there are other stacks
-  if (length(get_workspace_stacks()) > 1) {
-    tmp <- rbind(
-      registry[registry$ctor == "result_block", ],
-      tmp
-    )
-  }
-  tmp
-}
-
 #' @param stack An object inheriting form `"stack"`
 #' @param id Stack ID
 #'