使用Shinydashboard侧边栏上的输入未绘制的情节

时间:2019-03-14 16:41:23

标签: r ggplot2 shiny shinydashboard

几天以来,我一直在使用shiny库开发应用程序,现在我想使用shinydashboard包测试新的改编版。问题在于,当我在侧边栏中设置输入时,我的绘图不会出现在我希望其显示的选项卡中(呈现)。

仅使用闪亮包,我设置了以下代码,没有菜单侧边栏(如闪亮仪表板中的内容):

library(shiny)
library(ggplot2)
library(dplyr)

rm(list=ls()); gc()

#functions to order the bar graph

reorder_within <- function(x, by, within, fun = mean, sep = "___", ...) {
  new_x <- paste(x, within, sep = sep)
  stats::reorder(new_x, by, FUN = fun)
}

scale_x_reordered <- function(..., sep = "___") {
  reg <- paste0(sep, ".+$")
  ggplot2::scale_x_discrete(labels = function(x) gsub(reg, "", x), ...)
}

#setting example data 

sample_data = data.frame(Company_Name=c("Company 1","Company 2","Company 3",
                                        "Company 1","Company 2","Company 3",
                                        "Company 1","Company 2","Company 3"),
                         Profits_MM = c(20,100,80,
                                        45,120,70,
                                        50,110,130),
                         Sales_MM = c(200,800,520,
                                      300,1000,630,
                                      410,1150,1200),
                         Year=c(2016,2016,2016,
                                2017,2017,2017,
                                2018,2018,2018))


# UI
ui <- fluidPage(

  sidebarLayout(

    # Input(s)
    sidebarPanel(

      checkboxGroupInput(inputId = "sel_com",
                         label = "Company Selection:",
                         choices = c("Company 1","Company 2","Company 3"),
                         selected = "Company 1"),


      selectInput(inputId = "y", 
                  label = "Performance Variable",
                  choices = c("Profits (in Millions)" = "Profits_MM", 
                              "Sales (in Millions)" = "Sales_MM"),
                  selected = "Profits_MM"),


      sliderInput("year","Year Selection:",
                  min=2016,
                  max=2018,
                  value=c(2017,2018),
                  step=1)


    ),

    # Output(s)
    mainPanel(
      plotOutput(outputId = "barplot")
    )
  )
)

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

  companies_sel <- reactive({

    req(input$sel_com)

    sample_data_gg = filter(sample_data, Company_Name %in% input$sel_com)
    #  print(sample_data_gg)
    sample_data_gg

  })

  year_sample <- reactive({

    req(input$year)
    sample_data_gg = sample_data
    if((input$year[2] - input$year[1])>1){

      Years = seq(input$year[1],input$year[2])

      sample_data_gg = filter(companies_sel(), Year %in% Years)

    }  

    if((input$year[2] - input$year[1])==1){

      sample_data_gg = filter(companies_sel(), Year %in% input$year)

    }
    #  print(sample_data_gg)
    sample_data_gg
  })


  output$barplot = renderPlot({

    sample_data_gg = year_sample()

    y <- input$y
    ggplot(data = sample_data_gg, aes(x=reorder_within(Company_Name, get( y ), Year), y = get( y ))) +
      geom_col(position="dodge", fill="darkred") +
      facet_wrap(Year~., scales = "free")  +
      scale_x_reordered() +
      theme(axis.text.x = element_text(angle = 60, hjust = 1))


  })

}

shinyApp(ui = ui, server = server)

此代码在闪亮的程序包中有效,并显示了我想在应用程序中显示的情节类型。

但是,如果我更改shinydashboard包的编码-在边栏中设置输入时-不会显示该图,并且我试图找出原因。这是代码:

library(shiny)
library(ggplot2)
library(dplyr)
library(shinydashboard)

reorder_within <- function(x, by, within, fun = mean, sep = "___", ...) {
  new_x <- paste(x, within, sep = sep)
  stats::reorder(new_x, by, FUN = fun)
}

scale_x_reordered <- function(..., sep = "___") {
  reg <- paste0(sep, ".+$")
  ggplot2::scale_x_discrete(labels = function(x) gsub(reg, "", x), ...)
}

rm(list=ls()); gc()

