1 批量将word文档转excel-1

有多个word文档，我们希望可以批量读取word文档，将文档内容按一定名目及顺序整理成excel表格。（如果不在要求名目内，则将相应内容归入备注）

library(readtext)
library(tidyverse)
library(readxl)

1.1 数据清洗

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

data <- read_xlsx("D:/Myblog/datas/kaoqin.xlsx")

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

# A tibble: 560 × 3
   姓名    月份 事项               
   <chr>  <dbl> <chr>              
 1 李胜       3 年休假8天          
 2 李胜       7 年休假3天          
 3 李胜       8 年休假5天          
 4 李胜       9 年休假2天          
 5 孔瑗       9 事假0.5天          
 6 黎娜舒     9 年休假3天          
 7 刘巧生     4 年休假3天          
 8 刘巧生     5 年休假5天          
 9 张宁伊     8 婚假15天、年休假3天
10 张宁伊     9 年休假2天          
# ℹ 550 more rows

事项中记录了很多信息，包括事项、天数，有些还修了多种假期，且分隔符号也不完全相同。我们需要将这一列按照信息类型，分割成多个列。

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

# A tibble: 591 × 3
   姓名    月份 事项     
   <chr>  <dbl> <chr>    
 1 李胜       3 年休假8天
 2 李胜       7 年休假3天
 3 李胜       8 年休假5天
 4 李胜       9 年休假2天
 5 孔瑗       9 事假0.5天
 6 黎娜舒     9 年休假3天
 7 刘巧生     4 年休假3天
 8 刘巧生     5 年休假5天
 9 张宁伊     8 婚假15天 
10 张宁伊     8 年休假3天
# ℹ 581 more rows

下一步就是将事项与天数分成两列。值得注意的是，事项中不仅仅只有天数，还有类似全月病假、全月产假的表述，也有些是不带”假”字的（如居家办公、居家隔离办公等）。在处理这类文字时，要格外注意，使用正则表达式。

我们使用extract()同时提取事项和天数两个信息。

extract()的基本语法是：提供对哪列做提取，提取出来作为哪几列，最主要的是正则表达式设计，位于表达式()中的就是要提取的部分：
- 事项列字符串的规律为：一个或多个非数值即汉字+数字加多个任意字符或者结尾。这里的关键是，有的事项里不带”数字天”，所以必须要有|$ （或者结尾），否则会牵连到整个正则表达式无法正确的匹配。
- 天数列中包含”天”等，修改列解析成数值，解析失败的将变成 NA，正好对应原事项中不包含”数字天”的行，也正好对应”全月…” 。
- 全月，就需要计算该月的天数插补上，为此，先自定义一个小函数，根据年月计算当月天数。

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

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

# A tibble: 591 × 4
   姓名    月份 事项    天数
   <chr>  <dbl> <chr>  <dbl>
 1 李胜       3 年休假   8  
 2 李胜       7 年休假   3  
 3 李胜       8 年休假   5  
 4 李胜       9 年休假   2  
 5 孔瑗       9 事假     0.5
 6 黎娜舒     9 年休假   3  
 7 刘巧生     4 年休假   3  
 8 刘巧生     5 年休假   5  
 9 张宁伊     8 婚假    15  
10 张宁伊     8 年休假   3  
# ℹ 581 more rows

以上，数据清洗基本的步骤完成，但数据中还有些问题：

年假和休假可以归并到一起统一为年假类型。
同一员工的同一事项可以汇总

# 年假和休假可以归并到一起统一为年休假
df <- df %>%
  mutate(
    事项 = case_when(
      str_detect(事项, "年假|年休|休假") ~ "年休假",
      str_detect(事项, "居家") ~ "居家",
      str_detect(事项, "病假") ~ "病假",
      str_detect(事项, "产假") ~ "产假",
      TRUE ~ 事项
    )
  )

# 同一员工的同一事项汇总
df <- df %>%
  group_by(姓名, 事项) %>%
  summarise(天数 = sum(天数), .groups = "drop")
