R 按月的闪亮日期滑块动画（当前按天）答案

【问题标题】：R Shiny date slider animation by month (currently by day)R 按月的闪亮日期滑块动画（当前按天）
【发布时间】：2016-11-03 02:02:10
【问题描述】：

我对 R 比较满意，但对 Shiny 不太满意，尽管这不是我的第一个 Shiny 应用程序。

我有一个数据框，其中包含 lon/lat 以及每个新客户在系统中输入的日期/时间。我还根据 startDate 变量创建了其他变量，例如年、月、周、年月 (ym) 和年周 (yw)：

  id      lat       lon  startDate year month week         ym         yw
1  1 45.53814 -73.63672 2014-04-09 2014     4   15 2014-04-01 2014-04-06
2  2 45.51076 -73.61029 2014-06-04 2014     6   23 2014-06-01 2014-06-01
3  3 45.43560 -73.60100 2014-04-30 2014     4   18 2014-04-01 2014-04-27
4  4 45.54332 -73.56000 2014-05-30 2014     5   22 2014-05-01 2014-05-25
5  5 45.52234 -73.59022 2014-05-01 2014     5   18 2014-05-01 2014-04-27

我想用传单映射每个客户（已完成），但我想通过仅显示特定日期范围内的新客户来为我的应用程序设置动画。

我想逐月查看日期（ym 变量：2016-01-01、2016-02-01、2016-03-01...），而不是按天（或已支持的 x 天）因为每月的日期并不总是下个月的 30 天。这是我目前的申请：

library(shiny)
library(leaflet)
library(dplyr)

df <- data.frame(id = 1:5, 
             lat = c(45.53814, 45.51076, 45.4356, 45.54332, 45.52234), 
             lon = c(-73.63672, -73.61029, -73.6010, -73.56000, -73.59022),
             startDate = as.Date(c("2014-04-09", "2014-06-04", "2014-04-30", "2014-05-30", "2014-05-01")),
             year = c(2014, 2014, 2014, 2014, 2014),
             month = c(4, 6, 4, 5, 5),
             week = c(15, 23, 18, 22, 18),
             ym = as.Date(c("2014-04-01", "2014-06-01", "2014-04-01", "2014-05-01", "2014-05-01")),  # Year-Month
             yw = as.Date(c("2014-04-06", "2014-06-01", "2014-04-27", "2014-05-25", "2014-04-27"))   # Year-Week
             )


ui <- bootstrapPage(
  tags$style(type = "text/css", "html, body {width:100%;height:100%}"),

  leafletOutput("map", width = "83%", height = "100%"),

  absolutePanel(
top = 1,
right = 10,

div(
  style = "height: 80px;",
  sliderInput(
    "time",
    "Time Slider",
    min(df$month),
    max(df$month),
    value = c(min(df$month), max(df$month)),
    step = 1,
    animate = animationOptions(interval = 2500)

  ) # end sliderInput
) # end div
  ) # end absolutePanel
) # end bootstrapPage

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

  output$map <- renderLeaflet({
    leaflet(data = df %>% filter(month >= input$time[1], month <=             input$time[2])) %>% addTiles() %>% 
  addMarkers(~lon, ~lat) %>% 
  setView(lng = -73.6, lat = 45.52, zoom = 12)
    })
  })
shinyApp(ui = ui, server = server)

问题：如何使用滑块动画选项过滤数据以切换到下个月等？现在我循环遍历变量月份，但我有 8 年的数据，所以我还需要考虑年份，例如循环遍历 ym 变量。

我看到 here 和 here 完成了一些工作，但要么它没有响应我的需求，要么我不理解提供的 js 代码。如果是这样，如何更改我的代码以反映我的需求？

谢谢。

【问题讨论】：

标签： r shiny

【解决方案1】：

EDIT 2017-10-13：这个函数现在可以在包shinyWidgets（使用不同的名称：sliderTextInput()）中使用。

您可以使用此自定义滑块功能。它需要一个字符向量来进行选择，因此您可以使用任何您想要的格式并逐步完成选择。缺点是您必须手动拆分服务器中的输入：

