R语言实现含跨月周的周度数据转月度均值聚合

需求说明 #

现有包含数千个ID、覆盖3年的数据集，每条记录对应一周的起始/结束日期及weight值。需要实现：

• 按ID+月份聚合weight的均值，跨两个月的周需同时计入两个月份的计算（按该周在每个月的天数占比加权）
• 生成Monthly_weight列：同一ID同一月份的所有周记录对应相同的月度均值
• 生成Month列，格式为MM.YYYY

示例数据 #

期望输出 #

此前尝试的问题 #

1. zoo包方案：执行z <- c(z.st, z.en)时触发Error in bind.zoo(...) : indexes overlap，因为起止日期存在重复索引，无法直接合并

library(zoo)
z.st <- read.zoo(long_weights[c("start_date", "weight")])
z.en <- read.zoo(long_weights[c("end_date", "weight")])
z <- c(z.st, z.en) # 报错：索引重叠

g <- zoo(, seq(start(z), end(z), "day"))
m <- na.locf(merge(z, g))
aggregate(m, as.yearmon, mean)

2. dplyr分组方案：仅按周中间日期归属月份，无法处理跨月周的拆分计算

df <- df %>% 
  group_by(HHKEY, month = floor_date((as.Date(end_date)- as.Date(start_date))/2 + as.Date(start_date), "month")) %>% 
  mutate(monthly_weight = mean(weight), .after = end_date, month = format(month, "%Y.%m")) %>% 
  ungroup()

解决方案 #

采用按天拆分+加权聚合的思路，用tidyverse和lubridate实现：

步骤1：数据格式预处理 #

先将weight的逗号替换为小数点（转为数值型），日期转为Date格式：

library(tidyverse)
library(lubridate)

# 加载并清洗数据
df <- tibble(
  ID = c(60,60,60,60,60,61,61),
  weight = c("1,2","1,4","1,3","1,0","3,8","1,7","12,9") %>% 
    str_replace(",", ".") %>% 
    as.numeric(),
  start_date = ymd(c("2019-12-30","2020-01-06","2020-01-13","2020-01-20","2020-01-27","2019-12-30","2020-01-06")),
  end_date = ymd(c("2020-01-05","2020-01-12","2020-01-19","2020-01-26","2020-02-02","2020-01-05","2020-01-12"))
)

步骤2：计算月度加权权重 #

拆分每条周记录到对应月份，按天数占比计算权重贡献，再聚合月度均值：

# 计算每个ID的月度加权权重
monthly_weights <- df %>%
  rowwise() %>%
  mutate(
    # 生成该周覆盖的所有日期
    date_sequence = list(seq(start_date, end_date, by = "day")),
    # 统计该周在每个月份的天数
    month_day_count = list(
      tibble(date = date_sequence) %>%
        mutate(month = floor_date(date, "month")) %>%
        count(month, name = "days_in_month")
    )
  ) %>%
  unnest(month_day_count) %>%
  mutate(
    total_week_days = as.integer(end_date - start_date + 1),
    # 计算该周对每个月份的权重贡献
    weighted_weight = weight * (days_in_month / total_week_days)
  ) %>%
  # 按ID+月份聚合，得到月度均值
  group_by(ID, month) %>%
  summarise(
    Monthly_weight = sum(weighted_weight) %>% round(2),
    .groups = "drop"
  ) %>%
  mutate(Month = format(month, "%m.%Y"))

步骤3：关联回原数据集 #

将月度权重匹配到原每条周记录，确保跨月周能关联到对应的月份：

# 关联原数据与月度权重
final_result <- df %>%
  rowwise() %>%
  mutate(
    # 找出该周涉及的所有月份
    involved_months = list(unique(floor_date(seq(start_date, end_date, by = "day"), "month")))
  ) %>%
  unnest(involved_months) %>%
  left_join(monthly_weights, by = c("ID", "involved_months" = "month")) %>%
  # 整理列顺序，匹配期望输出
  select(ID, weight, start_date, end_date, Monthly_weight, Month) %>%
  arrange(ID, start_date)

# 如需将weight转回逗号分隔格式，可执行：
# final_result <- final_result %>% mutate(weight = str_replace(as.character(weight), "\\.", ","),
#                                        Monthly_weight = str_replace(as.character(Monthly_weight), "\\.", ","))

方案优势 #

• 准确处理跨月周：按实际天数占比拆分权重，保证月度均值的合理性
• 适配大规模数据：避免循环，用向量化操作处理数千个ID的3年数据
• 灵活扩展：可根据需求调整权重计算逻辑（如按工作日占比等）

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