df

# A tibble: 292 × 3
   姓名   事项    天数
   <chr>  <chr>  <dbl>
 1 丁晨蓓 居家     4  
 2 丁晨蓓 年休假  10  
 3 丁晨蓓 陪护假   7  
 4 丁霄明 事假     1.5
 5 丁霄明 年休假   5  
 6 丁霄明 病假     3  
 7 乔飞颖 事假     1.5
 8 乔飞颖 年休假   5  
 9 于信凡 年休假  10  
10 于晨舒 年休假   1  
# ℹ 282 more rows

至此，，后续无论做何种汇总，都已经非常方便了。

1.2 分组汇总

1.2.1 按员工总缺勤描述

对同一员工的所有事项及天数就行描述：先将类型和天数列拼接，再分组汇总

rlt1 <- df %>%
  mutate(info = str_c(事项, 天数, "天")) %>% # 拼接
  group_by(姓名) %>% # 分组汇总
  summarise(考勤 = str_c(info, collapse = "，"))
rlt1

# A tibble: 222 × 2
   姓名   考勤                          
   <chr>  <chr>                         
 1 丁晨蓓 居家4天，年休假10天，陪护假7天
 2 丁霄明 事假1.5天，年休假5天，病假3天 
 3 乔飞颖 事假1.5天，年休假5天          
 4 于信凡 年休假10天                    
 5 于晨舒 年休假1天                     
 6 于莉姬 产假157天，年休假3天          
 7 何璐群 年休假1天                     
 8 何诚   年休假18天，病假15天          
 9 何雅芳 年休假4天                     
10 侯善   年休假14天                    
# ℹ 212 more rows

1.2.2 按员工汇总缺勤扣发奖金数额

假设缺勤到一定天数后才会扣发奖金，按照每超过1天扣发100元奖金为例。

首先需要准备一个查找表，提供每种缺勤，及对应的扣发计算公式（根据天数）；查找表有两列：事项（缺勤）、计算公式（函数）。
建立辅助函数，计算扣发奖金金额。
分组汇总。

# 建立辅助函数
f <- function(x, th) ifelse(x > th, (x - th) * 100, 0)

# 创建查找表，这里fun中的函数必须为R函数，不能是匿名函数
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

# A tibble: 10 × 2
   事项   fun   
   <chr>  <list>
 1 丧假   <fn>  
 2 事假   <fn>  
 3 产假   <fn>  
 4 产检假 <fn>  
 5 出勤   <fn>  
 6 婚假   <fn>  
 7 居家   <fn>  
 8 年休假 <fn>  
 9 病假   <fn>  
10 陪护假 <fn>

# 根据事项类型，连接数据和查找表
rlt2 <- df %>%
  left_join(lookup, by = "事项")
rlt2

# A tibble: 292 × 4
   姓名   事项    天数 fun   
   <chr>  <chr>  <dbl> <list>
 1 丁晨蓓 居家     4   <fn>  
 2 丁晨蓓 年休假  10   <fn>  
 3 丁晨蓓 陪护假   7   <fn>  
 4 丁霄明 事假     1.5 <fn>  
 5 丁霄明 年休假   5   <fn>  
 6 丁霄明 病假     3   <fn>  
 7 乔飞颖 事假     1.5 <fn>  
 8 乔飞颖 年休假   5   <fn>  
 9 于信凡 年休假  10   <fn>  
10 于晨舒 年休假   1   <fn>  
# ℹ 282 more rows

# 将 fun 列的函数，分别应用到天数列，计算出扣发金额。
rlt2 <- rlt2 %>%
  mutate(money = invoke_map_dbl(fun, 天数))
rlt2

