我对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代码。如果是这样，需要如何更改我的代码以反映我的需求？
谢谢。
答案 0 :(得分：12)
编辑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 <- 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)
}
答案 1 :(得分：4)
Victorp解决方案很有效，值得称赞！我将发布与op集成的最终解决方案的代码。如果其他人想要运行此代码，请不要忘记包含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)