如何在Shiny应用中实现Highcharter甘特图节点的拖拽修改？

问题描述 #

我正在测试Highcharter的甘特图功能，编写了一个测试应用来学习该库的用法。我希望能够移动图表中的节点（比如将第一个节点提前几天），具体问题如下：

• 如何为图表添加节点移动功能？
• 如何单独修改节点的开始/结束时间？
• 如何在Shiny服务器的input$变量中捕获这些更新信息？

原始测试代码 #

library(shiny)
library(tidyverse)
library(lubridate)
library(highcharter)


data <- tibble(
  start = (today()+0.12) %>% as_datetime(), 
  end = (today()+1) %>% as_datetime(), 
  name = "Nissan Leaf", 
  id = "#1"
) %>% 
  add_row(
    start = (today()-2.2) %>% as_datetime(), 
    end = (today()+0) %>% as_datetime(), 
    name = "Tesla", 
    id = "#2"
  ) %>% 
  add_row(
    start = (today()+1.5) %>% as_datetime(), 
    end = (today()+2.2) %>% as_datetime(), 
    name = "Nissan Leaf", 
    id = "#3"
  ) %>% 
  mutate_if(is.POSIXct, datetime_to_timestamp) 

ui <- fluidPage(
  highchartOutput("hc_gantt"), 
  hr(), 
  uiOutput("click_ui")
)

server <- function(input, output) {

output$hc_gantt <- renderHighchart({
  hc_gantt <- highchart(
    type = "gantt"
  ) %>% 
    hc_add_series(
      name = "Program",
      data = data,
      grouping = list(
        groupPadding = 0.2,
        pointPadding = 0.1,
        borderWidth = 0,
        shadow = FALSE
      )
    ) %>% 
    hc_yAxis(
      uniqueNames = TRUE
    ) %>% 
    hc_add_event_point(event = "click") %>%
    hc_add_event_point(event = "mouseOver")

  hc_gantt %>% return()
})  

observe({
  print(names(input))
})

output$click_ui <- renderUI({
  if (is.null(input$hc_gantt_click)) {
    return()
  }
  
  wellPanel(
    data %>% 
      filter(
        name == input$hc_gantt_click$name,
        start == input$hc_gantt_click$x
      ) %>% 
      return()
  )
})

}

# Run the application 
shinyApp(ui = ui, server = server)

解决方案 #

1. 添加节点移动与时间修改功能 #

在hc_add_series中配置dragDrop参数，启用横向拖拽（移动整个节点）和尺寸调整（修改开始/结束时间）：

hc_add_series(
  name = "Program",
  data = data,
  grouping = list(
    groupPadding = 0.2,
    pointPadding = 0.1,
    borderWidth = 0,
    shadow = FALSE
  ),
  # 启用拖拽和调整功能
  dragDrop = list(
    draggableX = TRUE,  # 允许横向移动整个节点
    resize = list(
      enabled = TRUE,   # 允许调整节点的起止时间
      directions = "left right"  # 允许左右两端调整（对应start和end时间）
    )
  )
)

2. 单独修改节点的开始/结束时间 #

上述resize配置中的directions = "left right"已经支持单独拖动节点的左端（修改start时间）或右端（修改end时间）。如果只需要允许修改其中一端，可以设置directions为"left"（仅修改start）或"right"（仅修改end）。

3. 在Shiny中捕获更新信息 #

通过hc_add_event_series监听dragDrop和resize事件，这些事件会将更新后的节点数据传递到Shiny的input对象中：

修改图表渲染代码，添加事件监听：

output$hc_gantt <- renderHighchart({
  hc_gantt <- highchart(type = "gantt") %>% 
    hc_add_series(
      name = "Program",
      data = data,
      grouping = list(
        groupPadding = 0.2,
        pointPadding = 0.1,
        borderWidth = 0,
        shadow = FALSE
      ),
      dragDrop = list(
        draggableX = TRUE,
        resize = list(
          enabled = TRUE,
          directions = "left right"
        )
      )
    ) %>% 
    hc_yAxis(uniqueNames = TRUE) %>% 
    hc_add_event_point(event = "click") %>%
    hc_add_event_point(event = "mouseOver") %>%
    # 添加拖拽和调整事件监听
    hc_add_event_series(event = "dragDrop") %>%
    hc_add_event_series(event = "resize")

  hc_gantt
})

在Server中捕获并处理事件数据：

添加观察者来监听input$hc_gantt_dragDrop和input$hc_gantt_resize，从中获取更新后的节点信息：

observeEvent(input$hc_gantt_dragDrop, {
  # 拖拽事件返回的数据包含更新后的start、end、id等信息
  updated_data <- input$hc_gantt_dragDrop
  cat("拖拽更新的节点信息：\n")
  print(updated_data)
})

observeEvent(input$hc_gantt_resize, {
  # 调整尺寸事件返回的数据包含更新后的start、end、id等信息
  updated_data <- input$hc_gantt_resize
  cat("调整尺寸更新的节点信息：\n")
  print(updated_data)
})

完整修改后的代码 #

library(shiny)
library(tidyverse)
library(lubridate)
library(highcharter)

data <- tibble(
  start = (today()+0.12) %>% as_datetime(), 
  end = (today()+1) %>% as_datetime(), 
  name = "Nissan Leaf", 
  id = "#1"
) %>% 
  add_row(
    start = (today()-2.2) %>% as_datetime(), 
    end = (today()+0) %>% as_datetime(), 
    name = "Tesla", 
    id = "#2"
  ) %>% 
  add_row(
    start = (today()+1.5) %>% as_datetime(), 
    end = (today()+2.2) %>% as_datetime(), 
    name = "Nissan Leaf", 
    id = "#3"
  ) %>% 
  mutate_if(is.POSIXct, datetime_to_timestamp) 

ui <- fluidPage(
  highchartOutput("hc_gantt"), 
  hr(), 
  verbatimTextOutput("update_info")  # 用于显示更新信息
)

server <- function(input, output) {

output$hc_gantt <- renderHighchart({
  highchart(type = "gantt") %>% 
    hc_add_series(
      name = "Program",
      data = data,
      grouping = list(
        groupPadding = 0.2,
        pointPadding = 0.1,
        borderWidth = 0,
        shadow = FALSE
      ),
      dragDrop = list(
        draggableX = TRUE,
        resize = list(
          enabled = TRUE,
          directions = "left right"
        )
      )
    ) %>% 
    hc_yAxis(uniqueNames = TRUE) %>% 
    hc_add_event_point(event = "click") %>%
    hc_add_event_point(event = "mouseOver") %>%
    hc_add_event_series(event = "dragDrop") %>%
    hc_add_event_series(event = "resize")
})  

# 捕获拖拽事件
observeEvent(input$hc_gantt_dragDrop, {
  output$update_info <- renderPrint({
    cat("拖拽事件更新：\n")
    str(input$hc_gantt_dragDrop)
  })
})

# 捕获调整尺寸事件
observeEvent(input$hc_gantt_resize, {
  output$update_info <- renderPrint({
    cat("尺寸调整事件更新：\n")
    str(input$hc_gantt_resize)
  })
})

}

shinyApp(ui = ui, server = server)

内容的提问来源于stack exchange，提问作者Jochem