|
|
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(&#34;按员工汇总缺勤扣发金额.xlsx&#34;)<hr/>附录
学习全网最新的 R 语言编程技术，掌握真正的数据编程思维：
你只需要收看这份《R语言编程：基于tidyverse》完整课件！
下载地址：
链接：https://pan.baidu.com/s/1w6FDFndUuHcI8RngIOe49g?pwd=3yee 提取码：3yee
欢迎转发与推广！
本书的 电子网页版 和 纸质版预售 已上线（人邮）异步社区，可在异步社区公众号或官网购买，纸质版预计12月底上市： |
|
发表于 2023-1-14 19:45:25