如何解决周度转日度数据拆分中的负值与求和方向问题？

1. 修正日期区间匹配问题 #

原数据的coll_wk是前7天累计值的结束日期，而tempdisagg默认将低频日期作为高频区间的起始日期（对应后续7天的和）。我们需要把每个周度值的锚点日期改为对应7天区间的起始日期，这样工具就能正确匹配“前7天”的总和逻辑：

library(dplyr)
library(tempdisagg)

# 为原数据添加区间起始日期：coll_wk往前推6天，得到7天区间的第一天
dat <- dat %>% mutate(coll_wk_start = coll_wk - 6)

2. 解决拆分后出现负值的问题 #

denton-cholette方法可能因趋势波动产生负值，我们可以换用线性/样条插值+非负截断+区间缩放的方式，既保证插值平滑，又确保非负和总和守恒：

方法A：基于线性插值的非负拆分 #

这种方法简单稳定，适合无明显周期的数据：

# 构造每个7天区间的中点日期，用周度值的1/7作为中点初始值
dat_mid <- dat %>%
  mutate(
    mid_date = coll_wk_start + 3,  # 7天区间的第4天（中点）
    mid_value = New_A / 7
  )

# 生成覆盖所有区间的日度日期序列
date_seq <- seq(min(dat$coll_wk_start), max(dat$coll_wk), by = "day")

# 线性插值得到初始日度值
interp_func <- approxfun(dat_mid$mid_date, dat_mid$mid_value, method = "linear", rule = 2)
initial_daily <- interp_func(date_seq)

# 截断负值（设为0）
initial_daily[initial_daily < 0] <- 0

# 按原7天区间分组，缩放日度值确保每组总和等于原周度值
daily_A <- tibble(date = date_seq, value = initial_daily) %>%
  mutate(week_group = findInterval(date, dat$coll_wk_start)) %>%
  left_join(dat %>% mutate(week_group = row_number(), original_sum = New_A), by = "week_group") %>%
  group_by(week_group) %>%
  mutate(New_A = value / sum(value) * original_sum) %>%
  ungroup() %>%
  select(date, New_A)

方法B：基于三次样条插值的平滑拆分 #

如果需要更平滑的日度曲线，可改用三次样条插值：

# 构造中点数据（同方法A）
dat_mid <- dat %>%
  mutate(
    mid_date = coll_wk_start + 3,
    mid_value = New_A / 7
  )

# 生成日度日期序列
date_seq <- seq(min(dat$coll_wk_start), max(dat$coll_wk), by = "day")

# 自然三次样条插值
spline_func <- splinefun(dat_mid$mid_date, dat_mid$mid_value, method = "natural")
initial_daily <- spline_func(date_seq)

# 截断负值并缩放（同方法A）
daily_A <- tibble(date = date_seq, value = initial_daily) %>%
  mutate(week_group = findInterval(date, dat$coll_wk_start)) %>%
  left_join(dat %>% mutate(week_group = row_number(), original_sum = New_A), by = "week_group") %>%
  mutate(value = ifelse(value < 0, 0, value)) %>%
  group_by(week_group) %>%
  mutate(New_A = value / sum(value) * original_sum) %>%
  ungroup() %>%
  select(date, New_A)

方法C：修正tempdisagg结果的负值问题 #

如果坚持使用tempdisagg，可以在拆分后对负值进行截断并重新缩放：

# 用调整后的起始日期进行拆分
dat_A <- dat %>% select(coll_wk_start, New_A) %>% rename(date = coll_wk_start, value = New_A)
disagg_result <- td(value ~ 1, data = dat_A, to = "daily", method = "denton-cholette", conversion = "sum")$values

# 生成日度日期序列
date_seq <- seq(min(dat$coll_wk_start), max(dat$coll_wk), by = "day")

# 截断负值并缩放
daily_A <- tibble(date = date_seq, value = disagg_result) %>%
  mutate(week_group = findInterval(date, dat$coll_wk_start)) %>%
  left_join(dat %>% mutate(week_group = row_number(), original_sum = New_A), by = "week_group") %>%
  mutate(value = ifelse(value < 0, 0, value)) %>%
  group_by(week_group) %>%
  mutate(New_A = value / sum(value) * original_sum) %>%
  ungroup() %>%
  select(date, New_A)

3. 批量处理New_B字段 #

以上方法均可直接复制用于New_B字段，只需将代码中的New_A替换为New_B即可。

验证结果 #

可以通过以下代码验证每个7天区间的总和是否等于原周度值：

# 验证New_A的拆分结果
daily_A %>%
  mutate(week_end = date + 6) %>%  # 每个日期对应的区间结束日期
  group_by(week_end) %>%
  summarise(daily_sum = sum(New_A)) %>%
  left_join(dat %>% select(coll_wk, original_sum = New_A), by = c("week_end" = "coll_wk")) %>%
  mutate(diff = daily_sum - original_sum)

所有diff值应接近0（浮点误差范围内），且所有New_A值均非负。

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