如何高效加速R中序列表达式触发检测代码？

背景信息 #

数据集与规则定义 #

生成数据集的代码：

set.seed(1)
n <- 100
df <- data.frame(
  x = sample(1:30, n, replace = T),
  y = sample(1:30, n, replace = T),
  z = sample(1:30, n, replace = T)
)

规则表达式向量：

rules <- c("df$x[i] < df$y[i-2] - df$x[i]", 
           "df$y[i] >= mean(df$x)",
           "df$y[i] == 20",
           "df$z[i-30] >= df$x[5]",
           "df$y[i-5] == 16",
           "df$x[10] > sd(as.matrix(df[(i-5):i,]))")

原检测函数seq_rules #

该函数按顺序检测规则触发，触发一条规则后立即切换到下一条，直到所有规则触发或遍历完数据：

seq_rules <- function(df, rules, show=T){
  
ln <- length(rules)
res <- matrix(0,nrow = ln, ncol = 2, dimnames = list(NULL, c("row","res")))
n <- 1

  for(i in 30:nrow(df)){
    if(eval(str2expression(rules[n]))){
      res[n,"row"] <- i
      res[n,"res"] <- 1
      if(show) print( cbind.data.frame(df[i,], rule=rules[n], row=i))
      n <- n+1
    }
    if(n>ln) break
  }
res
}

现有优化尝试 #

已将规则预编译为函数，实现小幅提速：

Frules <- lapply(rules,\(x) eval(str2expression(paste("function(i) {", x ,"}"))))

优化后的函数Fseq_rules：

Fseq_rules <- function(df, rules){
  ln <- length(rules)
  res <- matrix(0,nrow = ln, ncol = 2, dimnames = list(NULL, c("row","res")))
  n <- 1
for(i in 30:nrow(df)){
    if(rules[[n]](i)){
        res[n,"row"] <- i
        res[n,"res"] <- 1
        n <- n+1
      }
    if(n>ln) break
  }
  res
}

进一步优化方案 #

1. 预计算静态值，避免重复计算 #

规则中存在mean(df$x)、df$x[5]等不随i变化的静态项，提前计算并注入预编译函数，减少循环内的重复计算：

# 预计算静态值
static_vals <- list(
  mean_x = mean(df$x),
  x5 = df$x[5],
  x10 = df$x[10]
)

# 编译规则函数时替换静态值
Frules_opt <- lapply(rules, function(rule_str) {
  rule_str <- gsub("mean\\(df\\$x\\)", "static_vals$mean_x", rule_str)
  rule_str <- gsub("df\\$x\\[5\\]", "static_vals$x5", rule_str)
  rule_str <- gsub("df\\$x\\[10\\]", "static_vals$x10", rule_str)
  eval(str2expression(paste("function(i, df, static_vals) {", rule_str ,"}")))
})

# 优化后的检测函数
Fseq_rules_opt <- function(df, rules, static_vals){
  ln <- length(rules)
  res <- matrix(0L, nrow = ln, ncol = 2, dimnames = list(NULL, c("row","res")))
  n <- 1L
  max_i <- nrow(df)
  
  for(i in 30L:max_i){
    if(rules[[n]](i, df, static_vals)){
      res[n,"row"] <- i
      res[n,"res"] <- 1L
      n <- n + 1L
      if(n > ln) break
    }
  }
  res
}

2. 用矩阵替代数据框，优化访问速度 #

数据框的列索引（df$x[i]）比矩阵访问慢，提前将df转为矩阵，规则中改用矩阵索引：

# 转换为矩阵
df_mat <- as.matrix(df)

# 编译适配矩阵的规则函数
Frules_mat <- lapply(rules, function(rule_str) {
  # 替换数据框索引为矩阵索引
  rule_str <- gsub("df\\$x\\[(.*?)\\]", "df_mat[\\1,1]", rule_str)
  rule_str <- gsub("df\\$y\\[(.*?)\\]", "df_mat[\\1,2]", rule_str)
  rule_str <- gsub("df\\$z\\[(.*?)\\]", "df_mat[\\1,3]", rule_str)
  # 替换静态值
  rule_str <- gsub("mean\\(df\\$x\\)", "static_vals$mean_x", rule_str)
  rule_str <- gsub("df\\$x\\[5\\]", "static_vals$x5", rule_str)
  rule_str <- gsub("df\\$x\\[10\\]", "static_vals$x10", rule_str)
  eval(str2expression(paste("function(i, df_mat, static_vals) {", rule_str ,"}")))
})

