在R闪亮小工具框中显示selectInput值

问题描述

请运行下面的R闪亮脚本，我希望在infobox小部件的第三个selectInput选项中显示selectInput值，并为下面的所有选项卡复制相同的功能。目前它是硬编码的，脚本是使用闪亮的模块编写的，所以请检查。正在附加快照以供参考，请帮助。

candyData <- read.table(
text = "
Brand       Candy           value
Nestle      100Grand        Choc1
Netle       Butterfinger    Choc2
Nestle      Crunch          Choc2
Hershey's   KitKat          Choc4
Hershey's   Reeses          Choc3
Hershey's   Mounds          Choc2
Mars        Snickers        Choc5
Nestle      100Grand        Choc3
Nestle      Crunch          Choc4
Hershey's   KitKat          Choc5
Hershey's   Reeses          Choc2
Hershey's   Mounds          Choc1
Mars        Twix            Choc3
Mars        Vaid            Choc2",
header = TRUE,
stringsAsFactors = FALSE)
library(shiny)
library(shinydashboard)
submenuUI <- function(id) {
ns <- NS(id)
tagList(
box(title = "Data", status = "primary", solidHeader = T, width = 12,
    fluidPage(
      fluidRow(

        column(2,offset = 0, style='padding:1px;',

selectInput(ns("Select1"),"select1",unique(candyData$Brand))),
        column(2,offset = 0,

style='padding:1px;',selectInput(ns("Select2"),"select2",choices = NULL)),
        column(2, offset = 0,

style='padding:1px;',selectInput(ns("Select3"),"select3",choices=NULL ))
      ))
    ),
infoBox("value1", 5)
)}
# submenu <- function(input,output,session){}
submenuServ <- function(input, output, session){
observeEvent(input$Select1,{
updateSelectInput(session,'Select2',


choices=unique(candyData$Candy[candyData$Brand==input$Select1]))
})
observeEvent(input$Select2,{
updateSelectInput(session,'Select3',


choices=unique(candyData$value[candyData$Brand==input$Select1 &

candyData$Candy==input$Select2]))
})}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
  shinyjs::useShinyjs(),
  id = "tabs",
  menuItem("Charts", icon = icon("bar-chart-o"),
           shinyjs::hidden(menuSubItem("dummy", tabName = "dummy")),
           menuSubItem("Sub-item 1", tabName = "subitem1"),
           menuSubItem("Sub-item 2", tabName = "subitem2"),
           menuSubItem("Sub-item 3", tabName = "subitem3")
  ))),
  dashboardBody(
  tabItems(tabItem("dummy"),
         tabItem("subitem1", submenuUI('submenu1')),
         tabItem("subitem2", submenuUI('submenu2')),
         tabItem("subitem3", submenuUI('submenu3')))))
 server <- function(input, output,session) {

 callModule(submenuServ,"submenu1")
 callModule(submenuServ,"submenu2")
 callModule(submenuServ,"submenu3")
 }
 shinyApp(ui = ui, server = server)

推荐答案

可以使用infoBoxOutput和renderInfoBox，如下所示：

candyData <- read.table(
  text = "
  Brand       Candy           value
  Nestle      100Grand        Choc1
  Netle       Butterfinger    Choc2
  Nestle      Crunch          Choc2
  Hershey's   KitKat          Choc4
  Hershey's   Reeses          Choc3
  Hershey's   Mounds          Choc2
  Mars        Snickers        Choc5
  Nestle      100Grand        Choc3
  Nestle      Crunch          Choc4
  Hershey's   KitKat          Choc5
  Hershey's   Reeses          Choc2
  Hershey's   Mounds          Choc1
  Mars        Twix            Choc3
  Mars        Vaid            Choc2",
  header = TRUE,
  stringsAsFactors = FALSE)
library(shiny)
library(shinydashboard)
submenuUI <- function(id) {
  ns <- NS(id)
  tagList(
    box(title = "Data", status = "primary", solidHeader = T, width = 12,
        fluidPage(
          fluidRow(

            column(2,offset = 0, style='padding:1px;',

                   selectInput(ns("Select1"),"select1",unique(candyData$Brand))),
            column(2,offset = 0,

                   style='padding:1px;',selectInput(ns("Select2"),"select2",choices = NULL)),
            column(2, offset = 0,

                   style='padding:1px;',selectInput(ns("Select3"),"select3",choices=NULL ))
          ))
    ),
    infoBoxOutput(ns("ibox"))
  )}
# submenu <- function(input,output,session){}
submenuServ <- function(input, output, session){
  observeEvent(input$Select1,{
    updateSelectInput(session,'Select2',


                      choices=unique(candyData$Candy[candyData$Brand==input$Select1]))
  })
  observeEvent(input$Select2,{
    updateSelectInput(session,'Select3',


                      choices=unique(candyData$value[candyData$Brand==input$Select1 &

                                                       candyData$Candy==input$Select2]))


    output$ibox <- renderInfoBox({
      infoBox(
        "value1",
        input$Select3
      )
    })


  })}
ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    sidebarMenu(
      shinyjs::useShinyjs(),
      id = "tabs",
      menuItem("Charts", icon = icon("bar-chart-o"),
               shinyjs::hidden(menuSubItem("dummy", tabName = "dummy")),
               menuSubItem("Sub-item 1", tabName = "subitem1"),
               menuSubItem("Sub-item 2", tabName = "subitem2"),
               menuSubItem("Sub-item 3", tabName = "subitem3")
      ))),
  dashboardBody(
    tabItems(tabItem("dummy"),
             tabItem("subitem1", submenuUI('submenu1')),
             tabItem("subitem2", submenuUI('submenu2')),
             tabItem("subitem3", submenuUI('submenu3')))))
server <- function(input, output,session) {

  callModule(submenuServ,"submenu1")
  callModule(submenuServ,"submenu2")
  callModule(submenuServ,"submenu3")
}
shinyApp(ui = ui, server = server)

希望能有所帮助！

这篇关于在R闪亮小工具框中显示selectInput值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！