如何自动化实现每日重复Logistic Regression建模？

问题背景 #

我拥有一份包含用户年龄、地址及过往行为的数据集，已知用户执行特定行为的日期，需构建Logistic Regression模型识别任意日期最可能执行该行为的用户。目前可按日构建数据集（sex为静态变量，events为过往行为累计值，address可能变动，outcome为当日是否执行目标行为），训练模型并计算预测概率，但数据集覆盖数年、包含数千用户与事件，手动逐日建模不可行。最终需求是每日按预测概率筛选Top1%、2%、3%的用户，并与另一模型对比，寻求自动化实现方案。

手动建模示例（仅作参考）：

day_one_data = data.frame(sex=c(1, 0, 1, 1, 1, 0, 1, 0),
events=c(0, 1, 0, 4, 2, 0, 1, 0),
age=c(21, 18, 40, 18, 19, 35, 22, 39),
address=c(4, 1, 2, 3, 3, 1, 3, 4),
outcome=c(0, 0, 0, 1, 1, 1, 0, 0)
)

model <- glm(outcome~sex+events+age+address, family = "binomial",  data=day_one_data)

day_one_data$outcome_prob <- predict(model, day_one_data, type="response")

补充数据集结构：

full_data <- data.frame(ID = c(1,2,3,4,2,1,5,6,6,4), 
sex = c("Male", "Female", "Male", "Male", "Female", "Male", "Male", "Male", "Male", "Male"), 
event_date = c("2019-09-27 150021043000000585680090","2019-10-01 150021043000000585680090","2019-11-24 150021043000000585680090","2019-12-09 150021043000000585680090","2020-01-01 150021043000000585680090","2020-02-01 150021043000000585680090","2020-03-01 150021043000000585680090","2020-04-10 150021043000000585680090", "2020-05-12 150021043000000585680090","2020-06-12 150021043000000585680090"), 
age = c(20, 22, 24, 19, 22, 21, 35, 24, 24, 20), 
previous_events = c(0, 0, 0, 0, 1, 1, 0, 0, 1, 1), 
address = c("A123", "B123", "C123", "A123", "B123", "A123", "D123", "B123", "B123", "A1234" ))

自动化实现方案 #

1. 数据预处理 #

先统一日期格式，提取完整用户列表与日期序列，为批量处理做准备：

library(dplyr)
library(lubridate)
library(purrr)

# 清洗原始数据，提取纯日期
full_data_clean <- full_data %>%
  mutate(event_date = as_date(str_sub(event_date, 1, 10))) %>%
  mutate(sex = ifelse(sex == "Male", 1, 0),
         address = as.factor(address))

# 获取所有唯一用户的静态信息（若address会变动，需构建用户-日期-地址映射表）
all_users <- full_data_clean %>%
  distinct(ID, sex, address)

# 获取所有存在事件的日期序列
all_dates <- full_data_clean %>%
  pull(event_date) %>%
  unique() %>%
  sort()

2. 批量建模与预测函数 #

编写单日报处理函数，自动生成当日特征、训练模型、计算概率并筛选高百分位用户：

# 单日报处理逻辑
process_single_day <- function(target_date) {
  # 生成当日全量用户数据集
  daily_data <- all_users %>%
    mutate(date = target_date,
           # 计算当日用户年龄（基于首次记录的年龄+时间差）
           first_age = map_dbl(ID, ~full_data_clean %>% filter(ID == .x) %>% slice(1) %>% pull(age)),
           first_date = map_dbl(ID, ~full_data_clean %>% filter(ID == .x) %>% slice(1) %>% pull(event_date)),
           age = first_age + interval(first_date, target_date) %/% years(1),
           # 累计过往行为数
           previous_events = map_dbl(ID, ~full_data_clean %>% filter(ID == .x, event_date < target_date) %>% nrow()),
           # 当日行为标签
           outcome = ifelse(ID %in% (full_data_clean %>% filter(event_date == target_date) %>% pull(ID)), 1, 0)) %>%
    select(-first_age, -first_date)
  
  # 训练Logistic回归（罕见事件可加权重优化）
  model <- glm(outcome ~ sex + previous_events + age + address, 
               family = "binomial", 
               data = daily_data)
  
  # 预测当日行为概率
  daily_data$outcome_prob <- predict(model, daily_data, type = "response")
  
  # 标记Top1%/2%/3%用户
  daily_data <- daily_data %>%
    mutate(
      top1p = outcome_prob >= quantile(outcome_prob, 0.99, na.rm = TRUE),
      top2p = outcome_prob >= quantile(outcome_prob, 0.98, na.rm = TRUE),
      top3p = outcome_prob >= quantile(outcome_prob, 0.97, na.rm = TRUE)
    )
  
  return(list(model = model, results = daily_data))
}

# 批量处理所有日期
daily_results <- map(all_dates, process_single_day)
names(daily_results) <- as.character(all_dates)

3. 结果导出与对比 #

将每日结果导出为文件，方便与其他模型对比：

# 导出每日预测结果
walk(names(daily_results), function(date) {
  write.csv(daily_results[[date]]$results, 
            paste0("daily_prediction_", date, ".csv"),
            row.names = FALSE)
})

关键注意事项 #

• 数据不平衡优化：目标行为罕见时，可在glm中加入weights参数给正样本更高权重，或使用SMOTE方法增强样本
• 地址变动处理：若用户地址随时间变化，需提前构建ID-日期-地址的映射表，在生成每日数据时匹配当日地址
• 效率提升：数据量极大时，可使用future.apply包实现并行处理，或按月份分块批量建模

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