Menu
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.
985
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 :
# 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 (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 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)
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With