# A tibble: 292 × 5
   姓名   事项    天数 fun    money
   <chr>  <chr>  <dbl> <list> <dbl>
 1 丁晨蓓 居家     4   <fn>       0
 2 丁晨蓓 年休假  10   <fn>     300
 3 丁晨蓓 陪护假   7   <fn>       0
 4 丁霄明 事假     1.5 <fn>       0
 5 丁霄明 年休假   5   <fn>       0
 6 丁霄明 病假     3   <fn>       0
 7 乔飞颖 事假     1.5 <fn>       0
 8 乔飞颖 年休假   5   <fn>       0
 9 于信凡 年休假  10   <fn>     300
10 于晨舒 年休假   1   <fn>       0
# ℹ 282 more rows

# 根据员工分组汇总应扣除的奖金
rlt2 <- rlt2 %>%
  group_by(姓名) %>%
  summarise(扣发奖金 = sum(money)) %>%
  arrange(desc(扣发奖金))
rlt2

# A tibble: 222 × 2
   姓名   扣发奖金
   <chr>     <dbl>
 1 谭珍才    32700
 2 贺山进    23250
 3 张瑾      16650
 4 白榕军    16400
 5 于莉姬    15000
 6 刘信会    14600
 7 刘璐晓    14400
 8 张世林    12100
 9 苏光琴    10700
10 邹伦朗     9900
# ℹ 212 more rows

2 批量将word文档转excel-2

2.1 数据清洗

df <- readtext("D:/Myblog/datas/word")
df

readtext object consisting of 2 documents and 0 docvars.
# A data frame: 2 × 2
  doc_id     text                   
  <chr>      <chr>                  
1 文档1.docx "\"00001·一匕金（\"..."
2 文档2.docx "\"00015·一井散\n\"..."

# 按药方切分列
df <- df %>%
  separate_rows(text, sep = "\n(?=\\d{5})") # 切分标志是: \n五位数字序号

此时，药方占据单独的一行。按照分解的思维，我们先解决其中一个药房（一行）的信息提取。

f <- function(x) {
  tibble(
    序号 = str_extract(x, "^\\d{5}"),
    方名 = str_extract(x, "(?<=\\d·).*?(?=\n)"),
    组成 = str_extract(x, "(?<=【组成】).*?(?=\n【用法】|$)"),
    用法 = str_extract(x, "(?<=【用法】).*?(?=\n【主治】|$)"),
    主治 = str_extract(x, "(?<=【主治】).*?(?=\n|$)"),
    备注 = ifelse(str_detect(x, "【"), NA, str_extract(x, "(?<=\n).*$"))
  )
}

说明：都是正则表达式提取，主要用到零宽断言，根据两端标志提取中间想要的内容。为什么看着这么啰嗦呢？是因为数据是有陷阱的：不是每个药方都包含【组成】、【用法】、【主治】，所以右端需要设置为下一项或结尾标志$。

# 测试函数
f(df$text[[1]])

# A tibble: 1 × 6
  序号  方名                       组成                        用法  主治  备注 
  <chr> <chr>                      <chr>                       <chr> <chr> <lgl>
1 00001 一匕金（《活幼心书》卷下） 穿山甲（汤浸透，取甲铿碎，… 上为… 豆疮… NA

2.2 循环迭代，解决问题

rlt <- map_dfr(df$text, f) # dfr,结果按行合并
rlt

# A tibble: 7 × 6
  序号  方名                           组成                    用法  主治  备注 
  <chr> <chr>                          <chr>                   <chr> <chr> <chr>
1 00001 一匕金（《活幼心书》卷下）     穿山甲（汤浸透，取甲铿… 上为… 豆疮… <NA> 
2 00002 一匕金（《痘疹仁端录》卷十三） 郁金一钱半甘草一钱      用水… 痘疮… <NA> 
3 00003 一九丹（《准绳·类方》卷七）    阴丹一分·阳丹九分·硼九… 上为… <NA>  <NA> 
4 00015 一井散                         <NA>                    <NA>  <NA>  《医…
5 00016 一井散                         <NA>                    <NA>  <NA>  《杂…
6 00017 一见消（《惠直堂方》卷四）     川乌三两草乌三两川倍子… 上药… 风气… <NA> 
7 00018 一见消（《惠宜堂方》卷四）     金银花一斤蒲公英四两赤… <NA>  <NA>  <NA>

