start add block feature

BristolMyersSquibb · Sep 28, 2023 · 6553862 · 6553862
1 parent 54ae580
commit 6553862
Show file tree

Hide file tree

Showing 5 changed files with 117 additions and 56 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -86,4 +86,5 @@ export(validate_field)
 export(value)
 export(values)
 export(variable_field)
+import(shiny)
 importFrom(magrittr,"%>%")
diff --git a/R/server.R b/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,19 +35,19 @@ generate_server.data_block <- function(x, ...) {
     )
   }
 
-  shiny::moduleServer(
+  moduleServer(
     attr(x, "name"),
     function(input, output, session) {
 
-      blk <- shiny::reactiveVal(x)
+      blk <- reactiveVal(x)
 
-      shiny::observeEvent(
+      observeEvent(
         eval(obs_expr(blk())),
         eval(set_expr(blk())),
         ignoreInit = TRUE
       )
 
-      out_dat <- shiny::reactive(
+      out_dat <- reactive(
         evalute_block(blk())
       )
 
@@ -77,19 +78,19 @@ generate_server.transform_block <- function(x, in_dat, ...) {
     )
   }
 
-  shiny::moduleServer(
+  moduleServer(
     attr(x, "name"),
     function(input, output, session) {
 
-      blk <- shiny::reactiveVal(x)
+      blk <- reactiveVal(x)
 
-      shiny::observeEvent(
+      observeEvent(
         eval(obs_expr(blk())),
         eval(set_expr(blk())),
         ignoreInit = TRUE
       )
 
-      out_dat <- shiny::reactive(
+      out_dat <- reactive(
         evalute_block(blk(), data = in_dat())
       )
 
@@ -107,23 +108,76 @@ generate_server.stack <- function(x, ...) {
 
   stopifnot(...length() == 0L)
 
-  shiny::moduleServer(
+  moduleServer(
     attr(x, "name"),
     function(input, output, session) {
+      ns <- session$ns
+      vals <- reactiveValues(blocks = vector("list", length(x)))
+      init_blocks(x, vals)
+
+      # Add block
+      observeEvent(input$add, {
+        showModal(
+          modalDialog(
+            selectInput(
+              ns("block_to_add"),
+              "Which block do you want to add?",
+              choices = c("filter") # TO DO: don't hardcode this
+            ),
+            title = "Add a new block",
+            footer = modalButton("Dismiss"),
+            size = "m",
+            easyClose = FALSE,
+            fade = TRUE
+          )
+        )
+      })
+
+      observeEvent(input$block_to_add, {
+        # Update stack
+        x[[length(x) + 1]] <- do.call(
+          filter_block,
+          list(vals$blocks[[length(x)]]())
+        )
+        # Call module
+        vals$blocks[[length(x)]] <- generate_server(
+          x[[length(x)]],
+          in_dat = vals$blocks[[length(x) - 1]]
+        )
+
+        # Insert UI after last block
+        insertUI(
+          sprintf(
+            "#%s-%s-block",
+            attr(x, "name"),
+            attr(x[[length(x) - 1]], "name")
+          ),
+          where = "afterEnd",
+          ui = generate_ui(
+            x[[length(x)]],
+            id = attr(x[[length(x)]], "name")
+          )
+        )
+      })
+
+      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 <- function(x, vals) {
+  observeEvent(TRUE, {
+    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]]
+      )
+    }
+  })
+}
+
 #' @param output Shiny output
 #' @param result Block result
 #' @rdname generate_ui
@@ -135,7 +189,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 +204,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")
   )
 

diff --git a/R/stack.R b/R/stack.R
@@ -42,5 +42,5 @@ serve_stack <- function(stack) {
     generate_server(stack)
   }
 
-  shiny::shinyApp(ui, server)
+  shinyApp(ui, server)
 }
diff --git a/R/ui.R b/R/ui.R
@@ -17,8 +17,8 @@ generate_ui.block <- function(x, id, ...) {
 
   stopifnot(...length() == 0L)
 
-  ns <- shiny::NS(
-    shiny::NS(id)(attr(x, "name"))
+  ns <- NS(
+    NS(id)(attr(x, "name"))
   )
 
   fields <- Map(
@@ -29,8 +29,9 @@ generate_ui.block <- function(x, id, ...) {
   )
 
   div_card(
-    title = shiny::h4(attr(x, "name")),
-    do.call(shiny::div, unname(fields)),
+    id = ns("block"),
+    title = h4(attr(x, "name")),
+    do.call(div, unname(fields)),
     ui_code(x, ns),
     ui_output(x, ns)
   )
@@ -42,12 +43,17 @@ generate_ui.stack <- function(x, ...) {
 
   stopifnot(...length() == 0L)
 
-  do.call(
-    shiny::fluidPage,
-    c(
-      lapply(x, generate_ui, id = attr(x, "name")),
-      title = attr(x, "name")
-    )
+  ns <- NS(attr(x, "name"))
+
+  tagList(
+    do.call(
+      fluidPage,
+      c(
+        lapply(x, generate_ui, id = attr(x, "name")),
+        title = attr(x, "name")
+      )
+    ),
+    actionButton(ns("add"), icon("plus"))
   )
 }
 
@@ -61,13 +67,13 @@ ui_input <- function(x, id, name) {
 #' @rdname generate_ui
 #' @export
 ui_input.string_field <- function(x, id, name) {
-  shiny::textInput(input_ids(x, id), name, value(x))
+  textInput(input_ids(x, id), name, value(x))
 }
 
 #' @rdname generate_ui
 #' @export
 ui_input.select_field <- function(x, id, name) {
-  shiny::selectInput(
+  selectInput(
     input_ids(x, id), name, value(x, "choices"), value(x), value(x, "multiple")
   )
 }
@@ -105,7 +111,7 @@ ui_input.variable_field <- function(x, id, name) {
     materialize_variable_field(x)
   )
 
-  shiny::div(
+  div(
     id = paste0(id, "_cont"),
     ui_input(field, id, name)
   )
@@ -114,7 +120,7 @@ ui_input.variable_field <- function(x, id, name) {
 #' @rdname generate_ui
 #' @export
 ui_input.range_field <- function(x, id, name) {
-  shiny::sliderInput(
+  sliderInput(
     input_ids(x, id), name, value(x, "min"), value(x, "max"), value(x)
   )
 }
@@ -142,7 +148,7 @@ ui_input.list_field <- function(x, id, name) {
     map(ui_input, fields, input_ids(x, id), names(fields))
   )
 
-  do.call(shiny::div, args)
+  do.call(div, args)
 }
 
 #' @param session Shiny session
@@ -155,13 +161,13 @@ ui_update <- function(x, session, id, name) {
 #' @rdname generate_ui
 #' @export
 ui_update.string_field <- function(x, session, id, name) {
-  shiny::updateTextInput(session, input_ids(x, id), name, value(x))
+  updateTextInput(session, input_ids(x, id), name, value(x))
 }
 
 #' @rdname generate_ui
 #' @export
 ui_update.select_field <- function(x, session, id, name) {
-  shiny::updateSelectInput(
+  updateSelectInput(
     session, input_ids(x, id), name, value(x, "choices"), value(x)
   )
 }
@@ -173,7 +179,7 @@ ui_update.variable_field <- function(x, session, id, name) {
   ns <- session$ns
   ns_id <- ns(id)
 
-  shiny::removeUI(
+  removeUI(
     selector = paste0("#", ns_id, "_cont", " > div"),
     session = session
   )
@@ -182,7 +188,7 @@ ui_update.variable_field <- function(x, session, id, name) {
     materialize_variable_field(x)
   )
 
-  shiny::insertUI(
+  insertUI(
     selector = paste0("#", ns_id, "_cont"),
     ui = ui_input(field, ns_id, name),
     session = session
@@ -192,7 +198,7 @@ ui_update.variable_field <- function(x, session, id, name) {
 #' @rdname generate_ui
 #' @export
 ui_update.range_field <- function(x, session, id, name) {
-  shiny::updateSliderInput(
+  updateSliderInput(
     session, input_ids(x, id), name, value(x), value(x, "min"), value(x, "max")
   )
 }
@@ -210,7 +216,7 @@ ui_update.list_field <- function(x, session, id, name) {
   ns <- session$ns
   ns_id <- ns(id)
 
-  shiny::removeUI(
+  removeUI(
     selector = paste0("#", ns_id, "_cont", " > div"),
     multiple = TRUE,
     session = session
@@ -221,10 +227,10 @@ ui_update.list_field <- function(x, session, id, name) {
     validate_field
   )
 
-  shiny::insertUI(
+  insertUI(
     selector = paste0("#", ns_id, "_cont"),
     ui = do.call(
-      shiny::tagList,
+      tagList,
       map(
         ui_input, fields, input_ids(x, ns_id), paste0(name, "_", names(fields))
       )
@@ -234,18 +240,18 @@ ui_update.list_field <- function(x, session, id, name) {
 }
 
 div_card <- function(..., title = NULL, footer = NULL) {
-  shiny::div(
+  div(
     class = "panel panel-default",
     style = "margin: 10px",
     if (not_null(title)) {
-      shiny::div(title, class = "panel-heading")
+      div(title, class = "panel-heading")
     },
-    shiny::div(
+    div(
       class = "panel-body",
       ...
     ),
     if (not_null(footer)) {
-      shiny::div(footer, class = "panel-footer")
+      div(footer, class = "panel-footer")
     }
   )
 }
@@ -260,7 +266,7 @@ ui_output <- function(x, ns) {
 #' @rdname generate_ui
 #' @export
 ui_output.block <- function(x, ns) {
-  shiny::verbatimTextOutput(ns("output"))
+  verbatimTextOutput(ns("output"))
 }
 
 #' @rdname generate_ui
@@ -272,5 +278,5 @@ ui_code <- function(x, ns) {
 #' @rdname generate_ui
 #' @export
 ui_code.block <- function(x, ns) {
-  shiny::verbatimTextOutput(ns("code"))
+  verbatimTextOutput(ns("code"))
 }
diff --git a/man/generate_server.Rd b/man/generate_server.Rd