Search code examples
rshinypurrrhtmltools

render grouped list in HTML


I am trying to make an HTML detailed elements by group (grouped or nested). The function div_detail_each format one row and stored as shiny.tag class. After that, I nest by group and unify the tags with unify_divs.

I make a tiny example with mtcars. The uiOutput does not the HTML as expected; I made a print in console before inserting the HTML statement to check it was rendered correctly.

It seems list elements has done some conflict with htmltools.

Hope someone could help me.

library(shiny)
library(broom)

df <- mtcars %>%
  mutate(
    DETAIL = pmap(
      .l = list(mpg, hp),
      .f = ~ div_detail_each(..1, ..2)
    )
  ) %>%
  group_by(
    cyl
  ) %>%
  nest() %>% 
  mutate(
    detail = map(
      .x = data,
      .f = ~ unify_divs(.x$DETAIL)
    )
  ) %>%
  select(
    cyl, detail
  )


div_detail_each <- function(mpg, hp, ...){
  mydiv <- div(
    class = "child", id = "child", 
    strong("detailed info: "),
    paste0(
      "mpg:", mpg, ", hp:", hp
    )
  ) 
  
  if(hp < 90) {
    mydiv <- tagAppendAttributes(
      mydiv,
      style = 'color:red'
    )
  }
  return(mydiv)
}  

unify_divs <- function(children_list){
  mydiv <- div(class = "parent", id = "container")
  mydiv <- tagSetChildren(mydiv, children_list)
  mydiv 
}

ui <- fluidPage(
  fluidRow(
    actionButton("do", "Do")
  ),
  fluidRow(
    uiOutput("detail")
  )
)    

server <- function(input, output, session){
  observeEvent(input$do, {
    output$detail <- renderUI({
      map(seq_len(nrow(df)), function(i) {
        print(df[i, 2][[1]])
        fluidRow(
          valueBox(
            value = as.character(df[i, 2][[1]]),
            subtitle = "Details",
            width = 12
          )
        )
      })
    })
  })  
}

shinyApp(ui, server)

Print screen: enter image description here


Solution

  • I found a somewhat messy solution varying this line

    lapply(df[i, 2], function(x) HTML(as.character(x[[1]])))
    

    But putting a lapply inside a map seems nonsense

    library(shiny)
    library(broom)
    
    df <- mtcars %>%
      mutate(
        DETAIL = pmap(
          .l = list(mpg, hp),
          .f = ~ div_detail_each(..1, ..2)
        )
      ) %>%
      group_by(
        cyl
      ) %>%
      nest() %>% 
      mutate(
        detail = map(
          .x = data,
          .f = ~ unify_divs(.x$DETAIL)
        )
      ) %>%
      select(
        cyl, detail
      )
    
    
    div_detail_each <- function(mpg, hp, ...){
      mydiv <- div(
        class = "child", id = "child", 
        strong("detailed info: "),
        paste0(
          "mpg:", mpg, ", hp:", hp
        )
      ) 
      
      if(hp < 90) {
        mydiv <- tagAppendAttributes(
          mydiv,
          style = 'color:red'
        )
      }
      return(mydiv)
    }  
    
    unify_divs <- function(children_list){
      mydiv <- div(class = "parent", id = "container")
      mydiv <- tagSetChildren(mydiv, children_list)
      mydiv 
    }
    
    ui <- fluidPage(
      fluidRow(
        actionButton("do", "Do")
      ),
      fluidRow(
        uiOutput("detail")
      )
    )    
    
    server <- function(input, output, session){
      observeEvent(input$do, {
        output$detail <- renderUI({
          map(seq_len(nrow(df)), function(i) {
            print(df[i, 2][[1]])
            fluidRow(
              column(2 ,paste0("group ", i)),
              column(10,
                 lapply(df[i, 2][[1]], function(x) HTML(as.character(x)))     
                 #lapply(df[i, 2], function(x) HTML(as.character(x[[1]])))
                 #value = lapply(df[i, 2][[1]], as.character)
                 #value = as.character(df[i, 2][[1]])
              )
            )
          })
        })
      })  
    }
    
    shinyApp(ui, server)