---
title: "4. Extend blockr"
output: rmarkdown::html_vignette
vignette: >
  %\VignetteIndexEntry{4. Extend blockr}
  %\VignetteEngine{quarto::html}
  %\VignetteEncoding{UTF-8}
---

```{r, include = FALSE}
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)
```

```{r packages, message=FALSE, warning=FALSE}
library(shiny)
library(bslib)
library(scoutbaR)
library(blockr.core)
```

```{r custom-plugin-setup, eval = FALSE, echo=FALSE}
chr_ply <- function(x, fun, ..., length = 1L, use_names = FALSE) {
  vapply(x, fun, character(length), ..., USE.NAMES = use_names)
}

#' @keywords internal
lgl_ply <- function(x, fun, ..., length = 1L, use_names = FALSE) {
  vapply(x, fun, logical(length), ..., USE.NAMES = use_names)
}

dropNulls <- function(x) {
  x[!lgl_ply(x, is.null)]
}

blk_icon <- function(category) {
  switch(
    category,
    "data" = "table",
    "file" = "file-import",
    "parse" = "cogs",
    "plot" = "chart-line",
    "transform" = "wand-magic-sparkles",
    "table" = "table"
  )
}

blk_choices <- function() {
  blk_cats <- sort(
    unique(chr_ply(available_blocks(), \(b) attr(b, "category")))
  )

  lapply(blk_cats, \(cat) {
    scout_section(
      label = cat,
      .list = dropNulls(
        unname(
          lapply(available_blocks(), \(choice) {
            if (attr(choice, "category") == cat) {
              scout_action(
                id = attr(choice, "classes")[1],
                label = attr(choice, "name"),
                description = attr(choice, "description"),
                icon = blk_icon(cat)
              )
            }
          })
        )
      )
    )
  })
}
```

## Introduction

