1 问题描述

问题来自好友 @楚新元 实际的工作场景，稍有改编：

某单位有如下 Excel 格式记录的员工考勤表（姓名是随机编造的），只截取一部分，共有 265 名员工，按 12 个月份记录了缺勤情况：

实际数据往往存在：

• 描述同一件事用词却不同、格式不同
• 记录形式多是文本，其中文字、数值、单位混杂，不能直接用于汇总计算

在数据操作之外，这些都需要做一定的文本处理，而文本处理又几乎肯定用到正则表达式。

本问题想要得到两种汇总结果：

• 每个员工的出勤记录的文字描述汇总（不能直接按行合并，因为需要修正描述不一致）
• 针对不同的缺勤，以及缺勤惩罚方式（扣钱），计算每个员工的扣发金额

下面来逐步解决问题。

先加载包：

library(tidyverse)
library(readxl)
libary(writexl)

2 数据清洗

2.1 数据读取与重塑

显然这是一个不整洁的宽表，先读取数据、做长变宽，同时设置两个额外参数以忽略缺失值、从原列名解析出数值（月份）：

data = read_xlsx("data.xlsx") %>% 
  pivot_longer(-姓名, names_to = "月份", values_to = "事项",
               values_drop_na = TRUE, names_transform = parse_number)
data

可以看到，事项列有的单元格记录了多件事情，其实不止、分割，还有用， ； 分割。需要将这种多条记录，切分成多行的单条记录，用 separate_rows() 即可：

df = data %>% 
  separate_rows(事项, sep = "，|、|；")
df

现在数据表面看起来是整洁数据了。

2.2 文本数据处理

这步需要业务逻辑，发现记录中的不一致问题，具体问题具体分析解决。

首先，事项中包含两个信息：事项、天数，但也有特殊的，比如有 全月病假、全月产假，其后不带“数字天”，注意也不是都带“假”字，有居家办公、居家隔离办公其后带“数字天”。

从貌似没有规律的文本中，发现并表达规律，就需要用到正则表达式。

