如何基于带间隙的鸡群观测数据计算产蛋与孵化日期

需要从记录鸡产蛋/孵化幼雏的DataFrame中，为每个唯一nestyear（巢年度）组合计算首次产蛋日期和首次孵化日期，需遵循给定的观测间隙规则，同时排除首次观测即为蛋或幼雏的记录（对应日期设为NA）。

计算规则 #

核心逻辑（产蛋/孵化通用，仅需替换目标列：eggs→chicks） #

• 若前一次0值观测（A日）与首次出现1/2值的日期（目标日）间隙1天：产蛋/孵化日期为中间的B日
• 若间隙2天：产蛋/孵化日期为A日的次日B日
• 若间隙3天：产蛋/孵化日期为中间的C日
• 若间隙≥4天：直接取首次出现1/2值的目标日
• 若该nestyear的首次观测即为蛋数>0或幼雏数>0：对应产蛋/孵化日期设为NA

示例数据 #

library(dplyr)

table <- "nestyear       date adults eggs chicks
1  2017_29 2017-06-01      1    0      0
2  2017_29 2017-06-02      1    0      0
3  2017_29 2017-06-04      1    1      0
4  2017_29 2017-06-05      1    2      0
5  2017_29 2017-06-07      1    1      1
6  2017_29 2017-06-08      2    0      2
7  2017_81 2017-06-01      1    0      0
8  2017_81 2017-06-06      1    1      0
9  2017_81 2017-06-07      1    1      0
10 2017_81 2017-06-08      1    2      0
11 2019_81 2017-06-10      1    1      1
12 2019_20 2019-06-01      1    1      0
13 2019_20 2019-06-02      1    0      1
14 2019_20 2019-06-03      1    0      0
15 2019_20 2019-06-09      1    0      1
16 2019_28 2019-06-01      1    0      0
17 2019_28 2019-06-02      1    0      0
18 2019_28 2019-06-03      1    0      0
19 2019_28 2019-06-05      2    2      0
20 2019_28 2019-06-14      2    0      1"

# 创建DataFrame并转换日期格式
df <- read.table(text=table, header = TRUE)
df$date <- as.Date(df$date)

现有代码（仅实现部分产蛋日期逻辑） #

nests <- unique(df$nestyear)
df$date.lay <- NA # 初始化产蛋日期标记列
df_2 <- df[0 , ] # 创建空DataFrame用于存储结果

for(i in 1:length(nests)){
  target_nest <- subset(df, nestyear == nests[i])
  date_first_lay <- target_nest[!duplicated(paste0(as.Date(target_nest$date), target_nest$eggs)) & target_nest$eggs > 0, ]
  date_first_lay_2 <- rownames(date_first_lay)
  target_nest$date.lay <- "N"
  target_nest$date.lay[rownames(target_nest) %in% date_first_lay_2] <- "Y"
  df_2 <- rbind(df_2, target_nest)
}

datelay <- df_2 %>%
  group_by(nestyear, date.lay) %>%
  filter(date == min(date)) %>%
  filter(date.lay == "Y")

期望输出 #

nestyear   date.lay    date.hatch
2017_29     2017-06-03  2017-06-06
2017_81     2017-06-06  NA
2019_81     NA          NA
2019_20     NA          2019-06-02
2019_28     2019-06-04  2019-06-14

解决方案 #

通过dplyr分组+窗口函数实现通用逻辑，避免重复代码：

library(dplyr)

# 通用函数：计算首次事件（产蛋/孵化）日期
calculate_first_event <- function(data, event_col) {
  data %>%
    group_by(nestyear) %>%
    # 标记首次观测是否为事件（蛋/幼雏>0）
    mutate(first_obs_is_event = first(!!sym(event_col)) > 0) %>%
    # 筛选首次事件发生的行
    filter(!!sym(event_col) > 0) %>%
    slice(1) %>%
    # 关联该事件前最后一次0值观测的日期
    left_join(
      data %>%
        group_by(nestyear) %>%
        filter(!!sym(event_col) == 0, date < first(date[!!sym(event_col) > 0])) %>%
        slice(n()),
      by = "nestyear",
      suffix = c("_event", "_last_zero")
    ) %>%
    # 计算间隙天数并应用规则
    mutate(
      gap_days = as.integer(date_event - date_last_zero),
      event_date = case_when(
        first_obs_is_event ~ NA_Date_,
        gap_days == 1 ~ date_last_zero + 1,
        gap_days == 2 ~ date_last_zero + 1,
        gap_days == 3 ~ date_last_zero + 2,
        gap_days >=4 ~ date_event,
        TRUE ~ NA_Date_
      )
    ) %>%
    select(nestyear, event_date)
}

# 分别计算产蛋、孵化日期
lay_dates <- calculate_first_event(df, "eggs") %>% rename(date.lay = event_date)
hatch_dates <- calculate_first_event(df, "chicks") %>% rename(date.hatch = event_date)

# 合并所有nestyear的结果
final_result <- lay_dates %>%
  full_join(hatch_dates, by = "nestyear") %>%
  right_join(df %>% distinct(nestyear), by = "nestyear") %>%
  arrange(nestyear)

print(final_result)

代码说明 #

1. 通用函数calculate_first_event：复用产蛋/孵化的计算逻辑，仅需传入目标列名
2. 边界处理：自动标记首次观测即为事件的记录，直接设为NA
3. 间隙计算：通过关联事件前最后一次0值观测，精准计算间隙天数并匹配规则
4. 结果合并：确保所有nestyear都被包含，无事件的记录对应日期为NA

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