闪亮的每小时快照选项 (vis.js)

Question

无法通过 Rshiny 将 snap 选项传递给 vis.js。当我尝试传递快照选项时，我在尝试移动日历项目时遇到了奇怪的行为。

我这样分配日期：

today <- as.character(Sys.Date())

然后传递选项：

snap = list(date = today, scale = 'minute', step= 15)

我的目标是将我的日历项目捕捉到 15 分钟的增量，但我的视图的默认设置似乎是 30 分钟块。

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

Answer 1

您必须使用选项 timeAxis，而不是 snap 选项：

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)

编辑

我误解了这个问题。实际上，您需要 snap 选项。此选项必须是 JavaScript 函数。这是应用程序：

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)

闪亮的每小时快照选项 (vis.js)

Rshiny timevis snap option (vis.js)

r

shiny

vis.js

编辑