Having trouble passing the snap option to vis.js through Rshiny. When I attempt to pass the snap option, I wind up with wonky behavior when trying to move calendar items.
I assign the day like so:
today <- as.character(Sys.Date())
and then pass the option with:
snap = list(date = today, scale = 'minute', step= 15)
My goal is to snap my calendar items to 15 minute increments, but the default for my view seems to be 30 minute blocks.
if (interactive()) {
library(shiny)
starthour <- 8
today <- as.character(Sys.Date())
todayzero <- paste(today,"00:00:00")
todayAM <- paste(today,"07:00:00")
todayPM <- paste(today, "18:00:00")
items <- data.frame(
category = c("Room","IceBreaker","Activity","Break"),
group=c(1,2,3,4),
className = c ("red_point", "blue_point", "green_point","purple_point"),
content = c("Big Room","Introductions","Red Rover","Lunch"),
length = c(480,60,120,90)
)
groups <- data.frame(id= items$group, content = items$category)
data <- items %>% mutate(id = 1:4,
start = as.POSIXct(todayzero) + hours(starthour),
end = as.POSIXct(todayzero) + hours(starthour) + minutes(items$length)
)
ui <- fluidPage(
tags$head(
tags$style(HTML("
.red_point { border-color: red; border-width: 2px; }
.blue_point { border-color: blue; border-width: 2px; }
.green_point { border-color: green; border-width: 2px; }
.purple_point { border-color: purple; border-width: 2px; }
"))),
timevisOutput("appts"),
div("Selected items:", textOutput("selected", inline = TRUE)),
div("Visible window:", textOutput("window", inline = TRUE)),
tableOutput("table")
)
server <- function(input, output) {
output$appts <- renderTimevis(
timevis(
data = data,
groups = groups,
fit = TRUE,
options = list(editable = TRUE,
multiselect = TRUE,
align = "center",
stack = TRUE,
start = todayAM,
end = todayPM,
showCurrentTime = FALSE,
showMajorLabels=FALSE,
snap = list(date = today, scale = 'minute', step= 15))
)
)
output$selected <- renderText(
paste(input$appts_selected, collapse = " ")
)
output$window <- renderText(
paste(input$appts_window[1], "to", input$appts_window[2])
)
output$table <- renderTable(
input$appts_data
)
}
shinyApp(ui, server)
}
You have to use the option timeAxis
, not the snap
option:
library(shiny)
library(timevis)
data <- data.frame(
id = 1:3,
start = c("2015-04-04", "2015-04-04 02:00:00", "2015-04-04 05:00:00"),
end = c("2015-04-04 06:00:00", NA, NA),
content = c("<h2>Vacation!!!</h2>", "Acupuncture", "Massage"),
style = c("color: red;", NA, NA)
)
ui <- fluidPage(
timevisOutput("appts")
)
server <- function(input, output) {
output$appts <- renderTimevis(
timevis(
data,
options = list(
editable = TRUE,
multiselect = TRUE,
align = "center",
timeAxis = list(scale = "minute", step = 15)
)
)
)
}
shinyApp(ui, server)
I misunderstood the question. Indeed, you need the snap
option. This option must be a JavaScript function. Here is the app:
library(shiny)
library(timevis)
data <- data.frame(
id = 1:3,
start = c("2015-04-04", "2015-04-04 02:00:00", "2015-04-04 05:00:00"),
end = c("2015-04-04 06:00:00", NA, NA),
content = c("<h2>Vacation!!!</h2>", "Acupuncture", "Massage"),
style = c("color: red;", NA, NA)
)
ui <- fluidPage(
timevisOutput("appts")
)
server <- function(input, output) {
output$appts <- renderTimevis(
timevis(
data,
options = list(
editable = TRUE,
multiselect = TRUE,
align = "center",
timeAxis = list(scale = "hour", step = 1),
snap = JS(
c(
"function(date, scale, step){",
" var quarter = 15 * 60 * 1000;",
" return Math.round(date / quarter) * quarter;",
"}"
)
)
)
)
)
}
shinyApp(ui, server)