Timing issue with tagAddRenderHook and nested functions

[DivadNojnarg]

Hi @schloerke!

I was finishing to review some chapter in the book and I found a weird result with tagAddRenderHook(). Typically, I created a bs_accordion() function which accepts bs_accordion_item() functions. Each function has a render hook to account for BS4 and BS5 differences. However, at some point, in the bs_accordion() hook, I got a very strange output. Below is the HTML structure of the tag I want to modify:

<div class="card">
  <div class="card-header">
    <h2 class="mb-0">
      <button class="btn btn-link btn-block text-left" type="button" data-toggle="collapse" aria-expanded="false">Item 1</button>
    </h2>
  </div>
  <div class="collapse">
    <div class="card-body">Item 1 content</div>
  </div>
</div>

If I do a tagQuery round on this tag like: tagQuery(item)$find(".card-header"), I got nothing. If I do tagQuery(item)$find(".collapse"), I get one selected result. If I check item$children, I get only:

 [[1]]
            <div class="collapse">
              <div>Item 1 content</div>
            </div>

My question is what happens with:

<div class="card-header">
  <h2 class="mb-0">
    <button class="btn btn-link btn-block text-left" type="button" data-toggle="collapse" aria-expanded="false">Item 1</button>
  </h2>
</div>

Why is it ignored? Could it be a timing issue with the hooks?

My whole code:

library(htmltools) # 0.5.1.9005
library(bslib) # 0.2.5.9002
library(shiny) # 1.6.0

bs_accordion <- function(id, items) {

  accordion_tag <- tags$div(
    class = "accordion",
    id = id,
    items
  )

  tagAddRenderHook(accordion_tag, function(x) {
    # get theme and version
    theme <- bslib::bs_current_theme()
    version <- if (bslib::is_bs_theme(theme)) {
      bslib::theme_version(theme)
    }

    if (version == "3") {
      stop(
        sprintf(
          "accordion is not available for Bootstrap %s", 
          version
        )
      )
    }

    # process accordion items to add
    # missing attributes
    new_items <- lapply(seq_along(items), function(i) {

      # temp ids based on the parent id
      heading_id <- paste(id, "heading", i, sep = "_")
      controls_id <- paste0(id, "_collapse_", i)
      target_id <- paste0("#", controls_id)

      browser()
      # BS4 and BS5 have minor differences
      switch(
        version,
        "4" = tagQuery(items[[i]])$
          find(".card-header")$
          addAttrs("id" = heading_id)$
          find(".btn")$
          addAttrs(
            "data-target" = target_id,
            "aria-controls" = controls_id
          )$
          resetSelected()$
          find(".collapse")$
          addAttrs(
            "id" = controls_id,
            "aria-labelledby" = heading_id,
            "data-parent" = paste0("#", id)
          )$
          allTags(),
        "5" = tagQuery(items[[i]])$
          find(".accordion-header")$
          addAttrs("id" = heading_id)$
          children()$
          addAttrs(
            "data-bs-target" = target_id,
            "aria-controls" = controls_id
          )$
          resetSelected()$
          find(".accordion-collapse")$
          addAttrs(
            "id" = controls_id,
            "aria-labelledby" = heading_id,
            "data-bs-parent" = paste0("#", id)
          )$
          allTags()
      )
    })

    # alter main tag structure
    tagQuery(x)$
      # replace accordion items processed above
      children()$
      empty()$
      append(new_items)$
      allTags()
  })
}