In the `Create block` [vignette](https://bristolmyerssquibb.github.io/blockr.core/articles/create-block.html),
you were taught how to design new blocks for blockr. Did you know that we could go much further?

Each major `blockr.core` feature belongs to its own __plugin__, materialized as a shiny module:

- Manage blocks (create/remove, append, ...)
- Manage __links__, that is how blocks are connected. Linking block A to block B means that block A passes its output
data to block B.
- Manage __stacks__ (group blocks together).
- Preserve the __board__ state: save and restore the application state.
- ...

All of the above is fully customizable by yourself, `blockr.core` only provides reasonable defaults to get you started.
`blockr.ui` is an example of full customization.

```{mermaid}
flowchart TD
  subgraph board[board]
    subgraph plugins[plugins]
      subgraph manage_blocks[Manage blocks]
      end
      subgraph manage_links[Manage links]
      end
      subgraph manage_stacks[Manage stacks]
      end
      subgraph preserve_board[Preserve board]
      end
      subgraph generate_code[Generate code]
      end
      subgraph notify_user[Notify user]
      end
      subgraph edit_block[Edit block]
      end
      subgraph edit_stack[Edit stack]
      end
    end
  end
```

## blockr plugins

### Background

__plugins__ are used to customize/enhance UX aspects of the __board__ module, that is the top level module exposed by `blockr.core`.
As stated above, there are a couple of plugins already available in the core, such that when you want to create a custom blockr app,
you can do this on the UI side:

```{r, eval=FALSE}
main_ui <- function(id, board) {
  ns <- NS(id)
  board_ui(
    ns("board"),
    board,
    plugins = board_plugins(
      c(
        "preserve_board",
        "manage_blocks",
        "manage_links",
        "manage_stacks",
        "generate_code",
        "notify_user"
      )
    )
  )
}
```

`board_ui()` expects the namespace of the module, a __board__ object which you can create with `new_board`. The board is, in general, passed
when you call `serve` on the board object such that you can start an app with predefined blocks, links and stacks.
where `board_plugins()` expect a vector of plugin names. It is important to state that at the moment, you can only overwrite existing plugins
but not create new ones. On the server side, you call `board_server()`, the server counter part of `board_ui()` which expects a namespace, the board object
and a subset (or all) of plugins. `callbacks` are to inject code directly into the board server function, as opposed to plugins which are nested submodules.
`parent` is used to __communicate__ application state between all parts of the application in a standardized way.

```{r, eval=FALSE}
main_server <- function(id, board) {
  moduleServer(
    id,
    function(input, output, session) {
      ns <- session$n

      app_state <- reactiveValues(
        # App state for module communication
      )

      # Board module
      board_server(
        "board",
        board,
        plugins = board_plugins(
          c(
            "preserve_board",
            "manage_blocks",
            "manage_links",
            "manage_stacks",
            "generate_code",
            "notify_user"
          )
        ),
        callbacks = list(),
        parent = app_state
      )
    }
  )
}
```

Looking at the `board_plugins()` function:

```{r, eval=FALSE}
board_plugins <- function(which = NULL) {

  plugins <- plugins(
    preserve_board(server = ser_deser_server, ui = ser_deser_ui),
    manage_blocks(server = add_rm_block_server, ui = add_rm_block_ui),
    manage_links(server = add_rm_link_server, ui = add_rm_link_ui),
    manage_stacks(server = add_rm_stack_server, ui = add_rm_stack_ui),
    notify_user(server = block_notification_server),
    generate_code(server = gen_code_server, ui = gen_code_ui),
    edit_block(server = edit_block_server, ui = edit_block_ui),
    edit_stack(server = edit_stack_server, ui = edit_stack_ui)
  )

  if (is.null(which)) {
    return(plugins)
  }

  plugins[which]
}
```

Each plugin is composed of a __server__ and __ui__ part, since they are modules. For instance, the `manage_blocks` plugin is defined as:

```{r, eval=FALSE}
manage_blocks <- function(server, ui) {
  new_plugin(server, ui, validator = expect_null, class = "manage_blocks")
}
```

In the following, we want to create a custom `manage_blocks` plugin that uses the `scoutbaR` package, described in [vignette](https://bristolmyerssquibb.github.io/blockr.core/articles/blocks-registry.html)

### A custom manage_blocks

To create our custom manage blocks, we'll first need to overwrite the `add_rm_block_server` and `add_rm_block_ui` functions. 
For sake of simplicity, on the UI side, we provide a `Add` block button as well as as scoutbar widget (`blk_choices()` is described in the following [vignette](https://bristolmyerssquibb.github.io/blockr.core/articles/blocks-registry.html)):

```{r custom-plugin-ui, eval=FALSE}
add_rm_block_ui <- function(id, board) {
  tagList(
    scoutbar(
      NS(id, "scoutbar"),
      placeholder = "Search for a block",
      actions = blk_choices(),
      theme = "dark",
      showRecentSearch = TRUE
    ),
    actionButton(
      NS(id, "add_block"),
      "New block",
      icon = icon("circle-plus"),
    )
  )
}
```

On the server part, a plugin is always defined as follows (documentation has been left for reference):

```{r, eval=FALSE}
#' Add/remove block module
#'
#' Customizable logic for adding/removing blocks to the board.
#'
#' @param id Namespace ID
#' @param board Reactive values object
#' @param update Reactive value object to initiate board updates
#' @param ... Extra arguments passed from parent scope
#'
#' @return A [shiny::reactiveValues()] object with components `add` and `rm`,
#' where `add` may be `NULL` or a `block` object and `rm` be `NULL` or a string
#' (block ID).
#'
#' @rdname add_rm_block
#' @export
add_rm_block_server <- function(id, board, update, ...) {
  moduleServer(
    id,
    function(input, output, session) {
      # SERVER LOGIC

      NULL
    }
  )
}
```

The server function __signature__ must start with the module id, `board` refers to internal reactive values (read-only), `update` is a reactive value
to send updates to the board module and `...` is used to recover parameters passed from the top level like `parent`. The plugin always returns `NULL`.

We now want to open the `scoutbaR` widget whenever the users clicks on the `Add block` button. We can achieve that by calling `update_scoutbar` passing `revealScoutbar = TRUE`.

```{r, eval=FALSE}
add_rm_block_server <- function(id, board, update, ...) {
  moduleServer(
    id,
    function(input, output, session) {
      # Trigger add block
      observeEvent(
        input$add_block,
        {
          update_scoutbar(
            session,
            "scoutbar",
            revealScoutbar = TRUE
          )
        }
      )

      NULL
    }
  )
}
```

Next step is to manage the user choice, that is when a scoutbar action is selected. We listen to `input$scoutbar` which holds the name of the selected block. Since it is a string, we call `create_block()`, which instantiates a block from its name, and wrap it by `as_blocks()`. Finally, we signal this change to the board by refreshing the `update` reactive value, saying we want to add a new block `list(blocks = list(add = new_blk))`:

```{r custom-plugin-server, eval=FALSE}
add_rm_block_server <- function(id, board, update, ...) {
  moduleServer(
    id,
    function(input, output, session) {
      # Trigger add block
      observeEvent(
        input$add_block,
        {
          update_scoutbar(
            session,
            "scoutbar",
            revealScoutbar = TRUE
          )
        }
      )

      observeEvent(input$scoutbar, {
        new_blk <- as_blocks(create_block(input$scoutbar))
        update(
          list(blocks = list(add = new_blk))
        )
      })

      NULL
    }
  )
}
```

### Register plugins

To register our new plugin, we can defined a custom `board_plugins()` function that calls our own plugin for `manage_blocks()`. For sake of simplicity, all other plugins are omitted:

```{r custom-plugin-helpers, eval=FALSE}
custom_board_plugins <- function(which = NULL) {
  plugins <- plugins(
    manage_blocks(server = add_rm_block_server, ui = add_rm_block_ui)
  )

  if (is.null(which)) {
    return(plugins)
  }

  plugins[which]
}
```

### Testing the new plugin

In the below example, you may click on the `Add block` button and see the scoutbar opening and then select a block.

```{r custom-plugin-app, eval=FALSE}
#| code-fold: true
main_ui <- function(id, board) {
  ns <- NS(id)
  board_ui(
    ns("board"),
    board,
    plugins = custom_board_plugins(
      c(
        "manage_blocks"
      )
    )
  )
}

main_server <- function(id, board) {
  moduleServer(
    id,
    function(input, output, session) {
      ns <- session$n

      # Board module
      board_server(
        "board",
        board,
        plugins = custom_board_plugins(
          c(
            "manage_blocks"
          )
        ),
        callbacks = list()
      )
    }
  )
}

board <- new_board()

ui <- page_fluid(
  main_ui("app", board)
)

server <- function(input, output, session) {
  main_server("app", board)
}

shinyApp(ui, server)
```

::: {.callout-note}
The demo below runs with shinylive. Not all feature may work as expected due to compatibility issues with webR.
:::

```{r shinylive_url, echo = FALSE, results = 'asis'}
# extract the code from knitr code chunks by ID
code <- paste0(
  c(
    "webr::install(\"blockr.core\", repos = \"https://cynkra.github.io/blockr.webR/\")",
    knitr::knit_code$get("packages"),
    knitr::knit_code$get("custom-plugin-setup"),
    knitr::knit_code$get("custom-plugin-ui"),
    knitr::knit_code$get("custom-plugin-server"),
    knitr::knit_code$get("custom-plugin-helpers"),
    knitr::knit_code$get("custom-plugin-app")
  ),
  collapse = "\n"
)

url <- roxy.shinylive::create_shinylive_url(code, header = FALSE)
```

```{r shinylive_iframe, echo = FALSE, eval = TRUE}
shiny::tags$iframe(
  class = "border border-5 rounded shadow-lg",
  src = url,
  style = "zoom: 0.75;",
  width = "100%",
  height = "1100px"
)
```

## Custom UI components

If you'd like to use the board with another UI kit than `bslib` you can create a new method for `board_ui()`. For that,
you'll need a little bit of S3 [knowledge](https://adv-r.hadley.nz/s3.html).

The function signature should contain `id` (module namespace), `x` (board object), and `plugins` to use `blockr.core` plugins.
In the following, we leverage the brand new `shinyNextUI` to power the custom board UI:

```{r custom-board-ui, eval=FALSE}
board_ui.custom_board <- function(id, x, plugins = list(), ...) {
  plugins <- as_plugins(plugins)
  div(
    id = paste0(id, "_board"),
    board_ui(id, plugins[["manage_blocks"]], x),
    div(
      id =  paste0(id, "_blocks"),
      block_ui(id, x)
    )
  )
}
```

We have to customize the `block_ui` too. Overall, we leverage the `shinyNextUI::card` component to create the block layout:

```{r custom-block-ui, eval=FALSE}
get_block_registry <- function(x) {
  stopifnot(is_block(x))
  available_blocks()[[strsplit(attr(x, "ctor"), "new_")[[1]][2]]]
}

block_ui.custom_board <- function(id, x, blocks = NULL, ...) {
  block_card <- function(x, id, ns) {
    id <- paste0("block_", id)

    blk_info <- get_block_registry(x)

    div(
      class = "m-2",
      id = ns(id),
      shinyNextUI::card(
        variant = "bordered",
        shinyNextUI::card_header(
          className = "d-flex justify-content-between",
          icon(blk_icon(attr(blk_info, "category"))),
          sprintf(
            "Block: %s (id: %s)",
            attr(blk_info, "name"),
            gsub("block_", "", id)
          ),
          shinyNextUI::tooltip(
            icon("info-circle"),
            content = tagList(
              p(
              icon("lightbulb"),
              "How to use this block?",
              ),
              p(attr(blk_info, "description"), ".")
            )
          )
        ),
        shinyNextUI::divider(),
        shinyNextUI::card_body(
          expr_ui(ns(id), x),
          block_ui(ns(id), x)
        ),
        shinyNextUI::divider(),
        shinyNextUI::card_footer(
          sprintf(
            "Type: %s; Package: %s",
            attr(blk_info, "category"),
            attr(blk_info, "package")
          )
        )
      )
    )
  }

  stopifnot(is.character(id) && length(id) == 1L)

  if (is.null(blocks)) {
    blocks <- board_blocks(x)
  } else if (is.character(blocks)) {
    blocks <- board_blocks(x)[blocks]
  }

  stopifnot(is_blocks(blocks))

  tagList(
    Map(
      block_card,
      blocks,
      names(blocks),
      MoreArgs = list(ns = NS(id)),
      USE.NAMES = FALSE
    )
  )
}
```

Notice the use of few `blockr.core` helpers along the way:

- `board_blocks()` to extract and validate the blocks of a board.
- `is_blocks()` check whether an object correspond to a list of blocks.
- `get_block_registry()` to get the current block metadata from the [registry](https://bristolmyerssquibb.github.io/blockr.core/articles/blocks-registry.html).

`add_rm_block_ui()` now leverages `shinyNextUI::actionButton`:

```{r custom-plugin-ui-nextui, eval=FALSE}
add_rm_block_ui <- function(id, board) {
  tagList(
    scoutbar(
      NS(id, "scoutbar"),
      placeholder = "Search for a block",
      actions = blk_choices(),
      theme = "dark",
      showRecentSearch = TRUE
    ),
    shinyNextUI::actionButton(
      NS(id, "add_block"),
      "New block",
      icon = icon("circle-plus"),
    )
  )
}
```

Since `blockr.core` blocks utilizes `shiny`/`bslib` UI, you'd also have to rewrite the UI and/or server part whenever necessary. This [vignette](https://bristolmyerssquibb.github.io/blockr.core/articles/create-block.html) provides a starting point to authoring blocks.

As a final step, when you call `new_board()` don't forget to add it the `custom_board` class so that the custom S3 methods are invoked.

```{r custom-ui-app, eval=FALSE}
#| code-fold: true
board <- new_board(class = "custom_board")

ui <- nextui_page(
  board_ui(
    "board",
    board,
    plugins = custom_board_plugins(
      c(
        "manage_blocks"
      )
    )
  ) 
)

server <- function(input, output, session) {
  board_server(
    "board",
    board,
    plugins = custom_board_plugins(
      c(
        "manage_blocks"
      )
    ),
    callbacks = list()
  )
}

shinyApp(ui, server)
```

::: {.callout-note}
The demo below runs with shinylive. Not all feature may work as expected due to compatibility issues with webR.
:::

```{r shinylive2_url, echo = FALSE, results = 'asis'}
# extract the code from knitr code chunks by ID
code <- paste0(
  c(
    "webr::install(\"blockr.core\", repos = \"https://cynkra.github.io/blockr.webR/\")",
    "library(shiny)",
    "library(scoutbaR)",
    "library(blockr.core)",
    "library(shinyNextUI)",
    knitr::knit_code$get("custom-plugin-setup"),
    knitr::knit_code$get("custom-plugin-ui-nextui"),
    knitr::knit_code$get("custom-plugin-server"),
    knitr::knit_code$get("custom-plugin-helpers"),
    knitr::knit_code$get("custom-block-ui"),
    knitr::knit_code$get("custom-board-ui"),
    knitr::knit_code$get("custom-ui-app")
  ),
  collapse = "\n"
)

url <- roxy.shinylive::create_shinylive_url(code, header = FALSE)
```

```{r shinylive2_iframe, echo = FALSE, eval = TRUE}
shiny::tags$iframe(
  class = "border border-5 rounded shadow-lg",
  src = url,
  style = "zoom: 0.75;",
  width = "100%",
  height = "1100px"
)
```

## Customize board options

TBD