Question

我有一个看似非常简单的问题。我想在不同的标签中显示不同的图表。为此，我已经有一些代码，我使用output$Sidebar和output$TABUI作为标签的内容。

我确实希望对图表使用一些控件，但所有控件都是相同的，我需要它们位于不同选项卡的下方，因为我不希望将它们复制并让它们出现在每个选项卡中。

我必须在我的代码中遗漏一些内容，因为仪表板中没有任何内容。标签创建得很好（看起来像），我的控件就在它们下面。我的数据被读取（可以在控制台中看到），我可以使用控件，但是没有任何内容出现在身体中。

我尝试修改我的代码（更长时间）来制作一个最小的例子，如下所示。

编辑：如果sidebarmenu和tabitems都在UI.R中，那么ui上的所有内容都会被正确编译，除了我的数据，它们在SERVER的开头加载.R未加载。似乎server.R甚至没有运行。如果我从server.R定义sidebarmenu和thetabitems，则加载数据，但只显示我的控件，不显示sidebarmenu和body。我也无法理解这种行为。如果我在server.R的UI.R和sidebarmenu中留下tabitems，它也不会加载数据。该应用程序只是坐在那里没有任何反应。如果有人认为他们可能知道原因，我会很高兴得到解释。谢谢。

ui.R：

library(shiny)
library(shinydashboard)

body <- dashboardBody(
  tags$head(
    tags$link(
      rel = "stylesheet",
      type = "text/css",
      href = "css/custom.css"
    )
  ),
  uiOutput("TABUI")

)

sidebar <- dashboardSidebar(
  width = 350,
  uiOutput("Sidebar")
)

header <- dashboardHeader(
  title = "Dashboard",
  titleWidth = 350,

  tags$li(
    class = "dropdown",
    img(
      src = 'img/General_Logo.png',
      style =  'margin-right:150px; margin-top:21px')
  )
)

dashboardPage(
  header,
  sidebar,
  body
)

Server.R

library(ggplot2)
library(dplyr)
library(RColorBrewer)
library(XLConnect)
library(htmlTable)
library(plotly)

# Loading data  -----------------------------------------------------
raw_data <- read.csv("file.csv")

# Server function ---------------------------------------------------
shinyServer(function(input, output) {

  # Tabs and content

  ntabs <- 4
  tabnames <- paste0("tab ", 1:ntabs)

  output$Sidebar <- renderUI({
    Menus <- vector("list", ntabs + 2)
    for (i in 1:ntabs){
             Menus[[i]] <- menuItem(tabnames[i], tabName = tabnames[i], icon = icon("dashboard"))
    }
    # Controls to appear below tabs
    Menus[[ntabs + 1]] <- selectInput("dpt", "Departments :",
                c("dpt 1" = "DPT1",
                  "dpt 2" = "DPT2",
                  "dpt 3" = "DPT3"),
                multiple = TRUE,
                selectize = TRUE)

    Menus[[ntabs + 2]] <- uiOutput("bottleneck")
    Menus[[ntabs + 3]] <- uiOutput("daterange")
    Menus[[ntabs + 4]] <- submitButton()

    do.call(function(...) sidebarMenu(id = 'sidebarMenu', ...), Menus)
  })

  # content of each tab
  output$TABUI <- renderUI({
    Tabs <- vector("list", ntabs)
    Tabs[[1]] <- tabItem(tabName = tabnames[1],
                         # fluidRow(box(h3("foo.")))
                         fluidRow(
                           box(
                             plotOutput("plot_1")
                           )
                         )
    )
    Tabs[[2]] <- tabItem(tabName = tabnames[2],
                         "Tab 2 Stuff")
    Tabs[[3]] <- tabItem(tabName = tabnames[3],
                         "Tab 3 Stuff")
    Tabs[[4]] <- tabItem(tabName = tabnames[4],
                         "Tab 4 Stuff")
    do.call(tabItems, Tabs)
  })

  formulaText <- reactive({

    if (is.null(data.r())) {
      return("some text")
    }

    paste0(as.character(input$daterange[1]), " to ", as.character(input$daterange[2]), " - blah blah")
  })

  output$bottleneck <- renderUI({
    selectInput('bottleneck', HTML('<font color=\"black\"> Bottlenecks : </font>'), c(Choose = '', raw_data[raw_data$is_bottleneck == 1 & !is.na(raw_data$Sort.field) & raw_data$Cost.Center %in% input$dpt,]$Sort.field %>%  unique() %>% sort()), selectize = TRUE)
  })

  output$daterange <- renderUI({
    dateRangeInput(inputId = 'daterange', 
                   label = HTML('<font color=\"black\"> Select period : </font>'), 
                   min = min(raw_data$Completn.date) , 
                   start = min(raw_data$Completn.date) ,
                   max = max(raw_data$Completn.date), 
                   end = max(raw_data$Completn.date))
  })

  data.r = reactive({

    if (is.null(input$dpt)) {
      return(NULL)
    }  

    ifelse(input$bottleneck == "", a <- raw_data %>% filter(Completn.date >=     input$daterange[1],
                                                                            Completn.date <= input$daterange[2]),
           a <- raw_data %>% filter(Completn.date >= input$daterange[1],
                                    Completn.date <= input$daterange[2],
                                    Sort.field %in% input$bottleneck))

    return(a)
  })

  output$table_ranking <- renderHtmlTableWidget({

    if (is.null(data.r())) {
      return()
    }

    ranking <- read.csv("ranking.csv", header = TRUE)
    htmlTableWidget(ranking)
  })

  output$caption <- renderText({
    formulaText()
  })

  output$plot_1 <- renderPlot({

    if (is.null(data.r())) {
      return()
    }

    current_data <- data.r()

    p0 <- current_data %>% 
      ggplot(aes(x = x1, y = y1)) +
      geom_point()

    p0

  })

  output$plot_2 <- renderPlot({

    if (is.null(data.r())) {
      return()
    }

    current_data <- data.r()

    p0 <- current_data %>% 
      ggplot(aes(x = x2, y = y2)) +
      geom_point()

    p0

  })
})

这是尝试复制建议here的尝试失败。

提前感谢您对此进行调查。

Answer 1

我终于找到了答案。

我在不同的标签中复制了多个反应元素。出于某种原因，Shiny不喜欢这个。一旦我创建了不同的反应字符串（在我的情况下），那么一切都很好（在server.r中使用renderUI的tabitems，以及sidebarmenu）。

很奇怪，但无论如何。

闪亮 - 不同标签中的不同情节

1 个答案: