Shiny: вызвать всплывающее окно, нажав ValueBox

Question

Я хочу отобразить таблицу данных во всплывающем окне, нажав valueBox.Сам valueBox должен работать как actionButton.

Когда я нажимаю valueBox, он должен отобразить таблицу во всплывающем окне, как показано на рисунке ниже.

Кто-нибудь может помочь с этим кодом?

Мой код:

library(shiny)
library(shinydashboard)

data <- iris

ui <- dashboardPage(
  dashboardHeader(title = "Telemedicine HP"),
  dashboardSidebar(),
  dashboardBody(
    fluidRow(
      valueBox( 60, subtitle = tags$p("Attended", style = "font-size: 200%;"),
                icon = icon("trademark"), color = "purple", width = 4,
                href = NULL))))

server <- function(input,output){
}

shinyApp(ui, server)

Answer 1

Вы можете создать событие onclick с помощью shinyjs.Поэтому вам нужно добавить useShinyjs() в ваш пользовательский интерфейс, что вы можете сделать, поместив ваш пользовательский интерфейс в tagList.

Функция onclick запускается на вашем сервере при нажатии на элемент с данным идентификатором.Так что вам также нужно дать valueBox идентификатор.Я решил обернуть его в div с идентификатором.

Следующая часть - создать всплывающее окно при каждом запуске события onclick.Это можно сделать с помощью функции showModal из shinyBS.

Рабочий пример

library(shiny)
library(shinydashboard)
library(shinyjs)
library(shinyBS)

data <- iris

ui <- tagList(
  useShinyjs(),
  dashboardPage(
    dashboardHeader(title = "Telemedicine HP"),
    dashboardSidebar(),
    dashboardBody(
      fluidRow(
        div(id='clickdiv',
            valueBox(60, subtitle = tags$p("Attended", style = "font-size: 200%;"), icon = icon("trademark"), color = "purple", width = 4, href = NULL)
        )
      )
    )
  )
)

server <-  function(input, output, session){
  onclick('clickdiv', showModal(modalDialog(
    title = "Your title",
    renderDataTable(data)
  )))
}

shinyApp(ui, server)

Answer 2

Вот еще одно решение без shinyjs

library(shiny)
library(shinydashboard)
library(shinyBS)

data <- iris

ui <- tagList(
  dashboardPage(
    dashboardHeader(title = "Telemedicine HP"),
    dashboardSidebar(),
    dashboardBody(
      fluidRow(
        div(id='clickdiv',
            valueBox(60, subtitle = tags$p("Attended", style = "font-size: 200%;"), icon = icon("trademark"), color = "purple", width = 4, href = NULL)
        )
      ),
      bsModal("modalExample", "Data Table", "clickdiv", size = "large",dataTableOutput("table"))
    )
  )
)

server <-  function(input, output, session){

  output$table <- renderDataTable({
    head(data)
  })

}

shinyApp(ui, server)