7

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.

3 Answers 3

15
+100

EDIT 2017-10-13: This function is now avalaible in package shinyWidgets (with a different name : sliderTextInput()).

You can use this custom slider function. It takes a character vector for choices, so you can use whatever you want as format and step through the choices. The downside is that you have to manually split the input in the server :

app example :

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

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)
}
3
  • Hi @Victorp what is the name of the function in shinyWidgets? I'm not finding it.
    – Phil
    Oct 19, 2017 at 17:21
  • UPDATE: I think I found it - sliderTextInput() in the version on your Github repo, correct?
    – Phil
    Oct 19, 2017 at 17:27
  • Yep that's the one, also available on CRAN now, i'll put the name in the edit.
    – Victorp
    Oct 20, 2017 at 9:09
5

Victorp solution works great, kudos! I'll post the code of the final solution integrated with the op. If anyone else wants to run this code, don't forget to include Victorp's sliderValues function.

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

Update that the "controlLabel" function has been superseded by "shinyInputLabel". Make sure to substitute the latter for the former in the sliderValues function.

1

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.