在闪亮的日期范围输入中添加后退/下一个按钮

Question

我花了很长时间试图弄清楚如何在 Shiny 的 daterangeinput 字段周围添加返回/下周按钮。我个人认为这是一个很酷且方便的功能，并且似乎在 stackoverflow 上没有类似的问题/答案（如果我错了，请纠正我，我会删除这篇文章）。

这是一个屏幕截图，所以你知道我在说什么：

以下是我在设计代码时可以想到的功能列表。
1.当您点击后退/下一个按钮时，两个日期都会向后/向前移动
2. Back/Next 应该利用两个日期之间的间隔来跳转
3. 当左边的日期达到最小日期并且您回击时，该日期将不再减少，但右侧的日期仍然会减少，直到它也达到最小日期
4.当两个日期在最小日期相等时，当你点击下一步时，右侧的日期默认增加7（一周）。
5. 右侧反之亦然。

Answer 1

我将我的代码公开gist。

shiny::runGist("https://gist.github.com/haozhu233/9dd15e7ba973de82f124")

服务器.r

library(shiny)
shinyServer(function(input, output, session) {

  session$onSessionEnded(function() {
    stopApp()
  })

  date.range <- as.Date(c("2015-01-01", "2015-12-31"))
  # ------- Date Range Input + previous/next week buttons---------------
  output$choose.date <- renderUI({
    dateRangeInput("dates", 
                   label = h3(HTML("<i class='glyphicon glyphicon-calendar'></i> Date Range")), 
                   start = "2015-05-24", end="2015-05-30", 
                   min = date.range[1], max = date.range[2])
  }) 

  output$pre.week.btn <- renderUI({
    actionButton("pre.week", 
                 label = HTML("<span class='small'><i class='glyphicon glyphicon-arrow-left'></i> Back</span>"))
  })
  output$next.week.btn <- renderUI({
    actionButton("next.week", 
                 label = HTML("<span class='small'>Next <i class='glyphicon glyphicon-arrow-right'></i></span>"))
  })

  date.gap <- reactive({input$dates[2]-input$dates[1]+1})
  observeEvent(input$pre.week, {
    if(input$dates[1]-date.gap() < date.range[1]){
      if(input$dates[2]-date.gap() < date.range[1]){
        updateDateRangeInput(session, "dates", start = date.range[1], end = date.range[1])
      }else{updateDateRangeInput(session, "dates", start = date.range[1], end = input$dates[2]-date.gap())}
      #if those two dates inputs equal to each other, use 7 as the gap by default
    }else{if(input$dates[1] == input$dates[2]){updateDateRangeInput(session, "dates", start = input$dates[1]-7, end = input$dates[2])
    }else{updateDateRangeInput(session, "dates", start = input$dates[1]-date.gap(), end = input$dates[2]-date.gap())}
    }})
  observeEvent(input$next.week, {
    if(input$dates[2]+date.gap() > date.range[2]){
      if(input$dates[1]+date.gap() > date.range[2]){
        updateDateRangeInput(session, "dates", start = date.range[2], end = date.range[2])
      }else{updateDateRangeInput(session, "dates", start = input$dates[1]+date.gap(), end = date.range[2])}
    }else{if(input$dates[1] == input$dates[2]){updateDateRangeInput(session, "dates", start = input$dates[1], end = input$dates[2]+7)
    }else{updateDateRangeInput(session, "dates", start = input$dates[1]+date.gap(), end = input$dates[2]+date.gap())}
    }})

  output$dates.input <- renderPrint({input$dates})
})
#------- End of Date range input -----------------

ui.r

library(shiny)
shinyUI(
  navbarPage("Demo", 
             position = "static-top",
             fluid = F,

             #================================ Tab 1 =====================================
             tabPanel("Demo",class="active",
                      sidebarLayout(
                        sidebarPanel(uiOutput("choose.date"),
                                     tags$div(class="row",
                                              tags$div(class="col-xs-6 text-center", uiOutput("pre.week.btn")),
                                              tags$div(class="col-xs-6 text-center", uiOutput("next.week.btn")))
                        ),
                        mainPanel = (
                          textOutput("dates.input")
                        )
                      ))))