如何在单个R Shiny应用中为多ID数据框生成多条独立timevis时间轴

需求说明 #

• 原有单ID应用可实现：顶部展示text字段输出，下方生成分组timevis时间轴，侧边栏下拉选择DF类型可切换对应时间戳数据
• 适配新增的多ID数据框，为每个ID单独生成独立的timevis时间轴，所有时间轴纵向排列在同一页面
• 保留原有按DF类型切换时间轴内容的功能

原有单ID示例代码 #

library(timevis)
library(shiny)
library(shinydashboard)
library(lubridate)

df_original <- data.frame(id =c(1),
                 text1 =c('d'),
                 text2 =c('h'),
                 text3 =c('l'),
                 time1 =c('2019-01-08 20:30:00'),
                 time2 =c('2019-01-08 20:40:00'),
                 time3 =c('2019-01-08 20:50:00'),
                 time4 =c('2019-01-08 21:00:00'),
                 time5 =c('2019-01-08 20:48:00'),
                 time6 =c('2019-01-08 20:34:00'))

df_original$time1 <- as.POSIXct(df_original$time1,format="%Y-%m-%d %H:%M:%S")
df_original$time2 <- as.POSIXct(df_original$time2,format="%Y-%m-%d %H:%M:%S")
df_original$time3 <- as.POSIXct(df_original$time3,format="%Y-%m-%d %H:%M:%S")
df_original$time4 <- as.POSIXct(df_original$time4,format="%Y-%m-%d %H:%M:%S")
df_original$time5 <- as.POSIXct(df_original$time5,format="%Y-%m-%d %H:%M:%S")
df_original$time6 <- as.POSIXct(df_original$time6,format="%Y-%m-%d %H:%M:%S")

##############################################UI

header <- dashboardHeader(title = "")

#Sidebar
sidebar <- dashboardSidebar(
  #DF type menu
  selectInput(inputId = 'df',
              label = 'Type of DF',
              choices = c('DF1', 'DF2', 'DF3', 'DF4'),
              selected = 'DF1')
)

#Text Row
frow1 <- fluidRow(box(width = 12,
                      splitLayout(
                        textOutput("text1"),
                        textOutput("text2"),
                        textOutput('text3'))
))

#Timeline Row
frow2 <- fluidRow(box(timevisOutput("timeline"),width = NULL
                      ))

#Body function
body <- dashboardBody(frow1,frow2)

#UI aggregation
ui <- dashboardPage(header, sidebar, body, skin = 'black')

###############################Server
server <- function(input, output, session){
  
  #Converting Df original to timevis ready data
  
  Summary <- reactive({
    #Transposing
    agg <- data.frame(r1=names(df_original), t(df_original))
    colnames(agg) <- c("content","start")
    #Removing text columns
    agg <- agg[-c(1,2,3,4),]
    #Adding group id
    agg$group <- c(1,2,3,4,1,2)
    #Rearranging columns
    agg <- agg[c(2,3,1)]
    agg$start <- ymd_hms(agg$start)
    agg$content <- as.factor(agg$content)
    #Adding section column to tell which timestamp belong to which DF when switching
    agg$section <- c(4,2,3,4,3,2)
    agg$section <- as.numeric(agg$section)
    return(data.frame(agg))
  })
  
  
  #if condition for DF1,DF2,DF3,DF4
  
  df <-reactive({
    if (input$df == "DF2") {
      df <- Summary()[which(Summary()$section == 2),]
    }
    else if (input$df == "DF3") {
      df <- Summary()[Summary()$section == 3,]
    }
    else if (input$df == "DF4") {
      df <- Summary()[(Summary()$section == 4),]
    }
    else {
      df <- Summary()
    }
    return(df)
  })
  
  output$timeline <- renderTimevis(
    timevis(
      df(),
      groups = data.frame(id = 1:4, content = c('Group1','Group2','Group3','Group4'))
      ,options = list( showCurrentTime = FALSE)
    )
  )
  
  output$text1 <- renderText({paste("Text1:", df_original$text1)})
  output$text2 <- renderText({paste("Text2:", df_original$text2)})
  output$text3 <- renderText({paste("Text3:", df_original$text3)})

}

#####################################Execution
shinyApp(ui, server)

新多ID数据源 #

df_original <- data.frame(id =c(1,2,3,4),
                 text1 =c('a','b','c','d'),
                 text2 =c('e','f','g','h'),
                 text3 =c('i','j','k','l'),
                 time1 =c('2019-01-08 20:00:00','2019-01-08 20:35:00','2019-01-08 21:10:00','2019-01-08 20:30:00'),
                 time2 =c('2019-01-08 20:10:00','2019-01-08 20:50:00','2019-01-08 21:00:00','2019-01-08 20:40:00'),
                 time3 =c('2019-01-08 21:20:00','2019-01-08 20:40:00','2019-01-08 21:20:00','2019-01-08 20:50:00'),
                 time4 =c('2019-01-08 22:30:00','2019-01-08 20:45:00','2019-01-08 21:30:00','2019-01-08 21:00:00'),
                 time5 =c('2019-01-08 20:23:00','2019-01-08 20:55:00','2019-01-08 21:23:00','2019-01-08 20:48:00'),
                 time6 =c('2019-01-08 20:16:00','2019-01-08 20:48:00','2019-01-08 21:16:00','2019-01-08 20:34:00'))

