基于tidyverse双dataframe匹配统计采样时周边运营农场数量

需求说明 #

我有两个数据表：

• 表1：不同地点的采样时间点列表
• 表2：对应区域的农场列表，包含各农场开业、关停日期以及农场周边的采样区域信息
  需要在采样时间点dataframe中新增一列，返回对应采样地点在采样时正在运营的周边农场总数。目前可手动输入「采样日期」和「采样地点」单独计算单条记录结果，需要自动化批量处理的方案。

现有单条手动计算代码 #

farms %>%
filter(as.Date(Open.Date) < as.Date("Sample.Date")) %>%
filter(as.Date(Closure.Date) > as.Date("Sample.Date")) %>%
filter(grepl("Sample.Location", Nearby.Farm.Locations)) %>%
count()

补充数据示例 #

采样表示例 #

structure(list(Sample.Date = structure(c(2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
1L), .Label = c("29/06/2004", "29/06/2015"), class = "factor"), 
    Location = structure(c(1L, 1L, 1L, 2L, 2L, 2L, 2L, 3L, 3L, 
    3L, 3L, 4L, 4L, 4L, 4L, 5L, 5L, 5L, 5L, 6L, 6L, 6L), .Label = c("Orchard Bay ", 
    "Port Ligar ", "Rams Head ", "Skiddaw ", "Te Puraka Point ", 
    "Waitata Reach "), class = "factor")), class = "data.frame", row.names = c(NA, 
-22L))

农场表示例 #

structure(list(Farm.Number = c(8103L, 8107L, 8108L, 8109L, 8110L, 
8111L, 8112L, 8113L, 8114L, 8115L, 8116L, 8117L, 8118L, 8119L, 
8120L, 8121L, 8122L, 8123L, 8124L, 8125L, 8126L, 8127L, 8128L, 
8129L, 8130L, 8131L, 8132L, 8133L), Start.Date = structure(c(23L, 
16L, 4L, 7L, 25L, 14L, 10L, 20L, 2L, 12L, 3L, 8L, 14L, 11L, 9L, 
1L, 19L, 22L, 5L, 18L, 17L, 13L, 24L, 15L, 26L, 15L, 21L, 6L), .Label = c("1/07/1982", 
"10/06/1994", "11/04/1990", "11/04/1997", "13/05/1982", "13/08/1980", 
"14/05/1996", "14/09/1983", "15/09/1982", "16/03/1981", "17/03/1997", 
"21/01/1986", "23/05/1989", "23/07/2004", "23/12/1982", "25/08/2000", 
"27/06/1983", "27/10/1981", "28/09/1982", "28/10/1983", "29/01/1981", 
"29/01/1982", "29/09/1997", "30/01/2001", "30/06/1982", "4/08/1980"
), class = "factor"), End.Date = structure(c(6L, 8L, 13L, 10L, 
10L, 3L, 10L, 9L, 7L, 10L, 1L, 10L, 4L, 12L, 10L, 10L, 10L, 5L, 
10L, 10L, 10L, 10L, 11L, 2L, 10L, 10L, 10L, 10L), .Label = c("1/02/2039", 
"1/06/2039", "1/06/2041", "1/07/2041", "1/10/2040", "14/09/2007", 
"20/04/2028", "24/08/2020", "30/06/2034", "31/12/2024", "7/03/2039", 
"7/11/2030", "7/11/2031"), class = "factor"), Nearby.Locations = structure(c(6L, 
5L, 5L, 5L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 2L, 4L, 4L, 4L, 4L, 2L, 2L, 2L, 4L, 4L), .Label = c("", "Anakoha Bay", 
"Forsyth Bay; Orchard Bay", "Forsyth Bay; Orchard Bay; Anakoha Bay", 
"Port Ligar; Forsyth Bay; Orchard Bay ", "Waitata Reach "), class = "factor")), class = "data.frame", row.names = c(NA, 
-28L))

期望输出示例 #

structure(list(Sample.Date = structure(c(2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
1L), .Label = c("29/06/2004", "29/06/2015"), class = "factor"), 
    Location = structure(c(1L, 1L, 1L, 2L, 2L, 2L, 2L, 3L, 3L, 
    3L, 3L, 4L, 4L, 4L, 4L, 5L, 5L, 5L, 5L, 6L, 6L, 6L), .Label = c("Orchard Bay ", 
    "Port Ligar ", "Rams Head ", "Skiddaw ", "Te Puraka Point ", 
    "Waitata Reach "), class = "factor"), Nearby.Farms = c(16L, 
    16L, 16L, 3L, 3L, 3L, 3L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
    0L, 0L, 0L, 0L, 0L, 0L, 1L)), class = "data.frame", row.names = c(NA, 
-22L))

实现方案 #

首先预处理两个表的日期列，统一转为Date类型，避免重复转换损耗性能：

library(dplyr)
# 转换农场表日期
farms <- farms %>%
  mutate(
    Start.Date = as.Date(Start.Date, format = "%d/%m/%Y"),
    End.Date = as.Date(End.Date, format = "%d/%m/%Y")
  )
# 转换采样表日期
samples <- samples %>%
  mutate(
    Sample.Date = as.Date(Sample.Date, format = "%d/%m/%Y")
  )

然后使用rowwise()逐行计算每个采样点对应的活跃农场数，直接在mutate中完成批量计算，不需要额外编写遍历函数：

samples_with_farms <- samples %>%
  rowwise() %>%
  mutate(
    Nearby.Farms = sum(
      farms$Start.Date < Sample.Date & 
      farms$End.Date > Sample.Date & 
      grepl(Location, farms$Nearby.Locations)
    )
  ) %>%
  ungroup()

计算逻辑和原有单条计算逻辑完全一致：筛选开业时间早于采样时间、关停时间晚于采样时间、且周边区域包含当前采样点的农场，直接求和得到总数，最终结果和提供的期望输出完全匹配。

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