bslib::value_box within bs4Dash displays not as intended

Question

I am trying to adapt for my own application the last example in this documentation of creating valueBoxes with "showcase"d sparklines made interactive via plotly. The example does not go as far as rendering within a shiny app and the bslib package does not include render/output functions.

I have gotten something sort of working via the renderUI/uiOutput functions but the result does not respect proportioning and positioning between the value and the showcased sparkline within the bs4Dash (or any other framework). Running the code interactively in RStudio shows the desired result in the Viewer pane. I am looking for help to match the rendered output in my shiny app to the article linked above

MRE below

## app.R ##
library(shiny)
library(plotly)
library(dplyr)
library(bs4Dash)
library(bslib)


ui <- bs4DashPage(
  dashboardHeader(title = "Test Dash"),
  bs4DashSidebar(
    sidebarMenu(id = "tab",
                menuItem("Test 1", tabName = "t1", icon = icon("dashboard")),
                menuItem("Test 2", tabName = "t2", icon = icon("triangle-exclamation"))
    )
  ),
  bs4DashBody(
    tabItems(
      tabItem(tabName = "t1",
              
              fluidRow(
                box(width = 3,
                    uiOutput("papq_vbox_quote")
                )
              )               
      ),
      tabItem(tabName = "t2"
      )
    )
  )
)

server <- function(input, output) {
  
  dat <- tibble(Date = seq(Sys.Date()-59, Sys.Date(), by = 1),
                measure = rnorm(length(Date), 20 + (Date - min(Date)), 5))
  
  output$papq_vbox_quote <- renderUI({
    
    sparkline <- plot_ly(dat) %>%
      add_lines(
        x = ~Date, y = ~measure,
        color = I("white"), span = I(1),
        fill = 'tozeroy', alpha = 0.2
      ) %>%
      layout(
        xaxis = list(visible = F, showgrid = F, title = ""),
        yaxis = list(visible = F, showgrid = F, title = ""),
        hovermode = "x",
        margin = list(t = 0, r = 0, l = 0, b = 0),
        font = list(color = "white"),
        paper_bgcolor = "transparent",
        plot_bgcolor = "transparent"
      ) %>%
      config(displayModeBar = F) %>%
      htmlwidgets::onRender(
        "function(el) {
      var ro = new ResizeObserver(function() {
         var visible = el.offsetHeight > 200;
         Plotly.relayout(el, {'xaxis.visible': visible});
      });
      ro.observe(el);
    }"
      )
    
    value_box("Series Data",
              value = formatC(mean(dat$measure), format = "d", big.mark = ","),
              showcase = sparkline,
              showcase_layout = showcase_left_center(),
              full_screen = TRUE,
              # height = "100px",
              # width = .2,
              # max_height = "100px",
              theme_color = "success"
    ) %>%
      return()
  })
  
}

options(shiny.host = '0.0.0.0')
options(shiny.port = 8080)

shinyApp(ui, server)

score 2 · Accepted Answer · answered Jun 11 '23 at 22:21

I would not say {bslib} was meant to work with {bs4Dash}.

While {bs4Dash} uses bootstrap 4, {bslib} is more flexible on the version.

That said, I'd advice you choose to use either of them, but not both.

In this example, I use {bs4Dash} and bootstrap 4 classes to show how you can create and customize your own cards (and value boxes).

Note that I did not change the way you created the sparklines.

global.R

library(shiny)
library(bs4Dash)
library(plotly)
library(dplyr)

ui.R

ui <- bs4DashPage(
  dashboardHeader(title = "Test Dash"),
  bs4DashSidebar(
    sidebarMenu(
      id = "tab",
      menuItem("Test 1", tabName = "t1", icon = icon("dashboard")),
      menuItem("Test 2", tabName = "t2", icon = icon("triangle-exclamation"))
    )
  ),
  bs4DashBody(
    shinyjs::useShinyjs(),
    tabItems(
      tabItem(
        tabName = "t1",
        fluidRow(
          bs4Card(
            width = 8,
            create_card()
          )
        )               
      ),
      tabItem(
        tabName = "t2"
      )
    )
  )
)

create_card

create_card <- function(
    card_class = "bg-success text-white rounded py-2",
    plot_size = 4,
    plot_ui = plotlyOutput(outputId = "theplot", height = "100px"),
    card_header = tags$p("Series Data"),
    show_expand_icon = TRUE,
    icon_id = "expand",
    card_value = tags$h3("50")
) {
  fluidRow(
    class = card_class,
    column(
      width = plot_size,
      plot_ui
    ),
    column(
      width = 12 - plot_size,
      class = "pl-4",
      tags$div(
        class = "d-flex justify-content-between",
        tags$div(
          card_header,
        ),
        if (show_expand_icon) {
          tags$i(
            id = icon_id,
            style = "cursor: pointer;",
            class = "glyphicon glyphicon-resize-full"
          )
        }
      ),
      card_value
    )
  )
}

server.R

