r - 添加后退/下一步按钮以 Shiny 的日期范围输入

Question

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

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

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

Answer 1

我把我的代码放在公共(public)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 -----------------

用户界面

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")
                        )
                      ))))