3 批量读取和合并数据文件

3.1 批量读取多个Excel文件

用数据思维来解决：

先获取所有文件路径，创建为一列的数据框；
提取文件名中的分组变量；
分组嵌套，把分组变量的路径，嵌套在一起；
用批量建模技术在每组上迭代：批量读取该组路径的数据，并合并。

library(tidyverse)
files <- list.files("D:/Myblog/datas/read_datas",
  pattern = "csv",
  full.names = TRUE
)
df <- tibble(files) %>%
  mutate(grp = str_extract(files, ".(?=\\d)")) %>%
  group_nest(grp, .key = "files") %>%
  mutate(data = map(files, ~ map_dfr(.x$files, read_csv, locale(encoding = "GBK"))))
df

# A tibble: 0 × 3
# ℹ 3 variables: grp <chr>, files <list<tibble[,1]>>, data <list>

# 写出到文件
walk2(df$data, str_c("D:/Myblog/datas/read_datas/", df$grp, "年级.csv"), write_csv)

4 批量读取多个多sheet的excel表

library(tidyverse)
library(readxl)

按照分解问题的思维：先解决一个事，然后写函数，再批量做事。

这个问题中，我们先解决读取一个有多sheet的表格，再批量读取多个这样的表。

# 获取文件路径
files <- list.files("d:/Myblog/datas/read_datas",
  pattern = "xlsx", full.names = TRUE, recursive = TRUE
)
files

[1] "d:/Myblog/datas/read_datas/61grades.xlsx"
[2] "d:/Myblog/datas/read_datas/62grades.xlsx"
[3] "d:/Myblog/datas/read_datas/63grades.xlsx"
[4] "d:/Myblog/datas/read_datas/64grades.xlsx"
[5] "d:/Myblog/datas/read_datas/65grades.xlsx"

# 解决一个表格的问题
map_dfr(
  excel_sheets("d:/Myblog/datas/read_datas/61grades.xlsx"),
  ~ read_xlsx("d:/Myblog/datas/read_datas/61grades.xlsx")
)

# A tibble: 4 × 6
  班级  姓名   性别   语文  数学  英语
  <chr> <chr>  <chr> <dbl> <dbl> <dbl>
1 61班  何娜   女       87    92    79
2 61班  黄才菊 女       95    77    75
3 61班  陈芳妹 女       79    87    66
4 61班  陈学勤 男       82    79    66

# 编制函数
readPath <- function(path) {
  map_dfr(
    excel_sheets(path),
    ~ read_xlsx(path, sheet = .x, range = "A1:F5")
  )
}

# 批量应用
df <- map_dfr(files, readPath)
df

# A tibble: 20 × 6
   班级  姓名   性别   语文  数学  英语
   <chr> <chr>  <chr> <dbl> <dbl> <dbl>
 1 61班  何娜   女       87    92    79
 2 61班  黄才菊 女       95    77    75
 3 61班  陈芳妹 女       79    87    66
 4 61班  陈学勤 男       82    79    66
 5 六2班 黄祖娜 女       94    88    75
 6 六2班 徐雅琦 女       92    86    72
 7 六2班 徐达政 男       90    86    72
 8 六2班 陈华健 男       92    84    70
 9 六3班 江佳欣 女       80    69    75
10 六3班 何诗婷 女       76    53    72
11 六3班 林可莉 女       72    52    72
12 六3班 雷帆   男       78    56    66
13 六4班 周婵   女       92    94    77
14 六4班 李小龄 男       90    87    69
15 六4班 陈丽丽 女       87    93    61
16 六4班 杨昌晟 男       84    85    64
17 六5班 符苡榕 女       85    89    76
18 六5班 陆曼   女       88    84    69
19 六5班 容唐   女       83    71    56
20 六5班 蒙丽梅 女       72    72    64