Support add + remove blocks to a stack

NAMESPACE

@@ -86,4 +86,5 @@ export(validate_field)
 export(value)
 export(values)
 export(variable_field)
+import(shiny)
 importFrom(magrittr,"%>%")

R/server.R

@@ -1,11 +1,12 @@
-#' UI
+#' Server
 #'
-#' Generic for UI generation
+#' Generic for server generation
 #'
-#' @param x Object for which to generate a [shiny::moduleServer()]
+#' @param x Object for which to generate a [moduleServer()]
 #' @param ... Generic consistency
 #'
 #' @export
+#' @import shiny
 generate_server <- function(x, ...) {
   UseMethod("generate_server")
 }
@@ -34,25 +35,45 @@ generate_server.data_block <- function(x, ...) {
     )
   }
 
-  shiny::moduleServer(
+  moduleServer(
     attr(x, "name"),
     function(input, output, session) {
+      ns <- session$ns
+      blk <- reactiveVal(x)
 
-      blk <- shiny::reactiveVal(x)
-
-      shiny::observeEvent(
+      o <- observeEvent(
         eval(obs_expr(blk())),
         eval(set_expr(blk())),
         ignoreInit = TRUE
       )
 
-      out_dat <- shiny::reactive(
+      out_dat <- reactive(
         evalute_block(blk())
       )
 
       output <- server_output(x, out_dat, output)
       output <- server_code(x, blk, output)
 
+      # Cleanup module inputs (UI and server side)
+      # and observer
+      observeEvent(input$remove, {
+        # Trick to be able to tell the stack to wait
+        # for this event to run.
+        session$userData$is_cleaned(FALSE)
+        # Can only remove when it is the last stack block
+        if (length(session$userData$stack) == 1) {
+          message(sprintf("CLEANING UP BLOCK %s", attr(x, "name")))
+          removeUI(sprintf("#%s", ns("block")), immediate = TRUE)
+          remove_shiny_inputs(id = attr(x, "name"), input)
+          o$destroy()
+          session$userData$is_cleaned(TRUE)
+        }
+        # We have to set high priority so this event
+        # executes before the one in the stack which
+        # updates the stack. If we don't, this will
+        # never execute because the stack will be empty :)
+      }, priority = 500)
+
       out_dat
     }
   )
@@ -77,25 +98,35 @@ generate_server.transform_block <- function(x, in_dat, ...) {
     )
   }
 
-  shiny::moduleServer(
+  moduleServer(
     attr(x, "name"),
     function(input, output, session) {
+      ns <- session$ns
+      blk <- reactiveVal(x)
 
-      blk <- shiny::reactiveVal(x)
-
-      shiny::observeEvent(
+      o <- observeEvent(
         eval(obs_expr(blk())),
         eval(set_expr(blk())),
         ignoreInit = TRUE
       )
 
-      out_dat <- shiny::reactive(
+      out_dat <- reactive(
         evalute_block(blk(), data = in_dat())
       )
 
       output <- server_output(x, out_dat, output)
       output <- server_code(x, blk, output)
 
+      # Cleanup module inputs (UI and server side)
+      # and observer
+      observeEvent(input$remove, {
+        message(sprintf("CLEANING UP BLOCK %s", attr(x, "name")))
+        removeUI(sprintf("#%s", ns("block")))
+        remove_shiny_inputs(id = attr(x, "name"), input)
+        o$destroy()
+        session$userData$is_cleaned(TRUE)
+      })
+
       out_dat
     }
   )
@@ -107,20 +138,159 @@ generate_server.stack <- function(x, ...) {
 
   stopifnot(...length() == 0L)
 
-  shiny::moduleServer(
+  moduleServer(
     attr(x, "name"),
     function(input, output, session) {
+      vals <- reactiveValues(stack = x, blocks = vector("list", length(x)))
+      init_blocks(x, vals, session)
+
+      # Add block
+      observeEvent(input$add, {
+        showModal(
+          modalDialog(
+            "TO DO: add a confirm button and a select input to select
+            which block to add ...",
+            title = h3(icon("check"), "Add a new block"),
+            footer = modalButton("Dismiss"),
+            size = "m",
+            easyClose = FALSE,
+            fade = TRUE
+          )
+        )
+      })
+
+      observeEvent(input$add, {
+        # Update stack
+        block_to_add <- if (length(vals$stack) == 0) {
+          data_block
+        } else {
+          filter_block
+        }
+
+        vals$stack[[length(vals$stack) + 1]] <- do.call(
+          block_to_add,
+          if (length(vals$stack) == 0) {
+            list()
+          } else {
+            list(vals$blocks[[length(vals$stack)]]())
+          }
+        )
+        # Call module
+        vals$blocks[[length(vals$stack)]] <- generate_server(
+          vals$stack[[length(vals$stack)]],
+          in_dat = if (length(vals$stack) == 1) {
+            # No data for first block
+            NULL
+          } else {
+            # Data from previous block
+            vals$blocks[[length(vals$stack) - 1]]
+          }
+        )
+
+        # Correct selector
+        if (length(vals$stack) == 1) {
+          # If this is the first module inserted,
+          # we target the body container.
+          # TO DO: we should actually have a proper UI for the stack
+          # to avoid targeting .container-fluid ...
+          selector <- ".container-fluid"
+        } else {
+          # Target the previous block
+          selector <- sprintf(
+            "#%s-%s-block",
+            attr(vals$stack, "name"),
+            attr(vals$stack[[length(vals$stack) - 1]], "name")
+          )
+        }
+
+        # Insert UI after last block
+        insertUI(
+          selector,
+          where = "afterEnd",
+          ui = generate_ui(
+            vals$stack[[length(vals$stack)]],
+            id = attr(vals$stack, "name")
+          )
+        )
+
+        # Necessary to communicate with downstream modules
+        session$userData$stack <- vals$stack
+      })
+
+      # Remove block from stack (can't be done within the block)
+      to_remove <- reactive({
+        req(input$last_changed)
+        if (grepl("remove", input$last_changed$name)) {
+          req(input$last_changed$value > 0)
+        }
+
+        # Retrieve index of block to remove
+        blocks_ids <- paste(
+          attr(x, "name"),
+          vapply(vals$stack, \(x) attr(x, "name"), FUN.VALUE = character(1)),
+          sep = "-"
+        )
+        block_id <- strsplit(input$last_changed$name, "-remove")[[1]][1]
+        tmp <- which(blocks_ids == block_id)
+        req(length(tmp) > 0)
+        tmp
+      })
+
+      session$userData$is_cleaned <- reactiveVal(FALSE)
+
+      observeEvent({
+        c(
+          to_remove(),
+          session$userData$is_cleaned()
+        )
+      }, {
+        # We can't remove the data block if there are downstream consumers...
+        if (to_remove() == 1 && length(vals$stack) > 1) {
+          showModal(
+            modalDialog(
+              title = h3(icon("xmark"), "Error"),
+              "Can't remove a datablock whenever there are 
+              downstream data block consumers."
+            )
+          )
+        } else {
+          if (session$userData$is_cleaned()) {
+            message(sprintf("REMOVING BLOCK %s", to_remove()))
+            vals$stack[[to_remove()]] <- NULL
+            session$userData$stack <- vals$stack
+            session$userData$is_cleaned(FALSE)
+          }
+        }
+      })
+
+      vals
 
-      res <- vector("list", length(x))
-
-      res[[1L]] <- generate_server(x[[1L]])
-
-      for (i in seq_along(x)[-1L]) {
-        res[[i]] <- generate_server(x[[i]], in_dat = res[[i - 1L]])
-      }
+    }
+  )
+}
 
-      res
+#' Init blocks server
+#' @keywords internal
+init_blocks <- function(x, vals, session) {
+  observeEvent(TRUE, {
+    session$userData$stack <- vals$stack
+    vals$blocks[[1L]] <- generate_server(x[[1L]])
+    for (i in seq_along(x)[-1L]) {
+      vals$blocks[[i]] <- generate_server(
+        x[[i]],
+        in_dat = vals$blocks[[i - 1L]]
+      )
     }
+  })
+}
+
+#' Cleanup module inputs
+#' @keywords internal
+remove_shiny_inputs <- function(id, .input) {
+  invisible(
+    lapply(grep(id, names(.input), value = TRUE), function(i) {
+      .subset2(.input, "impl")$.values$remove(i)
+    })
   )
 }
 
@@ -135,7 +305,7 @@ server_output <- function(x, result, output) {
 #' @rdname generate_ui
 #' @export
 server_output.block <- function(x, result, output) {
-  output$output <- shiny::renderPrint(result())
+  output$output <- renderPrint(result())
   output
 }
 
@@ -150,7 +320,7 @@ server_code <- function(x, state, output) {
 #' @export
 server_code.block <- function(x, state, output) {
 
-  output$code <- shiny::renderPrint(
+  output$code <- renderPrint(
     cat(deparse(generate_code(state())), sep = "\n")
   )
 

R/stack.R

@@ -42,5 +42,5 @@ serve_stack <- function(stack) {
     generate_server(stack)
   }
 
-  shiny::shinyApp(ui, server)
+  shinyApp(ui, server)
 }