从ATF网站多格式PDF提取溯源数据并结构化赋值的方案咨询

一、现有爬取代码优化 #

原爬取代码存在冗余变量、循环内重复绑定数据效率低的问题，优化后代码如下：

library(xml2)
library(tidyverse)
library(rvest)

# 州名转缩写映射表
state_map <- tibble(
  state_full = c('Alabama','Alaska','Arizona','Arkansas','California','Colorado','Connecticut','Delaware','District of Columbia','Florida','Georgia','Guam & Northern Mariana Islands','Hawaii','Idaho','Illinois','Indiana','Iowa','Kansas','Kentucky','Louisiana','Maine','Maryland','Massachusetts','Michigan','Minnesota','Mississippi','Missouri','Montana','Nebraska','Nevada','New Hampshire','New Jersey','New Mexico','New York','North Carolina','North Dakota','Ohio','Oklahoma','Oregon','Pennsylvania','Puerto Rico','Rhode Island','South Carolina','South Dakota','Tennessee','Texas','Utah','Vermont','Virginia','Washington','West Virginia','Wisconsin','Wyoming', "Virgin Islands"),
  state_abbr = c('AL','AK','AZ','AR','CA','CO','CT','DE','DC','FL','GA','GU','HI','ID','IL','IN','IA','KS','KY','LA','ME','MD','MA','MI','MN','MS','MO','MT','NE','NV','NH','NJ','NM','NY','NC','ND','OH','OK','OR','PA','PR','RI','SC','SD','TN','TX','UT','VT','VA','WA','WV','WI','WY', 'VI')
)

URL <- "https://www.atf.gov/resource-center/data-statistics"
# 爬取年份级页面列表
year_pages <- read_html(URL) %>% 
  html_nodes("a") %>% 
  map_dfr(~tibble(
    link = html_attr(.x, "href"),
    year_title = html_text(.x)
  )) %>% 
  filter(str_detect(link, fixed("node"))) %>% 
  mutate(year = str_extract(year_title, "\\d{4}"))

# 批量爬取每个年份下的州级PDF链接
trace_list <- year_pages %>% 
  pmap_dfr(function(link, year_title, year){
    read_html(link) %>% 
      html_nodes("a") %>% 
      map_dfr(~tibble(
        pdf_link = html_attr(.x, "href"),
        state_full = html_text(.x)
      )) %>% 
      filter(str_detect(pdf_link, fixed("download"))) %>% 
      inner_join(state_map, by = "state_full") %>% 
      mutate(year = year)
  })

优化点：

• 删除未使用的正则变量，减少冗余
• 用purrr::map_dfr替代手动循环+逐行绑定，运行效率更高
• 内置州名转缩写映射，直接输出符合要求的state字段
• 自动从标题提取四位年份数值，避免脏数据影响后续处理

二、2017-2019年新版PDF提取优化 #

原提取代码硬编码行号适配性差，优化后基于规则自动定位数据，代码如下：

library(pdftools)
extract_new_pdf <- function(pdf_link, year, state_abbr){
  text <- pdf_text(pdf_link)
  page10 <- text[10] %>% str_split("\n") %>% unlist() %>% trimws()
  
  # 提取城市表格数据
  table_rows <- page10[str_detect(page10, "^[A-Za-z ]+ \\d+$")]
  res <- str_match(table_rows, "^([A-Za-z ]+) (\\d+)$") %>% 
    as_tibble() %>% 
    select(city = V2, count = V3) %>% 
    mutate(count = as.integer(count))
  
  # 提取其他、无法确定城市的数值
  other_row <- page10[str_detect(page10, "^Other ")]
  if(length(other_row) > 0){
    other_count <- str_extract(other_row, "\\d+") %>% as.integer()
    res <- bind_rows(res, tibble(city = "Other", count = other_count))
  }
  unknown_row <- page10[str_detect(page10, "Unknown|No city|cannot be determined")]
  if(length(unknown_row) > 0){
    unknown_count <- str_extract(unknown_row, "\\d+") %>% as.integer()
    res <- bind_rows(res, tibble(city = "None", count = unknown_count))
  }
  
  # 关联年份、州信息
  res %>% mutate(year = year, state = state_abbr) %>% select(year, state, city, count)
}

优化点：

• 自动定位第10页内的城市-数值表格区域，无需硬编码行号
• 新增关键词匹配逻辑，自动提取“其他”“无法确定回收城市”对应数值
• 直接输出结构化字段，无需多次长宽转换

三、2014-2016年旧版PDF提取方案 #

针对无表格结构的饼图环绕数据，采用图像预处理+分区域OCR方案处理，代码如下：

library(pdftools)
library(tesseract)
library(magick)
extract_old_pdf <- function(pdf_link, year, state_abbr){
  # 转换PDF第10页为图像
  img <- pdf_convert(pdf_link, pages = 10, format = "tiff", dpi = 400) %>% 
    image_read()
  
  # 预处理：二值化、去噪，去除饼图画块干扰
  img_processed <- img %>% 
    image_convert(type = "Grayscale") %>% 
    image_threshold("white", "70%") %>% 
    image_median(3)
  
  # 裁剪四个固定文字区域（可根据实际排版调整坐标参数）
  area_top <- image_crop(img_processed, "2000x300+0+200")
  area_left <- image_crop(img_processed, "800x1500+0+500")
  area_right <- image_crop(img_processed, "800x1500+1200+500")
  area_bottom <- image_crop(img_processed, "2000x300+0+2000")
  
  # 限定识别字符范围，提升准确率
  ocr_engine <- tesseract(options = list(tessedit_char_whitelist = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789 "))
  text_all <- map_chr(list(area_top, area_left, area_right, area_bottom), ~ocr(.x, engine = ocr_engine)) %>% 
    paste(collapse = "\n") %>% 
    str_split("\n") %>% unlist() %>% trimws()
  
  # 提取城市-数值对
  table_rows <- text_all[str_detect(text_all, "[A-Za-z ]+ \\d+")]
  res <- str_match(table_rows, "([A-Za-z ]+) (\\d+)") %>% 
    as_tibble() %>% 
    select(city = V2, count = V3) %>% 
    mutate(count = as.integer(count), city = trimws(city)) %>% 
    filter(!is.na(count))
  
  # 关联年份、州信息
  res %>% mutate(year = year, state = state_abbr) %>% select(year, state, city, count)
}

额外校验规则：所有提取到的城市数值加总需等于页面顶部标注的该州总溯源武器数，校验不通过的自动标记待人工复核，大幅降低错误率。

四、最终输出 #

批量处理时可按年份字段判断调用对应提取函数，2017年及以后的文件调用extract_new_pdf，2014-2016年文件调用extract_old_pdf，最终合并所有结果即可得到符合要求的结构化表：

内容的提问来源于stack exchange，提问作者James R.