Support Shiny UI inside of chat_append() and markdown_stream() (#29)

* Support Shiny UI inside of chat_append() and markdown_stream()

* Bugfix

* Update CSS/JS assets

* Update snapshot

* Make it more explicit what process_ui() is doing

* Add documentation

* elmer -> ellmer

* Update output_markdown_stream() docs

* Add some snapshot test for static rendering

* Apply suggestions from code review

Co-authored-by: Garrick Aden-Buie <[email protected]>

* usethis::use_import_from()

* Update news

---------

Co-authored-by: Garrick Aden-Buie <[email protected]>

Author: cpsievert

DESCRIPTION

@@ -8,14 +8,15 @@ Authors@R: c(
   )
 Description: Provides a scrolling chat interface with multiline input, suitable
     for creating chatbot apps based on Large Language Models (LLMs). Designed to
-    work particularly well with the 'elmer' R package for calling LLMs.
+    work particularly well with the 'ellmer' R package for calling LLMs.
 License: MIT + file LICENSE
 URL: https://github.com/jcheng5/shinychat, https://jcheng5.github.io/shinychat/
 BugReports: https://github.com/jcheng5/shinychat/issues
 Imports:
     bslib,
     coro,
     htmltools,
+    jsonlite,
     promises (>= 1.3.2),
     rlang,
     shiny (>= 1.10.0)

NAMESPACE

@@ -7,6 +7,8 @@ export(chat_ui)
 export(markdown_stream)
 export(output_markdown_stream)
 importFrom(coro,async)
+importFrom(htmltools,HTML)
 importFrom(htmltools,css)
 importFrom(htmltools,tag)
+importFrom(rlang,"%||%")
 importFrom(shiny,getDefaultReactiveDomain)

NEWS.md

@@ -1,7 +1,8 @@
 # shinychat (development version)
 
-* Added a new `chat_clear()` function to clear the chat of all messages. (#25)
 * Added new `output_markdown_stream()` and `markdown_stream()` functions to allow for streaming markdown content to the client. This is useful for showing Generative AI responses in real-time in a Shiny app, outside of a chat interface. (#23)
+* Both `chat_ui()` and `output_markdown_stream()` now support arbirary Shiny UI elements inside of messages. This allows for gathering input from the user (e.g., `selectInput()`), displaying of rich output (e.g., `{htmlwidgets}` like `{plotly}`), and more. (#1868)
+* Added a new `chat_clear()` function to clear the chat of all messages. (#25)
 
 # shinychat 0.1.1
 

R/chat.R

@@ -4,10 +4,6 @@
 # trimming of the message history to fit within the context window; these
 # are left for the caller to handle in the R version.
 
-#' @importFrom htmltools tag css
-#' @importFrom coro async
-NULL
-
 chat_deps <- function() {
   htmltools::htmlDependency(
     "shinychat",
@@ -20,36 +16,48 @@ chat_deps <- function() {
       list(src = "text-area/textarea-autoresize.js", type = "module")
     ),
     stylesheet = c(
-      "chat/chat.css", 
+      "chat/chat.css",
       "markdown-stream/markdown-stream.css",
       "text-area/textarea-autoresize.css"
     )
   )
 }
 
 #' Create a chat UI element
-#' 
+#'
 #' @description
 #' Inserts a chat UI element into a Shiny UI, which includes a scrollable
 #' section for displaying chat messages, and an input field for the user to
 #' enter new messages.
-#' 
+#'
 #' To respond to user input, listen for `input$ID_user_input` (for example, if
 #' `id="my_chat"`, user input will be at `input$my_chat_user_input`), and use
 #' [chat_append()] to append messages to the chat.
 #'
 #' @param id The ID of the chat element
 #' @param ... Extra HTML attributes to include on the chat element
 #' @param messages A list of messages to prepopulate the chat with. Each
-#'   message can be a string or a named list with `content` and `role` fields.
+#'   message can be one of the following:
+#' 
+#'   * A string, which is interpreted as markdown and rendered to HTML on 
+#'     the client.
+#'     * To prevent interpreting as markdown, mark the string as 
+#'       [htmltools::HTML()].
+#'   * A UI element.
+#'     * This includes [htmltools::tagList()], which take UI elements 
+#'       (including strings) as children. In this case, strings are still 
+#'       interpreted as markdown as long as they're not inside HTML.
+#'   * A named list of `content` and `role`. The `content` can contain content 
+#'     as described above, and the `role` can be "assistant" or "user".
+#'       
 #' @param placeholder The placeholder text for the chat's user input field
 #' @param width The CSS width of the chat element
 #' @param height The CSS height of the chat element
 #' @param fill Whether the chat element should try to vertically fill its
 #'   container, if the container is
 #'   [fillable](https://rstudio.github.io/bslib/articles/filling/index.html)
 #' @returns A Shiny tag object, suitable for inclusion in a Shiny UI
-#' 
+#'
 #' @examplesIf interactive()
 #' library(shiny)
 #' library(bslib)
@@ -62,7 +70,7 @@ chat_deps <- function() {
 #' server <- function(input, output, session) {
 #'   observeEvent(input$chat_user_input, {
 #'     # In a real app, this would call out to a chat model or API,
-#'     # perhaps using the 'elmer' package.
+#'     # perhaps using the 'ellmer' package.
 #'     response <- paste0(
 #'       "You said:\n\n",
 #'       "<blockquote>",
@@ -91,26 +99,30 @@ chat_ui <- function(
   }
 
   message_tags <- lapply(messages, function(x) {
-    if (is.character(x)) {
-      x <- list(content = x, role = "assistant")
-    } else if (is.list(x)) {
-      if (!("content" %in% names(x))) {
-        rlang::abort("Each message must have a 'content' key.")
-      }
-      if (!("role" %in% names(x))) {
-        rlang::abort("Each message must have a 'role' key.")
-      }
-    } else {
-      rlang::abort("Each message must be a string or a named list.")
+    role <- "assistant"
+    content <- x
+    if (is.list(x) && ("content" %in% names(x))) {
+      content <- x[["content"]]
+      role <- x[["role"]] %||% role
     }
 
-    if (isTRUE(x[["role"]] == "user")) {
+    if (isTRUE(role == "user")) {
       tag_name <- "shiny-user-message"
     } else {
       tag_name <- "shiny-chat-message"
     }
 
-    tag(tag_name, list(content = x[["content"]]))
+    ui <- with_current_theme({
+      htmltools::renderTags(content)
+    })
+
+    tag(
+      tag_name,
+      rlang::list2(
+        content = ui[["html"]],
+        ui[["dependencies"]],
+      )
+    )
   })
 
   res <- tag("shiny-chat-container", rlang::list2(
@@ -131,36 +143,47 @@ chat_ui <- function(
     res <- bslib::as_fill_carrier(res)
   }
 
-  res
+  tag_require(res, version = 5, caller = "chat_ui")
 }
 
 #' Append an assistant response (or user message) to a chat control
 #'
 #' @description
-#' The `chat_append` function appends a message to an existing chat control. The
+#' The `chat_append` function appends a message to an existing [chat_ui()]. The
 #' `response` can be a string, string generator, string promise, or string
-#' promise generator (as returned by the 'elmer' package's `chat`, `stream`,
+#' promise generator (as returned by the 'ellmer' package's `chat`, `stream`,
 #' `chat_async`, and `stream_async` methods, respectively).
-#' 
+#'
 #' This function should be called from a Shiny app's server. It is generally
 #' used to append the model's response to the chat, while user messages are
 #' added to the chat UI automatically by the front-end. You'd only need to use
 #' `chat_append(role="user")` if you are programmatically generating queries
 #' from the server and sending them on behalf of the user, and want them to be
 #' reflected in the UI.
-#' 
+#'
 #' # Error handling
-#' 
+#'
 #' If the `response` argument is a generator, promise, or promise generator, and
 #' an error occurs while producing the message (e.g., an iteration in
 #' `stream_async` fails), the promise returned by `chat_append` will reject with
 #' the error. If the `chat_append` call is the last expression in a Shiny
 #' observer, Shiny will see that the observer failed, and end the user session.
 #' If you prefer to handle the error gracefully, use [promises::catch()] on the
 #' promise returned by `chat_append`.
-#' 
+#'
 #' @param id The ID of the chat element
-#' @param response The message or message stream to append to the chat element
+#' @param response The message or message stream to append to the chat element.
+#'   The actual message content can one of the following:
+#'   
+#'   * A string, which is interpreted as markdown and rendered to HTML on 
+#'     the client.
+#'     * To prevent interpreting as markdown, mark the string as 
+#'       [htmltools::HTML()].
+#'   * A UI element.
+#'     * This includes [htmltools::tagList()], which take UI elements 
+#'       (including strings) as children. In this case, strings are still 
+#'       interpreted as markdown as long as they're not inside HTML.
+#' 
 #' @param role The role of the message (either "assistant" or "user"). Defaults
 #'   to "assistant".
 #' @param session The Shiny session object
@@ -175,7 +198,7 @@ chat_ui <- function(
 #' library(coro)
 #' library(bslib)
 #' library(shinychat)
-#' 
+#'
 #' # Dumbest chatbot in the world: ignores user input and chooses
 #' # a random, vague response.
 #' fake_chatbot <- async_generator(function(input) {
@@ -187,42 +210,31 @@ chat_ui <- function(
 #'     "Can you elaborate on that?",
 #'     "Interesting question! Let's examine thi... **See more**"
 #'   )
-#' 
+#'
 #'   await(async_sleep(1))
 #'   for (chunk in strsplit(sample(responses, 1), "")[[1]]) {
 #'     yield(chunk)
 #'     await(async_sleep(0.02))
 #'   }
 #' })
-#' 
+#'
 #' ui <- page_fillable(
 #'   chat_ui("chat", fill = TRUE)
 #' )
-#' 
+#'
 #' server <- function(input, output, session) {
 #'   observeEvent(input$chat_user_input, {
 #'     response <- fake_chatbot(input$chat_user_input)
 #'     chat_append("chat", response)
 #'   })
 #' }
-#' 
+#'
 #' shinyApp(ui, server)
-#' 
+#'
 #' @export
 chat_append <- function(id, response, role = c("assistant", "user"), session = getDefaultReactiveDomain()) {
   role <- match.arg(role)
-  if (is.character(response)) {
-    # string => generator
-    stream <- coro::gen(yield(response))
-  } else if (promises::is.promising(response)) {
-    # promise => async generator
-    stream <- coro::gen(yield(response))
-  } else if (inherits(response, "coro_generator_instance")) {
-    # Already a generator (sync or async)
-    stream <- response
-  } else {
-    rlang::abort("Unexpected message type; chat_append() expects a string, a string generator, a string promise, or a string promise generator")
-  }
+  stream <- as_generator(response)
   chat_append_stream(id, stream, role = role, session = session)
 }
 
@@ -250,13 +262,13 @@ chat_append <- function(id, response, role = c("assistant", "user"), session = g
 #' @returns Returns nothing (\code{invisible(NULL)}).
 #'
 #' @importFrom shiny getDefaultReactiveDomain
-#' 
+#'
 #' @examplesIf interactive()
 #' library(shiny)
 #' library(coro)
 #' library(bslib)
 #' library(shinychat)
-#' 
+#'
 #' # Dumbest chatbot in the world: ignores user input and chooses
 #' # a random, vague response.
 #' fake_chatbot <- async_generator(function(id, input) {
@@ -268,7 +280,7 @@ chat_append <- function(id, response, role = c("assistant", "user"), session = g
 #'     "Can you elaborate on that?",
 #'     "Interesting question! Let's examine thi... **See more**"
 #'   )
-#' 
+#'
 #'   # Use low-level chat_append_message() to temporarily set a progress message
 #'   chat_append_message(id, list(role = "assistant", content = "_Thinking..._ "))
 #'   await(async_sleep(1))
@@ -280,20 +292,20 @@ chat_append <- function(id, response, role = c("assistant", "user"), session = g
 #'     await(async_sleep(0.02))
 #'   }
 #' })
-#' 
+#'
 #' ui <- page_fillable(
 #'   chat_ui("chat", fill = TRUE)
 #' )
-#' 
+#'
 #' server <- function(input, output, session) {
 #'   observeEvent(input$chat_user_input, {
 #'     response <- fake_chatbot("chat", input$chat_user_input)
 #'     chat_append("chat", response)
 #'   })
 #' }
-#' 
+#'
 #' shinyApp(ui, server)
-#' 
+#'
 #' @export
 chat_append_message <- function(id, msg, chunk = TRUE, operation = c("append", "replace"), session = getDefaultReactiveDomain()) {
   if (!is.list(msg)) {
@@ -320,21 +332,31 @@ chat_append_message <- function(id, msg, chunk = TRUE, operation = c("append", "
     chunk_type <- NULL
   }
 
-  if (identical(class(msg[["content"]]), "character")) {
-    content_type <- "markdown"
-  } else {
-    content_type <- "html"
-  }
+  content <- msg[["content"]]
+  is_html <- inherits(content, c("shiny.tag", "shiny.tag.list", "html", "htmlwidget"))
+  content_type <- if (is_html) "html" else "markdown"
 
   operation <- match.arg(operation)
   if (identical(operation, "replace")) {
     operation <- NULL
   }
 
+  if (is.character(content)) {
+    # content is most likely a string, so avoid overhead in that case
+    ui <- list(html = content, deps = "[]")
+  } else {
+    # process_ui() does *not* render markdown->HTML, but it does:
+    # 1. Extract and register HTMLdependency()s with the session.
+    # 2. Returns a HTML string representation of the TagChild
+    #    (i.e., `div()` -> `"<div>"`).
+    ui <- process_ui(content, session)
+  }
+
   msg <- list(
-    content = msg[["content"]],
+    content = ui[["html"]],
     role = msg[["role"]],
     content_type = content_type,
+    html_deps = ui[["deps"]],
     chunk_type = chunk_type,
     operation = operation
   )
@@ -390,26 +412,26 @@ rlang::on_load(chat_append_stream_impl <- coro::async(function(id, stream, role
 
 
 #' Clear all messages from a chat control
-#' 
+#'
 #' @param id The ID of the chat element
 #' @param session The Shiny session object
-#' 
-#' @export 
+#'
+#' @export
 #' @examplesIf interactive()
-#' 
+#'
 #' library(shiny)
 #' library(bslib)
-#' 
+#'
 #' ui <- page_fillable(
 #'   chat_ui("chat", fill = TRUE),
 #'   actionButton("clear", "Clear chat")
 #' )
-#' 
+#'
 #' server <- function(input, output, session) {
 #'   observeEvent(input$clear, {
 #'     chat_clear("chat")
 #'   })
-#' 
+#'
 #'   observeEvent(input$chat_user_input, {
 #'     response <- paste0("You said: ", input$chat_user_input)
 #'     chat_append("chat", response)
@@ -426,4 +448,4 @@ chat_clear <- function(id, session = getDefaultReactiveDomain()) {
       obj = NULL
     )
   )
-}
+}