server <- function(input, output, session) {
  dat <- tibble(
    Date = seq(Sys.Date() - 59, Sys.Date(), by = 1),
    measure = rnorm(length(Date), 20 + (Date - min(Date)), 5)
  )
  
  sparkline <- plot_ly(dat) %>%
    add_lines(
      x = ~Date, y = ~measure, color = I("white"), span = I(1),
      fill = 'tozeroy', alpha = 0.2
    ) %>%
    layout(
      xaxis = list(visible = F, showgrid = F, title = ""),
      yaxis = list(visible = F, showgrid = F, title = ""),
      hovermode = "x",
      margin = list(t = 0, r = 0, l = 0, b = 0),
      font = list(color = "white"),
      paper_bgcolor = "transparent",
      plot_bgcolor = "transparent"
    ) %>%
    config(displayModeBar = F) %>%
    htmlwidgets::onRender(
      "function(el) {
          var ro = new ResizeObserver(function() {
            var visible = el.offsetHeight > 200;
            Plotly.relayout(el, {'xaxis.visible': visible});
          });
          ro.observe(el);
        }"
    )
  
  output$theplot <- renderPlotly(sparkline)
  
  plot_modal_tag_q <- modalDialog(
    title = fluidRow(
      column(
        width = 12,
        class = "d-flex justify-content-between",
        tags$div("Sparkline"),
        tags$div(
          tags$i(
            id = "close_modal",
            style = "cursor: pointer;",
            class = "glyphicon glyphicon-resize-small"
          )
        )
      )
    ),
    size = "xl",
    easyClose = TRUE,
    footer = NULL,
    create_card(
      plot_ui = plotlyOutput("card_ui_expanded"),
      plot_size = 10,
      show_expand_icon = FALSE
    )
  ) |> 
    htmltools::tagQuery()
  
  # change bg of modal:
  plot_modal_tag_q$find(".modal-content")$addClass("bg-success")
  # center modal:
  plot_modal_tag_q$find(".modal-dialog")$addClass("modal-dialog-centered")
  # full width title:
  plot_modal_tag_q$find(".modal-title")$addClass("w-100")
  plot_modal <- plot_modal_tag_q$allTags()
  
  output$card_ui_expanded <- renderPlotly(sparkline)
  
  shinyjs::onclick("expand", showModal(plot_modal))
  shinyjs::onclick("close_modal", removeModal())
}

score 1 · Answer 2 · answered Jun 09 '23 at 16:02

When you create the card outside of Shiny, a lot of the stying comes from Bootstrap 5, which contradicts with the bs4Dash (Bootstrap 4 Dash). So the styling is dropped, and some of that styling leads to the issues you're having here. I did find a workaround that allows you to continue with your current styling of the app, while addressing the issues with the card.

I want to point out that the card is apparently designed 30% - 70%. So what's on the left get's 30% of the available space and what's on the right gets 70% of the available space. You set the width to 3 in your ui, which, even on a large screen, would make the graph almost non-existent (esp due to padding). I've changed it to 8 in my code below.

The only other change is the addition of CSS in the body. I did not put this CSS in the head of your app because it becomes a problem with some of the current settings in the sidebar.

This is CSS that I captured simply by comparing the CSS behind an isolated value box and the one in your CSS. (So nothing particularly brainy on my end.)

No changes were made to the server.

library(shiny)
library(plotly)
library(dplyr)
library(bs4Dash)
library(bslib)


ui <- bs4DashPage(
  dashboardHeader(title = "Test Dash"),
  bs4DashSidebar(
    sidebarMenu(id = "tab",
                menuItem("Test 1", tabName = "t1", icon = icon("dashboard")),
                menuItem("Test 2", tabName = "t2", icon = icon("triangle-exclamation")))
  ),
  bs4DashBody(
    tags$style(HTML(
    ".bslib-value-box .value-box-grid {
      grid-template-columns: var(--bslib-value-box-widths);
    }
    .bslib-column-wrap {
        display: grid !important;
        gap: 1rem;
        height: var(--bslib-column-wrap-height);
    }
    .bslib-value-box .value-box-showcase {
      align-items: center;
      justify-content: center;
      margin-top: auto;
      margin-bottom: auto;
      padding: 1rem;
      max-height: var(--bslib-value-box-max-height);
    }"
    )),
    tabItems(tabItem(
      tabName = "t1",
      fluidRow(box(width = 8,           # <--- changed from 3
                   uiOutput("papq_vbox_quote")
                ))               
      ),
      tabItem(tabName = "t2"
      )
    )
  )
)

server <- function(input, output) {
  
  dat <- tibble(Date = seq(Sys.Date()-59, Sys.Date(), by = 1),
                measure = rnorm(length(Date), 20 + (Date - min(Date)), 5))
  
  output$papq_vbox_quote <- renderUI({
    sparkline <- plot_ly(dat) %>%
      add_lines(
        x = ~Date, y = ~measure, color = I("white"), span = I(1),
        fill = 'tozeroy', alpha = 0.2
      ) %>%
      layout(
        xaxis = list(visible = F, showgrid = F, title = ""),
        yaxis = list(visible = F, showgrid = F, title = ""),
        hovermode = "x",
        margin = list(t = 0, r = 0, l = 0, b = 0),
        font = list(color = "white"),
        paper_bgcolor = "transparent",
        plot_bgcolor = "transparent"
      ) %>%
      config(displayModeBar = F) %>%
      htmlwidgets::onRender(
        "function(el) {
          var ro = new ResizeObserver(function() {
            var visible = el.offsetHeight > 200;
            Plotly.relayout(el, {'xaxis.visible': visible});
          });
          ro.observe(el);
        }"
      )
    
    value_box("Series Data",
              value = formatC(mean(dat$measure), format = "d", big.mark = ","),
              showcase = sparkline,
              showcase_layout = showcase_left_center(),
              full_screen = TRUE,
              theme_color = "success") %>%
      return()
  })
}

options(shiny.host = '0.0.0.0')
options(shiny.port = 8080)

shinyApp(ui, server)

bslib::value_box within bs4Dash displays not as intended

2 Answers2