应用示例：

# List of months
choices_month <- format(seq.Date(from = as.Date("2014-01-01"), by = "month", length.out = 36), "%B-%Y")

library("shiny")

# ui
ui <- fluidPage(
  br(),

  # custom slider function
  sliderValues(
    inputId = "test", label = "Month", width = "100%",
    values = choices_month, 
    from = choices_month[2], to = choices_month[6],
    grid = FALSE, animate = animationOptions(interval = 1500)
  ),
  verbatimTextOutput("res")
)

# server
server <- function(input, output, session) {
  output$res <- renderPrint({
    print(input$test) # you have to split manually the result by ";"
    print(as.Date(paste("01", unlist(strsplit(input$test, ";")), sep="-"), format="%d-%B-%Y"))
  })
}

# App
shinyApp(ui = ui, server = server)

sliderValues 函数：

sliderValues <- function (inputId,
                          label,
                          values,
                          from,
                          to = NULL,
                          grid = TRUE,
                          width = NULL,
                          postfix = NULL,
                          prefix = NULL,
                          dragRange = TRUE,
                          disable = FALSE,
                          animate = FALSE) {
  validate_fromto <-
    function(fromto = NULL,
             values = NULL,
             default = 0) {
      if (!is.null(fromto)) {
        if (is.character(values) & is.numeric(fromto)) {
          fromto <- fromto - 1
        } else {
          fromto <- which(values == fromto) - 1
        }
      } else {
        fromto <- default
      }
      return(fromto)
    }

  sliderProps <- shiny:::dropNulls(
    list(
      class = "js-range-slider",
      id = inputId,
      `data-type` = if (!is.null(to))
        "double"
      else
        "single",
      `data-from` = validate_fromto(fromto = from, values = values),
      `data-to` = validate_fromto(
        fromto = to,
        values = values,
        default = length(values)
      ),
      `data-grid` = grid,
      `data-prefix` = if (is.null(prefix)) {
        "null"
      } else {
        shQuote(prefix, "sh")
      },
      `data-postfix` = if (is.null(postfix)) {
        "null"
      } else {
        shQuote(postfix, "sh")
      },
      `data-drag-interval` = dragRange,
      `data-disable` = disable,
      `data-values` = if (is.numeric(values)) {
        paste(values, collapse = ", ")
      } else {
        paste(shQuote(values, type = "sh"), collapse = ", ")
      }
    )
  )
  sliderProps <- lapply(
    X = sliderProps,
    FUN = function(x) {
      if (identical(x, TRUE))
        "true"
      else if (identical(x, FALSE))
        "false"
      else
        x
    }
  )
  sliderTag <- tags$div(
    class = "form-group shiny-input-container",
    style = if (!is.null(width))
      paste0("width: ", htmltools::validateCssUnit(width), ";"),
    if (!is.null(label))
      shiny:::controlLabel(inputId, label),
    do.call(
      tags$input,
      list(
        type = if (is.numeric(values) &
                   is.null(to)) {
          "number"
        } else {
          "text"
        },
        #class = "js-range-slider",
        id = inputId,
        name = inputId,
        value = ""
      )
    ),
    tags$style(
      whisker::whisker.render(
        template =
          "input[id='{{id}}'] {
        -moz-appearance:textfield;
}
input[id='{{id}}']::-webkit-outer-spin-button,
input[id='{{id}}']::-webkit-inner-spin-button {
-webkit-appearance: none;
margin: 0;
}", data = list(id = inputId))
    ),
    tags$script(
      HTML(
        whisker::whisker.render(
          template = '$("#{{id}}").ionRangeSlider({
          type: "{{data-type}}",
          from: {{data-from}},
          to: {{data-to}},
          grid: {{data-grid}},
          keyboard: true,
          keyboard_step: 1,
          postfix: {{data-postfix}},
          prefix: {{data-prefix}},
          drag_interval: {{data-drag-interval}},
          values: [{{data-values}}],
          disable: {{data-disable}}
          });',
          data = sliderProps
      )
      ))
      )
  if (identical(animate, TRUE)) 
    animate <- animationOptions()
  if (!is.null(animate) && !identical(animate, FALSE)) {
    if (is.null(animate$playButton)) 
      animate$playButton <- icon("play", lib = "glyphicon")
    if (is.null(animate$pauseButton)) 
      animate$pauseButton <- icon("pause", lib = "glyphicon")
    sliderTag <- htmltools::tagAppendChild(
      sliderTag,
      tags$div(class = "slider-animate-container", 
               tags$a(href = "#", class = "slider-animate-button", 
                      `data-target-id` = inputId, `data-interval` = animate$interval, 
                      `data-loop` = animate$loop, span(class = "play", 
                                                       animate$playButton), 
                      span(class = "pause", 
                           animate$pauseButton)))
    )
  }
  dep <- htmltools::htmlDependency(
    "ionrangeslider",
    "2.1.12",
    c(href = "shared/ionrangeslider"),
    script = "js/ion.rangeSlider.min.js",
    stylesheet = c(
      "css/ion.rangeSlider.css",
      "css/ion.rangeSlider.skinShiny.css"
    )
  )
  htmltools::attachDependencies(sliderTag, dep)
}

