在R中计算非连续事件的时长及行为发生顺序

输入数据 #

我有一组来自视频观测的行为数据，每个行为记录了开始/结束时间，多个时间段用+分隔，输入数据如下：

datain <- data.frame(
  A=c("1/5+11/18","0/5","7/10"),
  B=c("6/10+19/25","11/15","11/20"),
  C=c("26/30","6/10","0/6")
)

期望输出 #

需要计算每个行为的总时长，同时生成每一行观测的行为发生顺序，最终输出如下：

dataout <- data.frame(
  A=c("1/5+11/18","0/5","7/10"),
  B=c("6/10+19/25","11/15","11/20"),
  C=c("26/30","6/10","0/6"),
  A.sum=c(11,5,3),
  B.sum=c(10,4,9),
  C.sum=c(4,4,6),
  myorder=c("A/B/A/B/C","A/C/B","C/A/B")
)

现有尝试 #

最初尝试识别含+的列并拆分行为，但未完成时长计算，代码如下：

d.1 <- lapply(datain, function(x) str_which(x,"\\+"))
d.2 <- which(lapply(d.1,length)>0)
coltosum <- match(names(d.2),colnames(datain))

mylist <- lapply(datain[coltosum],function(x) strsplit(x,"\\+"))

后续已实现行为顺序的获取，但代码过于繁琐，具体实现如下：

# 移除空列
empty_columns <- sapply(datain, function(x) all(is.na(x) | x == ""))
datain<- datain[, !empty_columns]

# 循环1：提取行为的时间数值
mylist <- list()

for (i in seq(1,nrow(datain))){
mylist <- apply(datain,1,str_extract_all,pattern="\\d+")
myindx <- sapply(mylist, length)
myres <- c(do.call(cbind,lapply(mylist, `length<-`,max(myindx))))
names(myres) <- rep(colnames(datain),nrow(datain))
mydf <- ldply(myres,data.frame)
colnames(mydf) <- c("BH","values")
}

# 循环2：统计每行的元素数量
mydf.1 <- list()
myres.2 <- list()

for (i in seq(1,nrow(datain))){
mydf.1 <- length(unlist(mylist[i]))
myres.2[i] <- mydf.1
}

# 添加行号信息
names(myres.2) <- rownames(datain)
myres.3 <- as.numeric(myres.2)

mydf$myrow <- c(rep(rownames(datain),myres.3))

# 按行号和数值排序
mydf <- mydf[order(as.numeric(mydf$myrow),as.numeric(mydf$values)),]

# 生成序列并筛选起始行
myseq <- sequence(myres.3)
mydf <- cbind(mydf,myseq)

myseq.2 <- seq(1,nrow(mydf),by=2)
mydf.1 <- mydf[myseq.2,]
myorder <-split(mydf.1,mydf.1$myrow) 

# 循环3：整理行为顺序
myres.3 <- list()
for (i in seq(1,nrow(datain))){
myres.3 <- lapply(myorder,"[",i=1)
}

myorder.def <- data.frame(cbind(lapply(myres.3,paste0,collapse="/")))
colnames(myorder.def) <- "BH"

# 清理格式
myorder.def$BH <- str_replace_all(myorder.def$BH,"c","")
myorder.def$BH <- str_replace_all(myorder.def$BH,"\\(","")
myorder.def$BH <- str_replace_all(myorder.def$BH,"\\)","")
myorder.def$BH <- str_replace_all(myorder.def$BH,"\"","")
myorder.def$BH <- str_replace_all(myorder.def$BH,", ","/")

data.out <- cbind(datain,myorder.def)
data.out

希望得到更简洁高效的优化方案。

优化解决方案 #

使用tidyverse工具包（dplyr、stringr、tidyr）可以大幅简化代码，实现更清晰的逻辑：

步骤1：加载依赖包 #

library(dplyr)
library(stringr)
library(tidyr)

步骤2：计算各行为总时长 #

通过遍历所有列，拆分时间段后计算每个时间段的时长并求和：

sum_duration <- datain %>%
  mutate(across(everything(), function(time_str) {
    # 拆分多个时间段
    str_split(time_str, "\\+") %>%
      map_dbl(function(segments) {
        # 对每个时间段计算时长（结束-开始）并求和
        map_dbl(segments, ~ {
          as.integer(str_split(.x, "/")[[1]]) %>% diff()
        }) %>% sum()
      })
  })) %>%
  # 重命名列，添加.sum后缀
  rename_with(~ paste0(.x, ".sum"), everything())

步骤3：生成行为发生顺序 #

将数据转为长格式，拆分时间段后按开始时间排序，最后合并行为名称：

behavior_order <- datain %>%
  # 添加行号用于分组
  mutate(row_id = row_number()) %>%
  # 转为长格式，每行对应一个行为的一个时间段
  pivot_longer(-row_id, names_to = "behavior", values_to = "time") %>%
  # 拆分多个时间段
  mutate(time = str_split(time, "\\+")) %>%
  unnest(time) %>%
  # 拆分开始/结束时间并转为数值
  separate(time, into = c("start", "end"), sep = "/", convert = TRUE) %>%
  # 按行号和开始时间排序
  arrange(row_id, start) %>%
  # 按行分组，合并行为名称
  group_by(row_id) %>%
  summarise(myorder = paste(behavior, collapse = "/"), .groups = "drop") %>%
  # 只保留行为顺序列
  select(myorder)

步骤4：合并结果 #

将原数据、时长数据和行为顺序数据合并：

dataout <- bind_cols(datain, sum_duration, behavior_order)

执行后即可得到与期望一致的输出，代码逻辑清晰，避免了冗余循环，可读性和维护性更强。

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