shinyjs or write custom JavaScript code.")
+```
-## The renderUI case
+## renderUI and uiOutput {-}
- `renderUI()` and `uiOutput` most famous way to **render** any HTML block from the **server**
- `update____` and `toggle` tools are component-specific, only target the element to modify
-- `renderUI()` re-renders the block each time, implies poor performance in complex apps
+- `renderUI()` re-renders **the whole block** each time an associated _reactive dependency_ is invalidated.
+
+- Results in **poor performances** in complex apps.
+
+## renderUI and uiOutput Example Code {-}
+
+```{r}
+#| echo: false
+
+create_note(text = "We used do.call to execute dropdownMenu in order to update the number of messages in the menu bar.")
+```
+
+```r
+library(shiny)
+library(bs4Dash)
+
+new_message <- data.frame(
+ message = "New message",
+ from = "Paul",
+ time = "yesterday",
+ color = "success"
+)
+
+shinyApp(
+ ui = dashboardPage(
+ dark = FALSE,
+ header = dashboardHeader(
+ rightUi = uiOutput("messages", container = tags$li)
+ ),
+ sidebar = dashboardSidebar(),
+ controlbar = dashboardControlbar(),
+ footer = dashboardFooter(),
+ title = "test",
+ body = dashboardBody(actionButton("add", "Add message"))
+ ),
+ server = function(input, output) {
+
+ messages <- reactiveValues(
+ items = data.frame(
+ message = rep("A message", 10),
+ from = LETTERS[1:10],
+ time = rep("yesterday", 10),
+ color = rep("success", 10)
+ )
+ )
+
+ observeEvent(input$add, {
+ messages$items <- rbind(messages$items, new_message)
+ })
+
+ output$messages <- renderUI({
+ lapply(seq_len(nrow(messages$items)), function(i) {
+ items_i <- messages$items[i, ]
+ bs4Dash::messageItem(
+ message = items_i$message,
+ from = items_i$from,
+ time = items_i$time,
+ color = items_i$color
+ )
+ }) |>
+ c(badgeStatus = "danger",
+ type = "messages") |>
+ do.call(what = "dropdownMenu")
+ })
+ }
+)
+```
+
+## renderUI and uiOutput Example App {-}
+
+
+
+## renderUI and uiOutput Example HTML {-}
+
+```{r}
+items = data.frame(
+ message = rep("A message", 2),
+ from = LETTERS[1:2],
+ time = rep("yesterday", 2),
+ color = rep("success", 2)
+)
+
+lapply(seq_len(nrow(items)), function(i) {
+ items_i <- items[i, ]
+ bs4Dash::messageItem(
+ message = items_i$message,
+ from = items_i$from,
+ time = items_i$time,
+ color = items_i$color
+ )
+}) |>
+ c(badgeStatus = "danger",
+ type = "messages") |>
+ do.call(what = getExportedValue("bs4Dash", "dropdownMenu")) |>
+ as.character() |>
+ cat()
+```
+
+
+## insertUI Process {-}
+
+1. `insertUI` sends a R message through `session$sendInsertUI`, via the **websocket**.
+
+```r
+insertUI <- function(selector,
+ where = c("beforeBegin", "afterBegin",
+ "beforeEnd", "afterEnd"),
+ ui,
+ multiple = FALSE,
+ immediate = FALSE,
+ session = getDefaultReactiveDomain()) {
+
+ force(selector)
+ force(ui)
+ force(session)
+ force(multiple)
+ if (missing(where)) where <- "beforeEnd"
+ where <- match.arg(where)
+
+ callback <- function() {
+ session$sendInsertUI(selector = selector,
+ multiple = multiple,
+ where = where,
+ content = processDeps(ui, session))
+ }
+
+ if (!immediate) session$onFlushed(callback, once = TRUE)
+ else callback()
+}
+```
+
+## insertUI Process {-}
+
+2. But before, `shiny:::processDeps(ui, session)` returns a list with **rendered HTML** and **dependency** objects.
+
+```r
+processDeps <- function(tags, session) {
+ tags <- utils::getFromNamespace("tagify", "htmltools")(tags)
+ ui <- takeSingletons(tags, session$singletons, desingleton = FALSE)$ui
+ ui <- surroundSingletons(ui)
+ dependencies <- lapply(
+ resolveDependencies(findDependencies(ui, tagify = FALSE)),
+ createWebDependency
+ )
+ names(dependencies) <- NULL
+
+ list(
+ html = doRenderTags(ui),
+ deps = dependencies
+ )
+}
+```
+
+## insertUI Process {-}
+
+3. Sent html by Json to Javascript.
+
+```r
+ShinySession <- R6Class(
+ 'ShinySession',
+ private = list(
+ sendInsertUI = function(selector, multiple, where, content) {
+ private$sendMessage(
+ `shiny-insert-ui` = list(
+ selector = selector,
+ multiple = multiple,
+ where = where,
+ content = content
+ )
+ )
+ },
+ sendMessage = function(...) {
+ # This function is a wrapper for $write
+ msg <- list(...)
+ if (any_unnamed(msg)) {
+ stop("All arguments to sendMessage must be named.")
+ }
+ private$write(toJSON(msg))
+ }
+ )
+)
+```
+
+## insertUI Process {-}
+
+4. The `MessageHandler`
+
+ - Checks whether the provided selector has multiple DOM elements
+ - Calls `renderContent(html, el, dependencies)` which triggers
+ - `renderHtml(html, el, dependencies)` processes the provided HTML
+
+ - Renders all given **dependencies** into the page’s head.
+ - **Inserts the HTML** into the page at the position provided in the insertUI where parameter (`insertAdjacentHTML`).
+ - Initializes any **input binds** them to the scope.
+ - **Sends** the value to the server _(to invalidate output/observers)_ and **connects/bounds** the outputs.
+
+```javascript
+
+addMessageHandler('shiny-insert-ui', function(message) {
+ var targets = $(message.selector);
+ if (targets.length === 0) {
+ // render the HTML and deps to a null target, so
+ // the side-effect of rendering the deps, singletons,
+ // and still occur
+ console.warn('The selector you chose ("' + message.selector +
+ '") could not be found in the DOM.');
+ exports.renderHtml(message.content.html, $([]), message.content.deps);
+ } else {
+ targets.each(function (i, target) {
+ exports.renderContent(target, message.content, message.where);
+ return message.multiple;
+ });
+ }
+ });
+
+```
-- Book examples
+## insertUI vs renderUI {-}
+
+
+| **Feature** | `renderUI` | `insertUI` |
+|-------------------------|-----------------------------------------------------------------------------|------------------------------------------------------------------------------|
+| **Mechanism** | Re-renders the *entire* UI component and replaces it. | Inserts *new* UI elements _without_ modifying existing ones. |
+| **Performance** | Slower (reprocesses all HTML/dependencies every time). | Faster (only processes new content). |
+| **DOM Updates** | Forces full reflow (replaces container content). | Uses `insertAdjacentHTML` (minimal reflow). |
+| **Dependencies** | Re-resolves dependencies (CSS/JS) on every render. | Processes dependencies once for new content. |
+| **Use Case** | When the *entire* UI component must be rebuilt. | For *incremental* updates (adding/removing elements). |
+| **State Preservation** | May reset inputs/outputs (re-initializes everything). | Preserves existing states (only binds new elements). |
+
+## insertUI Example Code {-}
+
+```r
+library(shiny)
+library(bs4Dash)
+
+ServerFunction = function(input, output, session) {
+
+ observeEvent(input$add, {
+ insertUI(
+ selector = ".dropdown-menu > .dropdown-item .dropdown-header",
+ where = "afterEnd", #After the selector element itself
+ ui = messageItem(
+ message = paste("message", input$add),
+ image = dashboardUserImage,
+ from = "Divad Nojnarg",
+ time = "today",
+ color = "success"
+ )
+ )
+ })
+}
+```
-## Other Shiny handlers
+```{r}
+bs4Dash::dropdownMenu(badgeStatus = "danger",
+ type = "messages") |>
+ as.character() |>
+ cat()
+```
-### insertUI case
+## insertUI Example Code {-}
+
+```r
+library(shiny)
+library(bs4Dash)
+
+ServerFunction = function(input, output, session) {
+
+ observeEvent(input$add, {
+ insertUI(
+ selector = ".dropdown-menu > .dropdown-item .dropdown-header",
+ where = "afterEnd", #After the selector element itself
+ ui = messageItem(
+ message = paste("message", input$add),
+ image = dashboardUserImage,
+ from = "Divad Nojnarg",
+ time = "today",
+ color = "success"
+ )
+ )
+ })
+}
+```
+
+```{r}
+bs4Dash::messageItem(message = paste("message", 1),
+ image = "https://adminlte.io/themes/v3/dist/img/user2-160x160.jpg",
+ from = "Divad Nojnarg",
+ time = "today",
+ color = "success") |>
+ as.character() |>
+ cat()
+```
-- `insertUI` sends a R message through `session$sendInsertUI`, via the **websocket**
-- content is processed by `shiny:::processDeps()`
+## insertUI Example App {-}
-- Finds and resolves any HTML dependency
+
-- For each dependency, makes sure the corresponding files can be accessed on the server with `createWebDependency()` and `addResourcePath()`
-- Returns a list of the HTML element and dependencies. The HTML will be accessed by `message.content.html` and dependencies by `message.content.deps`
+## insertUI Example App (Updated Selector) {-}
-### Example
+```{r}
+#| echo: false
-- If the item is inserted, the item counter as well as the dropdown text are not
+create_note(text = "In the original example we were missing the division line between \"You have 0 messages\" and new message. selector = \".dropdown-menu > .dropdown-divider\"")
+```
-- We may fix that by adding extra `insertUI()` and `removeUI()` to replace those parts
+
-- order matters: ensure that **remove** happens before **insert**
-- issue: a lot of server code!
+## Updating counters Code {-}
+
+```{r}
+#| echo: false
+
+create_note(text = "To update elements we need to remove them (using removeUI) and then inserting them back. Make sure that the observers for removeUI have a higher priority")
+```
+
+```r
+ServerFunction <- function(input, output, session) {
+
+ observeEvent(input$add, {
+ # remove old badge
+ removeUI(selector = ".badge-danger.navbar-badge")
+
+ # remove old text counter
+ removeUI(selector = ".dropdown-item.dropdown-header")
+
+ }, priority = 1)
+
+
+
+ observeEvent(input$add, {
+
+ # insert new badge
+ insertUI(
+ selector = "[data-toggle=\"dropdown\"]",
+ where = "beforeEnd",
+ ui = tags$span(
+ class = "badge badge-danger navbar-badge",
+ input$add
+ )
+ )
+
+ # insert new text counter
+ insertUI(
+ selector = ".dropdown-menu",
+ where = "afterBegin",
+ ui = tags$span(
+ class = "dropdown-item dropdown-header",
+ sprintf("%s Items", input$add)
+ )
+ )
+
+ # Insert message item
+ insertUI(
+ selector = ".dropdown-menu > .dropdown-divider",
+ where = "afterEnd",
+ ui = messageItem(
+ message = paste("message", input$add),
+ image = dashboardUserImage,
+ from = "Divad Nojnarg",
+ time = "today",
+ color = "success"
+ )
+ )
+ })
+
+}
+```
+
-- issue: setting priorities in `observeEvent()` is a rather bad smell of poorly designed Shiny app
+## Updating counters App {-}
-## Custom handlers
+
-### Theory
+## Custom handlers Diagram{-}
-**session$sendCustomMessage(type, message)**. It works by pairing with the JS method **Shiny.AddCustomMessageHandler**, tightly linked by the type parameter
+1. **R** sends a message using `session$sendCustomMessage(type, message)`.
-- example
+2. **JS** apply a defined action based on `Shiny.AddCustomMessageHandler`.
-### Toward custom UI managment functions
+
-- we go back to the `bs4Dash::dropdownMenu()` issue
+## Custom handlers Example Code {-}
+
+**add-message-item.js**
+
+```javascript
+$(function() {
+ Shiny.addCustomMessageHandler('add-message-item', function(message) {
+ // since we do not re-render the dropdown, we must update its item counter
+ var $items = $('.dropdown-menu').find('.dropdown-item').length;
+ $('.dropdown-item.dropdown-header').html($items + ' Items');
+ $('.nav-item.dropdown').find('.navbar-badge').html($items);
+ // convert string to HTML
+ var itemTag = $.parseHTML(message)[0];
+ $(itemTag).insertAfter($('.dropdown-item.dropdown-header'));
+ });
+});
+```
+
+## Custom handlers Example Code {-}
+
+**app.R**
+
+```r
+library(shiny)
+library(bs4Dash)
+
+insertMessageItem <- function(item, session = shiny::getDefaultReactiveDomain()) {
+ session$sendCustomMessage("add-message-item", message = as.character(item))
+}
+
+dropdownDeps <- function(){
+ htmltools::htmlDependency(name = "bs4-dropdown",
+ version = "1.0.0",
+ src = c(file = "."),
+ script = "add-message-item.js")
+}
+
+ServerFunction <- function(input, output, session) {
+
+ observeEvent(input$add, {
+ insertMessageItem(
+ messageItem(
+ message = paste("message", input$add),
+ image = "https://adminlte.io/themes/v3/dist/img/user2-160x160.jpg",
+ from = "Divad Nojnarg",
+ time = "today",
+ color = "success"
+ )
+ )
+ })
+
+}
+```
-- create `insertMessageItem` with two parameters
- - **item**, the HTML element we want to insert in the DOM
- - **session**, used to send a message to JavaScript with `session$sendCustomMessage`
-- We give it a **type**, that is `add-message-item`, to be able to identify it from JavaScript with `Shiny.addCustomMessageHandler`
-- some JS stuff
-- This solution significantly lightens the server code since everything may be done on the JS side in one step
+## Custom handlers Example App {-}
-### A chat system
-- book example
+
## Meeting Videos
diff --git a/DESCRIPTION b/DESCRIPTION
index 040c47b..25bbbb7 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -15,6 +15,7 @@ Imports:
bookdown,
bs4Dash,
DiagrammeR,
+ htmltools,
httpuv,
jsonlite,
purrr,
diff --git a/examples/chapter-15/01-handwriting-recognition/app.R b/examples/chapter-15/01-handwriting-recognition/app.R
new file mode 100644
index 0000000..14f1b14
--- /dev/null
+++ b/examples/chapter-15/01-handwriting-recognition/app.R
@@ -0,0 +1,78 @@
+library(shiny)
+
+dropdownDeps <- function(){
+ htmltools::htmlDependency(name = "handwriting",
+ version = "1.0.0",
+ src = c(file = "."),
+ script = "handwriting.canvas.js")
+}
+
+
+ui = fluidPage(
+ dropdownDeps(),
+ htmltools::HTML('
+
+ result:
+ + + +