在滑块输入和预定义向量中闪亮显示月份

Question

我目前正在尝试编写一个闪亮的应用程序并接近解决方案，我想达到。但是，有些问题我无法解决...

if(!require(shiny)){
  install.packages("shiny")
  require(shiny)
}

if(!require(tidyverse)){
install.packages("tidyverse")
require(tidyverse)
}

if(!require(readxl)){
  install.packages("readxl")
  require(readxl)
}

if(!require(lubridate)){
  install.packages("lubridate")
  require(lubridate)
}

prodpromonat <- tibble(prodmonat = c("2008-01-01", "2008-02-01", "2008-03-01", "2008-04-01", "2008-05-01", "2008-06-01", "2008-07-01", "2008-08-01"),
                   n = c("3216", "3268", "2398", "2987", "4003", "3103", "3064", "2786"))

prodpromonat$prodmonat <- as.Date(prodpromonat$prodmonat)

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      sliderInput(
        "zeitraum",
        "Produktionszeitraum",
        min = min(prodpromonat$prodmonat),
        max = max(prodpromonat$prodmonat),
        value = c(max(prodpromonat$prodmonat)-90, max(prodpromonat$prodmonat))
  ),

    fluidRow(
      radioButtons(
        "farbschema",
        "Farbschema",
        choices = c("Einfarbig", "Zweifarbig"),
        selected = "Einfarbig"
      )
    ),

    fluidRow(
      uiOutput("farbwahl")
    )
    ),

  mainPanel(
    tabsetPanel(
      tabPanel(
        title = "Produktionsmenge" ,
        plotOutput(
          outputId = "produktionsmenge"
        )
      )
  )
  )
))

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

  farbeninput <- reactive({
    switch(input$farbschema,
       "Zweifarbig" = c(input$farbe1, input$farbe2),
       "Einfarbig" = c(input$farbe1, input$farbe1)
    )
  })

  filter_produktionsmenge <- reactive({
    min <- filter(prodpromonat, prodmonat >= floor_date(input$zeitraum[1], "month"))
    max <- filter(prodpromonat, prodmonat <= floor_date(input$zeitraum[2], "month"))
    semi_join(min, max, by = "prodmonat")
  })

  output$farbwahl <- renderUI({
    switch(input$farbschema,
       "Zweifarbig" = tagList(textInput("farbe1", "Farbe 1", value = "#808080"), textInput("farbe2", "Farbe 2", value = "#1E90FF")),
       "Einfarbig" = textInput("farbe1", "Farbe", value = "#808080")
       )
  })

  output$produktionsmenge <- renderPlot({
    ggplot(filter_produktionsmenge(), aes(factor(prodmonat), n)) +
      geom_bar(stat="identity", aes(fill = factor(as.numeric(month(prodmonat) %% 2 == 0)))) + 
      scale_fill_manual(values=rep(farbeninput())) +
      xlab("Produktionsmonat") +
      ylab("Anzahl produzierter Karosserien") + 
      theme(legend.position = "none") 
  })

}

shinyApp(ui, server)

问题 #1：在滑块输入中，我提供所选时间跨度内的每一天，而我只想提供现有月份，最好不提供当天的任何提示。我试图打印“%Y-%m”的每个解决方案都会产生错误，所以我坚持了这些日子......

问题 #2：是否有可能在使用 uiOutput 之前定义颜色向量？现在它几乎可以按我的计划工作，但是在渲染的 UI 完成渲染并显示在侧边栏中之前显示了一个错误。我的猜测是，在 renderUI 完成之前，该向量不存在，因为错误显示为“手动缩放中的值不足。需要 2，但只提供了 0。”。所以我想初始化它。首次更改为双色模式同样有效。

您对如何解决这些问题有任何想法吗？非常感谢！

干杯！

编辑：

之前找到了问题的解决方案。但是，问题 #1 和 #2 仍然存在。

*edit: 从代码中删除一个括号

Answer 1

对于问题 #1，您只需将 timeFormat 参数添加到您的滑块输入中，就像这样

sliderInput(
    "zeitraum",
    "Produktionszeitraum",
    min = min(prodpromonat$prodmonat),
    max = max(prodpromonat$prodmonat),
    timeFormat = "%Y-%m",
    value = c(max(prodpromonat$prodmonat)-90, max(prodpromonat$prodmonat))
  ),

Answer 2

问题 #1：

将timeFormat = "%Y-%m" 添加到sliderInput（waskuf 已经回答）

问题 #2：

问题源于一些依赖问题：

• renderPlot 取决于 farbeninput 和 filter_produktionsmenge。每次出现以下情况时，该情节将被渲染：

  • farbeninput 变化，
  • 滑块被修改，因此数据通过filter_produktionsmenge重新计算。

如果您将打印语句添加到每个块，您会看到renderPlot 被调用了两次，因为farbeninput 更改了两次。

[1] "renderUI"
[1] "renderPlot"
[1] "farbeninput"
[1] "renderPlot"
[1] "farbeninput"
[1] "filter_produkt"

为什么会这样？

farbeninput 依赖于 input$farbschema、input$farbe1 和 input$farbe2。这意味着如果这些输入中的任何一个发生变化，farbeninput 将被重新计算。

当更改input$farbschema farbeninput 时会渲染两次：

1. 因为input$farbschema 改变了。
2. 当textInputs 在 UI 中呈现时。

这就是导致显示警告的原因！

解决方案

您需要制作farbeninput，以便它仅在textInputs 被渲染后计算。您可以使用req 实现此目的。

例如：如果input$farbschema 的值为"Zweifarbig"，并且input$farbe1 或input$farbe2 未呈现，则返回NULL 值。如果两者都被渲染，则c(input$farbe1, input$farbe2) 将正常返回。

farbeninput <- reactive({
  switch(input$farbschema,
         "Zweifarbig" = {
           req(input$farbe1)
           req(input$farbe2)
           c(input$farbe1, input$farbe2)
         },
         "Einfarbig" = {
           req(input$farbe1)
           c(input$farbe1, input$farbe1)
         }
  )
})

将req(farbeninput()) 添加到renderPlot 以避免在farbeninput 为NULL 时呈现：

output$produktionsmenge <- renderPlot({
  req(farbeninput())
  ggplot(filter_produktionsmenge(), aes(factor(prodmonat), n)) +
    geom_bar(stat="identity", aes(fill = factor(as.numeric(month(prodmonat) %% 2 == 0)))) + 
    scale_fill_manual(values=rep(farbeninput())) +
    xlab("Produktionsmonat") +
    ylab("Anzahl produzierter Karosserien") + 
    theme(legend.position = "none") 
})