# 统一转换时间列格式
time_cols <- grep("time", names(df_original), value = T)
df_original[time_cols] <- lapply(df_original[time_cols], as.POSIXct, format="%Y-%m-%d %H:%M:%S")

适配后完整可运行代码 #

library(timevis)
library(shiny)
library(shinydashboard)
library(lubridate)
library(dplyr)
library(purrr)

# 多ID数据源
df_original <- data.frame(id =c(1,2,3,4),
                 text1 =c('a','b','c','d'),
                 text2 =c('e','f','g','h'),
                 text3 =c('i','j','k','l'),
                 time1 =c('2019-01-08 20:00:00','2019-01-08 20:35:00','2019-01-08 21:10:00','2019-01-08 20:30:00'),
                 time2 =c('2019-01-08 20:10:00','2019-01-08 20:50:00','2019-01-08 21:00:00','2019-01-08 20:40:00'),
                 time3 =c('2019-01-08 21:20:00','2019-01-08 20:40:00','2019-01-08 21:20:00','2019-01-08 20:50:00'),
                 time4 =c('2019-01-08 22:30:00','2019-01-08 20:45:00','2019-01-08 21:30:00','2019-01-08 21:00:00'),
                 time5 =c('2019-01-08 20:23:00','2019-01-08 20:55:00','2019-01-08 21:23:00','2019-01-08 20:48:00'),
                 time6 =c('2019-01-08 20:16:00','2019-01-08 20:48:00','2019-01-08 21:16:00','2019-01-08 20:34:00'))

# 转换时间列格式
time_cols <- grep("time", names(df_original), value = T)
df_original[time_cols] <- lapply(df_original[time_cols], as.POSIXct, format="%Y-%m-%d %H:%M:%S")
id_list <- unique(df_original$id)
group_df <- data.frame(id = 1:4, content = c('Group1','Group2','Group3','Group4'))

##############################################UI
header <- dashboardHeader(title = "多ID时间轴展示")

sidebar <- dashboardSidebar(
  selectInput(inputId = 'df_type',
              label = 'Type of DF',
              choices = c('DF1', 'DF2', 'DF3', 'DF4'),
              selected = 'DF1')
)

body <- dashboardBody(
  uiOutput("all_timelines")
)

ui <- dashboardPage(header, sidebar, body, skin = 'black')

###############################Server
server <- function(input, output, session){
  
  # 按ID预处理所有时间轴数据
  all_summary <- reactive({
    map_dfr(id_list, function(curr_id){
      curr_data <- df_original %>% filter(id == curr_id)
      agg <- data.frame(r1=names(curr_data), t(curr_data))
      colnames(agg) <- c("content","start")
      agg <- agg[-c(1,2,3,4),] # 剔除id和text列
      agg$group <- c(1,2,3,4,1,2)
      agg <- agg[c(2,3,1)]
      agg$start <- ymd_hms(agg$start)
      agg$content <- as.factor(agg$content)
      agg$section <- c(4,2,3,4,3,2)
      agg$section <- as.numeric(agg$section)
      agg$id <- curr_id
      return(agg)
    })
  })
  
  # 按选择的DF类型过滤数据
  filtered_data <- reactive({
    df <- all_summary()
    if (input$df_type == "DF2") {
      df <- df %>% filter(section == 2)
    } else if (input$df_type == "DF3") {
      df <- df %>% filter(section == 3)
    } else if (input$df_type == "DF4") {
      df <- df %>% filter(section == 4)
    }
    return(df)
  })
  
  # 动态生成所有ID的时间轴和对应text展示
  output$all_timelines <- renderUI({
    map(id_list, function(curr_id){
      curr_text <- df_original %>% filter(id == curr_id)
      tagList(
        fluidRow(
          box(width = 12,
            h3(paste0("ID：", curr_id)),
            splitLayout(
              paste0("Text1：", curr_text$text1),
              paste0("Text2：", curr_text$text2),
              paste0("Text3：", curr_text$text3)
            )
          )
        ),
        fluidRow(
          box(timevisOutput(paste0("timeline_", curr_id)), width = NULL)
        )
      )
    })
  })
  
  # 循环渲染每个ID的时间轴
  observe({
    df <- filtered_data()
    walk(id_list, function(curr_id){
      output[[paste0("timeline_", curr_id)]] <- renderTimevis({
        timevis(
          df %>% filter(id == curr_id),
          groups = group_df,
          options = list(showCurrentTime = FALSE)
        )
      })
    })
  })
}

#####################################Execution
shinyApp(ui, server)

适配说明 #

• 修正了原多ID数据框重复列名的问题，将后两个time1重命名为time5、time6
• 使用purrr包的循环函数批量处理每个ID的数据、生成UI元素、渲染时间轴
• 所有ID的时间轴纵向排列，每个时间轴上方对应展示该ID的text字段
• 完全保留原有侧边栏切换DF类型的功能，切换时所有ID的时间轴同步更新

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