如何用R创建自定义函数限制response值最大降幅为2%？

需求说明 #

当response值相较于前一日期**相对降幅超过2%**时，将其调整为仅下降2%（即取前一值的98%）；若为增长或降幅≤2%则保持原值（增长无限制）。需按area分组，每组内按日期顺序处理，且调整后的值作为下一次计算的基准（链式调整）。

原始数据集 #

# Dataset
area <- c("A","A","A","A","B","B","B","B","C","C","C","C")
dates <- c("05-01-2024","10-01-2024","18-01-2024","01-02-2024",
"05-01-2024","10-01-2024","18-01-2024","01-02-2024","05-01-2024",
"10-01-2024","18-01-2024", "01-02-2024")
response <- c(63,68,82,85,77,71,60,50,79,78,77,76)
my.ds <- data.frame(area = area, dates = dates, response = response)

尝试的无效代码 #

mutate(my.ds, response = ifelse(c(0, abs(diff(response))) < abs(response * .02), lag(response),  response),  .by = area)

期望结果 #

# my.ds.new
#  area      dates response
#1    A 2024-01-05       63
#2    A 2024-01-10       68
#3    A 2024-01-18       82
#4    A 2024-02-01       85
#5    B 2024-01-05       77
#6    B 2024-01-10       76
#7    B 2024-01-18       75
#8    B 2024-02-01       74
#9    C 2024-01-05       79
#10   C 2024-01-10       78
#11   C 2024-01-18       77
#12   C 2024-02-01       76

解决方案代码 #

library(dplyr)
library(purrr)

# 第一步：转换日期格式并按区域、日期排序（确保处理顺序正确）
my.ds <- my.ds %>%
  mutate(dates = as.Date(dates, format = "%d-%m-%Y")) %>%
  arrange(area, dates)

# 定义单步调整函数：输入上一个调整后的值和当前原始值，返回调整后的值
adjust_single <- function(prev_adjusted, curr_raw) {
  drop_ratio <- (prev_adjusted - curr_raw) / prev_adjusted
  if (drop_ratio > 0.02) {
    # 降幅超2%，返回上一值的98%
    return(prev_adjusted * 0.98)
  } else {
    # 增长或降幅≤2%，返回原始值
    return(curr_raw)
  }
}

# 第二步：按区域分组，用accumulate实现链式调整
my.ds.new <- my.ds %>%
  group_by(area) %>%
  mutate(
    response = accumulate(response, adjust_single) %>% round() # 按需取整
  ) %>%
  ungroup()

# 查看最终结果
print(my.ds.new)

代码说明 #

1. 日期处理：先将字符串格式的日期转换为标准日期类型，并按area和dates排序，保证每组内的时间顺序正确，这是链式调整的基础。
2. 单步调整逻辑：adjust_single函数判断当前原始值相对于上一个调整后值的降幅比例，超过2%则返回上一值的98%，否则保留原始值。
3. 链式处理：用purrr::accumulate函数遍历每组的response序列，逐个应用调整逻辑，确保每个值的计算依赖上一个已经调整后的结果。
4. 取整处理：最终用round()将结果取整，和期望结果的整数格式一致。

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