【讨论】：

嗨@Victorp shinyWidgets 中的函数名称是什么？我没找到。
更新：我想我找到了 - sliderTextInput() 在你的 Github repo 版本中，对吗？
是的，就是这个，现在也可以在 CRAN 上使用，我会在编辑中输入名称。

【解决方案2】：

Victorp 解决方案效果很好，赞！我将发布与操作集成的最终解决方案的代码。如果其他人想运行此代码，请不要忘记包含 Victorp 的 sliderValues 函数。

library(shiny)
library(leaflet)
library(dplyr)

df <- data.frame(id = 1:5, 
             lat = c(45.53814, 45.51076, 45.4356, 45.54332, 45.52234), 
             lon = c(-73.63672, -73.61029, -73.6010, -73.56000, -73.59022),
             startDate = as.Date(c("2014-04-09", "2014-06-04", "2014-04-30", "2014-05-30", "2014-05-01")),
             year = c(2014, 2014, 2014, 2014, 2014),
             month = c(4, 6, 4, 5, 5),
             week = c(15, 23, 18, 22, 18),
             ym = as.Date(c("2014-04-01", "2014-06-01", "2014-04-01", "2014-05-01", "2014-05-01")),  # Year-Month
             yw = as.Date(c("2014-04-06", "2014-06-01", "2014-04-27", "2014-05-25", "2014-04-27"))   # Year-Week
)

# List of months
choices_month <- seq.Date(from = as.Date("2014-01-01"), by = "month", length.out = 36)

# ui
ui <- bootstrapPage(
  tags$style(type = "text/css", "html, body {width:100%;height:100%}"),

  leafletOutput("map", width = "75%", height = "100%"),

  absolutePanel(
top = 1,
right = 10,

div(
  style = "height: 180px;",
# custom slider function
sliderValues(
  inputId = "test", label = "Month", width = "100%",
  values = choices_month[4:6], 
  from = choices_month[4], to = choices_month[6],
  grid = FALSE, animate = animationOptions(interval = 1500)
), # end sliderInput
verbatimTextOutput("res")
    ) # end div
  ) # end absolutePanel
) # end bootstrapPage

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

  output$map <- renderLeaflet({
#    leaflet(data = df %>% filter(ym > as.Date(input$test[1]), ym < as.Date(input$test[2]))) %>% addTiles() %>% 
 leaflet(data = df %>% filter(ym == input$test[1])) %>% addTiles() %>% 
  addMarkers(~lon, ~lat) %>% 
  setView(lng = -73.6, lat = 45.52, zoom = 12)
  }) # end map

  output$res <- renderPrint({
    print(input$test) # you have to split manually the result by ";"
    print(as.Date(unlist(strsplit(input$test, ";"))))
    }) # end res
}) # end server

# App
shinyApp(ui = ui, server = server)

【讨论】：