---
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

`blockr` can be extended in 3 main ways. The first way is to create new blocks, as described in the `Create block` [vignette](https://bristolmyerssquibb.github.io/blockr.core/articles/create-block.html). The second way is to change the behavior at __board__ level through the __plugin__ system. Finally we can customize the UI library, as we will in the last section.

## Plugins

Most major features of a __board__ are implemented through what we call __plugins__. A board of a given class, such as `"board"` (the basic legacy board) or `"dock_board"` (the board used by `blockr::run_app()`) supports a given set of __plugins__, implemented using shiny modules. Users can override the ui and server functions of these modules from the outside if they wish to tweak the display and logic of these features, as we'll show further below.

### Available plugins

The legacy board supports the following plugins :

- `manage_blocks()`: Implements the way __blocks__ are created, removed, appened...
- `manage_links()`: Implements how __blocks__ are connected. Linking __block__ A to __block__ B means that __block__ A passes its output data to __block__ B.
- `manage_stacks()`: Implements how __blocks__ can be grouped using __stacks__.
- `preserve_board()`: Implements how __boards__ can be saved and restored.
- `generate_code()`: Implements the way the data manipulation code executed by the __blocks__ is displayed to the user.
- `notify_user()`: Implements how notifications and warnings are relayed to the user.
- `edit_block()`: Implements how a block attributes such as titles are processed and rendered.
- `edit_stack()`: Implements how a stack attributes such as names are processed and rendered.

### Override a plugin's server and ui functions

We will work from an example, we want to modify the `manage_blocks()` plugin to use the `scoutbaR` package to search for blocks to add.

By default `manage_blocks()` uses `manage_blocks_ui()` and `manage_blocks_server()`, a good workflow is to start from those and implement our modifications.

```r
# manage_blocks_ui
function(id, board) {
  tagList(
    actionButton(
      NS(id, "add_block"),
      "Add block",
      icon = icon("circle-plus"),
      class = "btn-success"
    ),
    actionButton(
      NS(id, "rm_block"),
      "Remove block",
      icon = icon("circle-minus"),
      class = "btn-danger"
    )
  )
}
```

For simplicity let's assume we also want to drop the "Remove block" button, our new ui becomes: 

```r
new_manage_blocks_ui <- function(id, board) {
  tagList(
    scoutbaR::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"),
    )
  )
}
```

`blk_choices()` is a list of scoutbar actions, the details are not relevant here but the definition is provided below for information.

<details>

```r
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)
              )
            }
          })
        )
      )
    )
  })
}

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

chr_ply <- function(x, fun, ..., length = 1L, use_names = FALSE) {
  vapply(x, fun, character(length), ..., USE.NAMES = use_names)
}

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)]
}
```
</details>

In the same fashion we override the server function to handle the new logic.

We end up with the following server function, see additional explanations below.

```{r custom-plugin-server, eval=FALSE}
new_manage_blocks_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
    }
  )
}
```

The server function's __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`.

In the first observer we open the `scoutbaR` widget whenever the users clicks on the `Add block` button. We can achieve that by calling `update_scoutbar` passing `revealScoutbar = TRUE`.

In the second observer we listen to `input$scoutbar` which holds the name of the selected block, and use to create a "blocks" object with `create_block()` and `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))`.

### Putting everything together

Once we have updated ui and server functions we can use the updated plugin by defining new main ui and server functions around them.

```{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$ns

      # Board module
      board_server(
        "board",
        board,
        plugins = plugins(
          manage_blocks(server = new_manage_blocks_server, ui = new_manage_blocks_ui)
        ),
        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"
)
```