R语言补全数据集：新增未售座位行并按规则填充字段值

问题说明 #

现有一份足球赛事上座率数据集，节选数据构造代码如下：

example <- data.frame(Date <- c("2019-03-21", "2019-03-30", "2019-04-07", 
                                "2019-03-21", "2019-03-30", "2019-04-07",
                                "2019-03-21",  "2019-04-07",
                                "2019-03-21", "2019-03-30", "2019-04-07",
                                "2019-03-21", "2019-03-30", "2019-04-07",
                                "2019-03-21", "2019-03-30", "2019-04-07",
                                "2019-03-21", "2019-03-30", "2019-04-07",
                                "2019-03-21", "2019-03-30", "2019-04-07",
                                "2019-03-21", "2019-03-30",
                                "2019-03-21", "2019-03-30",
                                "2019-03-21", "2019-03-30",
                                "2019-03-21"),
                         Block <- c("43L","43L", "43L", "15B", "15B", "15B", "43L", "43L",
                                    "15B", "15B", "15B",
                                    "15B", "15B", "15B",
                                    "15B", "15B", "15B",
                                    "15B", "15B", "15B",
                                    "15B", "15B", "15B",
                                    "15B", "15B",
                                    "15B", "15B",
                                    "15B", "15B",
                                    "15B"),
                         Preis <- as.numeric(c("24", "35", "30", "35", "45", 
                                    "40", "26", "30",
                                    "35", "45", "40",
                                    "34", "43", "42",
                                    "35", "42", "45",
                                    "36", "45", "43",
                                    "36", "43", "40",
                                    "35", "41",
                                    "32", "42",
                                    "30", "42",
                                    "35")),
                         Max  <- c("3", "3", "3", "10", "10","10","3", "3",
                                   "10", "10","10",
                                   "10", "10","10",
                                   "10", "10","10",
                                   "10", "10","10",
                                   "10", "10","10",
                                   "10", "10",
                                   "10", "10",
                                   "10", "10",
                                   "10"),
                         Actual <- c("2", "1", "2", "10", "9", "6","2", "2",
                                     "10", "9", "6",
                                     "10", "9", "6",
                                     "10", "9", "6",
                                     "10", "9", "6",
                                     "10", "9", "6",
                                     "10", "9",
                                     "10", "9", 
                                     "10", "9",
                                     "10"),
                         Temperatur <- c("15", "20", "18","15", "20", "18", "15",  "18",
                                         "15", "20", "18",
                                         "15", "20", "18",
                                         "15", "20", "18",
                                         "15", "20", "18",
                                         "15", "20", "18",
                                         "15", "20", 
                                         "15", "20", 
                                         "15", "20", 
                                         "15"),
                      Placesold <- c("1", "1", "1", "1", "1","1", "1", "1",
                                     "1", "1", "1",
                                     "1", "1", "1",
                                     "1", "1", "1",
                                     "1", "1", "1",
                                     "1", "1", "1",
                                     "1", "1", 
                                     "1", "1",
                                     "1", "1",
                                     "1") )
colnames(example) <- c("Date", "Block", "Price", "Max", "Actual", "Temprature", "Placesold")

真实场景下数据集覆盖超过100个观赛区块、46个比赛日期。当前数据仅包含已售座位记录，不同区块不同日期的已售记录数统计如下：

table(example$Date, example$Block)
table(example$Placesold)

15B 43L
  2019-03-21  10   2
  2019-03-30   9   1
  2019-04-07    6   2

 1 
30 

补全规则 #

需要为每个区块、每个比赛日补充缺失的未售座位记录，要求：

• 未售记录的Placesold字段值设为0
• 未售记录的Price字段，使用同区块同日期下已售门票（Placesold=1）的平均价格填充，计算均值时不纳入0值
• 其余字段（Max/Actual/Temprature）复用同区块同日期的统一取值

手动构造的预期补全结果统计特征如下：

15B 43L
  2019-03-21  10   3
  2019-03-30  10   3
  2019-04-07   10   3

 0  1 
 9 30 

高效实现方案 #

采用dplyr+tidyr的分组计算逻辑实现，无需手动构造大矩阵，自动适配任意规模的区块、比赛日组合，代码如下：

# 加载依赖包
library(dplyr)
library(tidyr)

# 1. 清洗原始数据，将字符型数值字段转为数值类型
example_clean <- example %>%
  mutate(
    across(c(Price, Max, Actual, Temprature, Placesold), as.numeric)
  )

# 2. 分组计算补全所需指标，生成未售记录并合并
completed_data <- example_clean %>%
  # 按比赛日期+区块分组
  group_by(Date, Block) %>%
  summarise(
    # 同组已售门票均价
    avg_price = mean(Price[Placesold == 1], na.rm = TRUE),
    # 同组总座位数
    total_seat = unique(Max),
    # 同组已有的已售记录数
    sold_num = n(),
    # 提取同组固定属性值
    actual_val = unique(Actual),
    temp_val = unique(Temprature),
    .groups = "drop"
  ) %>%
  # 计算每组需要补充的未售记录数
  mutate(unsold_num = total_seat - sold_num) %>%
  # 按未售记录数生成对应行数
  uncount(unsold_num) %>%
  # 填充未售记录字段
  mutate(
    Price = avg_price,
    Max = total_seat,
    Actual = actual_val,
    Temprature = temp_val,
    Placesold = 0
  ) %>%
  # 对齐原始数据字段顺序
  select(all_of(colnames(example_clean))) %>%
  # 合并原始已售记录和新增未售记录
  bind_rows(example_clean, .) %>%
  # 按需排序（可根据自身需求调整排序规则）
  arrange(Block, Date, desc(Placesold))

结果验证 #

运行以下代码即可验证补全结果是否符合预期：

# 验证各区块各日期总记录数
table(completed_data$Date, completed_data$Block)
# 验证已售/未售记录分布
table(completed_data$Placesold)

输出与手动构造的预期结果完全一致：

15B 43L
 2019-03-21  10   3
 2019-03-30  10   3
 2019-04-07  10   3

 0  1 
 9 30 

该方案全程为向量化计算，即使处理上百区块、数十比赛日的全量数据也可秒级完成，不需要逐行循环遍历。

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