sample_data = data.frame(Company_Name=c("Company 1","Company 2","Company 3",
                                        "Company 1","Company 2","Company 3",
                                        "Company 1","Company 2","Company 3"),
                         Profits_MM = c(20,100,80,
                                        45,120,70,
                                        50,110,130),
                         Sales_MM = c(200,800,520,
                                      300,1000,630,
                                      410,1150,1200),
                         Year=c(2016,2016,2016,
                                2017,2017,2017,
                                2018,2018,2018))


# UI
ui <- dashboardPage(
      dashboardHeader(title = "Dashboard Test"),
      dashboardSidebar(

      sidebarMenu(id="tab",
                  menuItem("Data Selection", tabName = "dc", icon = icon("dashboard"),
      checkboxGroupInput(inputId = "sel_com",
                         label = "Company Selection:",
                         choices = c("Company 1","Company 2","Company 3"),
                         selected = "Company 1"),
      selectInput(inputId = "y", 
                  label = "Performance Variable",
                  choices = c("Profits (in Millions)" = "Profits_MM", 
                              "Sales (in Millions)" = "Sales_MM"),
                  selected = "Profits_MM"),
      sliderInput("year","Year Selection:",
                  min=2016,
                  max=2018,
                  value=c(2017,2018),
                  step=1)))),


      dashboardBody(

        tabItems(
          # First tab content
          tabItem(tabName = "dc",

                  fluidRow(column(width=12,box(plotOutput("plot1")))


        )
      )
    )
  )
)


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

  companies_sel <- reactive({

    req(input$sel_com)

    sample_data_gg = filter(sample_data, Company_Name %in% input$sel_com)
    #  print(sample_data_gg)
    sample_data_gg

  })

  year_sample <- reactive({

    req(input$year)
    sample_data_gg = sample_data
    if((input$year[2] - input$year[1])>1){

      Years = seq(input$year[1],input$year[2])

      sample_data_gg = filter(companies_sel(), Year %in% Years)

    }  

    if((input$year[2] - input$year[1])==1){

      sample_data_gg = filter(companies_sel(), Year %in% input$year)

    }
    #  print(sample_data_gg)
    sample_data_gg
  })


  output$barplot = renderPlot({

    sample_data_gg = year_sample()

    y <- input$y
    ggplot(data = sample_data_gg, aes(x=reorder_within(Company_Name, get( y ), Year), y = get( y ))) +
      geom_col(position="dodge", fill="darkred") +
      facet_wrap(Year~., scales = "free")  +
      scale_x_reordered() +
      theme(axis.text.x = element_text(angle = 60, hjust = 1))


  })

}

shinyApp(ui = ui, server = server)

我相信我可能会丢失小工具栏和侧边栏中的输入选择之间的某些交互,但是我无法确切地找出问题所在。

1 个答案:

答案 0 :(得分:4)

您的代码中实际上存在一些共同导致该问题的问题:

第一个:第一个在注释中标识-您使用rm(list=ls())删除了以后需要的功能。

第二:您的plotOutput()使用ID "plot1",而renderPlot引用"barplot"。我认为这是从您切换到shinydashboard以来的一个简单翻译错误。使它们相同,这将有所帮助。

第三:这是三个中比较严重的一个。 shinydashboard有一个已知问题,描述得很好here,其中menuItem中的多个元素导致链接内容到tabItem的属性丢失。您可以使用自定义函数手动设置这些值,然后将menuItem调用包装在该函数中,并小心在函数中指定tabName。

convertMenuItem <- function(mi,tabName) {
  mi$children[[1]]$attribs['data-toggle']="tab"
  mi$children[[1]]$attribs['data-value'] = tabName
  mi
}

根据您的情况更新的用户界面如下所示:

ui <- dashboardPage(
      ... #Other elements remain unchanged
      dashboardSidebar(
        sidebarMenu(
          convertMenuItem(menuItem("Data Selection", tabName = "dc", icon = icon("dashboard"),
              checkboxGroupInput(inputId = "sel_com",
                                label = "Company Selection:",
                                choices = c("Company 1","Company 2","Company 3"),
                                selected = "Company 1"),
              selectInput(inputId = "y", 
                                 label = "Performance Variable",
                                 choices = c("Profits (in Millions)" = "Profits_MM", 
                                             "Sales (in Millions)" = "Sales_MM"),
                                 selected = "Profits_MM"),
              sliderInput("year","Year Selection:",
                          min=2016,
                          max=2018,
                          value=c(2017,2018),
                          step=1)), tabName="dc")
        )
      ),
     ... #Other elements remain unchanged
     )

enter image description here