有两种处理思路，一种是用两次 str_extract() 分别提取两个信息 ；一种是直接用 extract() (类似分组捕获）同时提取两个信息，这里选择后者。

extract()的基本语法是，提供对哪列做提取，提取出来作为哪几列，最主要的是正则表达式设计，用的 ()分组语法，位于其中的是要提取的部分：一个或多个非数值即汉字，数字加多个任意字符或者结尾。 这里的关键是，有的事项里不带“数字天”，所以必须要有 |$ （或者结尾），否则会牵连到整个正则表达式无法正确的匹配。

接着，天数列中包含“天”等，修改列解析成数值，解析失败的将变成 NA，正好对应原事项中不包含“数字天”的，也正好对应“全月...” 。那么全月，就需要计算该月的天数插补上，为此，先自定义一个小函数（来自楚新元，我本来是自己写代码计算，用他这个更简洁）根据年月计算当月天数。

# 自定义函数根据年月计算当月天数
mdays = function(month, year = 2022) {
  x = str_c(year, "-", month, "-01")
  lubridate::days_in_month(x)
} 

df = df %>% 
  extract(事项, into = c("事项", "天数"), regex = "(\\D+)(\\d.*|$)") %>% 
  mutate(天数 = parse_number(天数),
         天数 = ifelse(is.na(天数), mdays(月份), 天数)) 
df

再次，对于 事项 列，有很多同一事项的不同表示，需要做一定的归并：

df %>% count(事项)

比如，年休，休假，都归到年休假。这属于多分支重新编码，借助 case_when() 来实现：

df = df %>% mutate(
  事项 = case_when(str_detect(事项, "年休|休假") ~  "年休假", 
                   str_detect(事项, "居家") ~  "居家",
                   str_detect(事项, "病假") ~  "病假",
                   str_detect(事项, "产假") ~  "产假",
                   TRUE ~ 事项)) 
df

注意到，同一名员工，同一种事项，可能有多次，先加以汇总：

df = df %>%
  group_by(姓名, 事项) %>%
  summarise(天数 = sum(天数), .groups = "drop")

至此，数据清洗完成，后续无论做何种汇总，都已经非常方便。

3 汇总1：按员工汇总缺勤描述

对同一员工的所有事项及天数，先拼接，再分组汇总（拼接）：

rlt1 = df %>%
  mutate(info = str_c(事项, 天数, "天")) %>% 
  group_by(姓名) %>%
  summarise(考勤 = str_c(info, collapse = "，")) 
rlt1

写出到 Excel 文件：

write_xlsx(rlt1, "员工缺勤描述汇总表.xlsx")    # 部分结果截图

4 汇总2：按员工汇总缺勤扣发金额

要计算缺勤扣发金额，首先需要准备一个查找表，提供每种缺勤，及对应的扣发计算公式（根据天数）。

一个计算公式实际上是一个函数，所以查找表有两列：事项（缺勤）、计算公式（函数）

我这里只是演示，是自己编的计算公式，基本格式是某缺勤在一定天数之内不扣钱，超过部分按100元/天。既然有基本格式，就有必要为其写个辅助函数，省的重复写代码。

f = function(x, th) ifelse(x > th, (x - th) * 100, 0)

创建查找表：

lookup = tibble(
  事项 = count(df, 事项)$事项,
  fun = list(\(x) f(x, 14), \(x) f(x, 180), \(x) f(x, 7), \(x) x * 0, \(x) f(x, 14),
             \(x) x * 0, \(x) f(x, 30), \(x) f(x, 7), \(x) f(x, 7), \(x) f(x, 7)))
lookup

注意，函数需要用列表列存放。另外，这里的函数必须得是 R 函数，不能是purrr 公式，因为后续要用于 invoke_map_*() 是不支持的。

接着，从前文清洗好的 df 数据开始，根据事项匹配左连接查找表 lookup：

rlt2 = df %>% 
  left_join(lookup, by = "事项")
rlt2

接下来，就是将 fun 列的函数，分别应用到天数列，计算出扣发金额。这也是我第一次遇到需要使用 invoke_map_*() 的实际场景。

rlt2 = rlt2 %>% 
  mutate(money = invoke_map_dbl(fun, 天数))
rlt2

每人的扣发金额都计算出来了，最后，就是简单的分组汇总了：

rlt2 = rlt2 %>% 
  group_by(姓名) %>% 
  summarise(扣发金额 = sum(money))
rlt2

写出到 Excel 略。

问题圆满解决！

若去掉不必要的中间结果展示，借助管道，加上写出到 Excel，完整代码如下：

library(tidyverse)
library(readxl)
library(writexl)
# 自定义函数根据年月计算当月天数
mdays = function(month, year = 2022) {
  x = str_c(year, "-", month, "-01")
  lubridate::days_in_month(x)
}  
# 数据清洗
df = read_xlsx("data.xlsx") %>% 
  pivot_longer(-姓名, names_to = "月份", values_to = "事项",
               values_drop_na = TRUE, names_transform = parse_number) %>% 
  separate_rows(事项, sep = "，|、|；") %>% 
  extract(事项, into = c("事项", "天数"), regex = "(\\D+)(\\d.*|$)") %>% 
  mutate(天数 = parse_number(天数),
         天数 = ifelse(is.na(天数), mdays(月份), 天数),
         事项 = case_when(
           str_detect(事项, "年休|休假") ~  "年休假", 
           str_detect(事项, "居家") ~  "居家",
           str_detect(事项, "病假") ~  "病假",
           str_detect(事项, "产假") ~  "产假",
           TRUE ~ 事项)) %>%
  group_by(姓名, 事项) %>%
  summarise(天数 = sum(天数), .groups = "drop")

# 汇总1: 按员工汇总缺勤描述
df %>%
  mutate(info = str_c(事项, 天数, "天")) %>% 
  group_by(姓名) %>%
  summarise(考勤 = str_c(info, collapse = "，")) %>%
  write_xlsx(rlt1, "员工缺勤描述汇总表.xlsx")

# 汇总2: 按员工汇总缺勤扣发金额
f = function(x, th) ifelse(x > th, (x - th) * 100, 0)
lookup = tibble(
  事项 = count(df, 事项)$事项,
  fun = list(\(x) f(x, 14), \(x) f(x, 180), \(x) f(x, 7), \(x) x * 0, \(x) f(x, 14),
             \(x) x * 0, \(x) f(x, 30), \(x) f(x, 7), \(x) f(x, 7), \(x) f(x, 7)))
df %>% 
  left_join(lookup, by = "事项") %>% 
  mutate(money = invoke_map_dbl(fun, 天数)) %>% 
  group_by(姓名) %>% 
  summarise(扣发金额 = sum(money)) %>%
  write_xlsx("按员工汇总缺勤扣发金额.xlsx")