Gregory W. Gregory W. - 25 days ago 19
R Question

R Shiny date slider animation by month (currently by day)

I'm somewhat comfortable with R, lot less with Shiny, though it's not my first Shiny application.

I have a data frame with lon/lat and the date/time of the entry in the system for every new customer. I also created other variables based on the startDate variable like the year, month, week, year-month (ym) and year-week (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


I want to map every customer with leaflet (this is done), but then I would like to animate my application by showing only customers who are new for a specific date range.

I would like to step through monthly dates (ym variable : 2016-01-01, 2016-02-01, 2016-03-01...) and not by day (or by x days which is already supported) because monthly dates are not always a 30 days step toward the next month.
Here is my current application:

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)


Question: How can I filter the data using the slider animation option to shift to the next month and so on? For now I cycle through the variable month, but I have data for 8 years, so I need to take into consideration the year also, thus cycling through the ym variable for example.

I saw some work done here and here, but either it's not responding to my needs or I didn't understand the suplied js code. If its the case, how a need to change my code to reflect my needs?

Thank you.

Answer

Hi you can this custom slider function, it takes character vector for choices, so you can put whatever you want as format and step, the downside is that who have to manually split the input in the server :

app exemple :

# 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 func :

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)
}
Comments