# 矩阵版检测函数
Fseq_rules_mat <- function(df_mat, rules, static_vals){
  ln <- length(rules)
  res <- matrix(0L, nrow = ln, ncol = 2, dimnames = list(NULL, c("row","res")))
  n <- 1L
  max_i <- nrow(df_mat)
  
  for(i in 30L:max_i){
    if(rules[[n]](i, df_mat, static_vals)){
      res[n,"row"] <- i
      res[n,"res"] <- 1L
      n <- n + 1L
      if(n > ln) break
    }
  }
  res
}

3. 预计算规则结果，减少循环次数 #

对可批量计算的规则，提前生成所有i>=30的触发结果，直接定位第一个触发位置，避免逐次循环判断：

# 批量预处理所有规则的触发结果
precompute_rule_results <- function(df_mat, static_vals) {
  max_row <- nrow(df_mat)
  list(
    rule1 = df_mat[30:max_row,1] < df_mat[(30-2):(max_row-2),2] - df_mat[30:max_row,1],
    rule2 = df_mat[30:max_row,2] >= static_vals$mean_x,
    rule3 = df_mat[30:max_row,2] == 20,
    rule4 = df_mat[30:max_row,3] >= static_vals$x5,
    rule5 = df_mat[(30-5):(max_row-5),2] == 16,
    rule6 = sapply(30:max_row, function(i) {
      static_vals$x10 > sd(df_mat[(i-5):i,])
    })
  )
}

# 基于预计算结果的检测函数
seq_rules_precomp <- function(df_mat, rule_results) {
  ln <- length(rule_results)
  res <- matrix(0L, nrow = ln, ncol = 2, dimnames = list(NULL, c("row","res")))
  current_start <- 1L # 对应原i=30的起始位置
  max_pos <- length(rule_results[[1]])
  
  for(n in 1L:ln){
    # 找到当前规则在剩余位置中第一个触发的索引
    trigger_pos <- which(rule_results[[n]][current_start:max_pos])[1]
    if(is.na(trigger_pos)) break # 无触发则终止
    actual_row <- 30 + current_start + trigger_pos - 2L
    res[n,"row"] <- actual_row
    res[n,"res"] <- 1L
    current_start <- current_start + trigger_pos # 更新下一条规则的起始位置
  }
  res
}

结果一致性验证 #

以上优化方案未改变规则逻辑，仅优化计算效率，可通过以下代码验证结果与原函数一致：

# 生成原函数结果
set.seed(1)
n <- 100
df <- data.frame(
  x = sample(1:30, n, replace = T),
  y = sample(1:30, n, replace = T),
  z = sample(1:30, n, replace = T)
)
res_original <- seq_rules(df, rules, show=F)

# 生成优化后函数结果
static_vals <- list(mean_x = mean(df$x), x5=df$x[5], x10=df$x[10])
df_mat <- as.matrix(df)
Frules_mat <- lapply(rules, function(rule_str) {
  rule_str <- gsub("df\\$x\\[(.*?)\\]", "df_mat[\\1,1]", rule_str)
  rule_str <- gsub("df\\$y\\[(.*?)\\]", "df_mat[\\1,2]", rule_str)
  rule_str <- gsub("df\\$z\\[(.*?)\\]", "df_mat[\\1,3]", rule_str)
  rule_str <- gsub("mean\\(df\\$x\\)", "static_vals$mean_x", rule_str)
  rule_str <- gsub("df\\$x\\[5\\]", "static_vals$x5", rule_str)
  rule_str <- gsub("df\\$x\\[10\\]", "static_vals$x10", rule_str)
  eval(str2expression(paste("function(i, df_mat, static_vals) {", rule_str ,"}")))
})
res_opt <- Fseq_rules_mat(df_mat, Frules_mat, static_vals)

# 对比结果
all.equal(res_original, res_opt) # 输出应为TRUE

内容的提问来源于stack exchange，提问作者mr.T