bs_accordion_item <- function(title, content, active = FALSE) {

  item_body <- tags$div(
    # id will be added from bs_accordion
    # aria-labelledby also added from bs_accordion
    # class differs between BS4 and BS5
    # data parent differs between BS4 and BS5
    class = "collapse",
    tags$div(
      # class differs between BS4 and BS5
      content
    )
  )

  # accordion item wrapper 
  accordion_item_tag <- tags$div(
    # class differs between BS4 and BS5
    item_body
  )

  tagAddRenderHook(accordion_item_tag, function(x) {
    # get theme and version
    theme <- bslib::bs_current_theme()
    version <- if (bslib::is_bs_theme(theme)) {
      bslib::theme_version(theme)
    }

    # create accordion item header 
    item_header <- if (version == "4") {
      tags$div(
        class = "card-header",
        # id will be added from bs_accordion
        tags$h2(
          class = "mb-0",
          tags$button(
            class = "btn btn-link btn-block text-left",
            type = "button",
            `data-toggle` = "collapse",
            # data-target will be added from bs_accordion 
            `aria-expanded` = tolower(active),
            # aria-controls will be added from bs_accordion
            title
          )
        )
      )
    } else if (version == "5") {
      tags$h2(
        class = "accordion-header",
        tags$button(
          class = "accordion-button",
          type = "button",
          `data-bs-toggle` = "collapse",
          `aria-expanded` = tolower(active),
          title
        )
      )
    }

    # alter tag structure
    switch(
      version,
      # don't need to handle BS3
      "4" =  tagQuery(x)$
        addClass("card")$
        # prepend header tag
        prepend(item_header)$
        find(".collapse")$
        children()$
        # add class to item body
        addClass("card-body")$
        allTags(),
      "5" = tagQuery(x)$
        addClass("accordion-item")$
        prepend(item_header)$
        find(".collapse")$
        children()$
        addClass("accordion-body")$
        allTags()
    )
  })
}

ui <- fluidPage(
  theme = bs_theme(version = 4),
  bs_accordion(
    id = "accordion",
    items = tagList(
      bs_accordion_item(
        title = "Item 1",
        "Item 1 content"
      ),
      bs_accordion_item(
        title = "Item 2",
        "Item 2 content"
      )
    )
  )
)

server <- function(input, output, session) {}
shinyApp(ui, server)

Regarding best practices, I am not sure whether I should use only the hook on the top level or if having it in both functions is not an issue.

[cpsievert]

Since the parent (bs_accordion) wants to query the final representation of it's children bs_according_item, it seems the only way to do this is to 'resolve' bs_according_item within bs_accordion's render hook. In your example, it seems you can just do:

item <- as.tags(items[[i]])
tagQuery(item)$find(".card-header")

However, note that as.tags() resolves only the render hooks attached to the top-level items[[i]] (it doesn't resolve any hooks attached to it's children). In order to do that, you'd have to use htmltools:::tagify() instead of as.tags() (we've been thinking of possibly tagify(), and this sort of use case might be reason enough to actually do it)

[DivadNojnarg]

Thanks @cpsievert it works well. See below a reduced example:

options("theme_version" = "4")

my_wrapper_tag <- function(...) {
  wrapper <- tags$div(class = "parent", ...)
  items <- list(...)

  tagAddRenderHook(wrapper, function(x) {
    version <- getOption("theme_version")

    if (!is.null(version)) {
      if (version == "4") {

        # resolve sub items
        # items <- lapply(items, as.tags)

        new_items <- tagQuery(items)$
          find(".new-child")$
          each(function(x, i) {
            tagAppendAttributes(x, id = i)
          })$
          allTags()

        x <- tagQuery(x)$
          # replace accordion items processed above
          empty()$
          append(new_items)$
          allTags()
      } 
    }

    x

  })
}

my_nested_tag <- function() {
  wrapper <- tags$div(
    class = "nested",
    tags$div(
      tags$span()
    )
  )

  tagAddRenderHook(wrapper, function(x) {
    version <- getOption("theme_version")

    if (!is.null(version)) {
      x <- if (version == "4") {

        new_child <- tags$div(class = "new-child")

        tagQuery(x)$
          prepend(new_child)$
          allTags()
      } 
    }

    x

  })
}

my_wrapper_tag(my_nested_tag(), my_nested_tag())

It requires to uncomment items <- lapply(items, as.tags) to work well, as you suggested.

Will tagify() be exported in that case?