R:使用plyr在两个数据源的匹配子集之间进行模糊字符串匹配

Question

假设我有一个县列表，其中存在不同数量的拼写错误或其他问题，这些问题将它们与 2010 FIPS dataset 区分开来。 (下面用于创建 fips 数据框的代码)，但拼写错误的县所在的州已正确输入。以下是我的完整数据集中 21 个随机观察结果的样本:

tomatch <- structure(list(county = c("Beauregard", "De Soto", "Dekalb", "Webster",
                                     "Saint Joseph", "West Feliciana", "Ketchikan Gateway", "Evangeline", 
                                     "Richmond City", "Saint Mary", "Saint Louis City", "Mclean", 
                                     "Union", "Bienville", "Covington City", "Martinsville City", 
                                     "Claiborne", "King And Queen", "Mclean", "Mcminn", "Prince Georges"
), state = c("LA", "LA", "GA", "LA", "IN", "LA", "AK", "LA", "VA", 
             "LA", "MO", "KY", "LA", "LA", "VA", "VA", "LA", "VA", "ND", "TN", 
             "MD")), .Names = c("county", "state"), class = c("tbl_df", "data.frame"
             ), row.names = c(NA, -21L))

              county state
1         Beauregard    LA
2            De Soto    LA
3             Dekalb    GA
4            Webster    LA
5       Saint Joseph    IN
6     West Feliciana    LA
7  Ketchikan Gateway    AK
8         Evangeline    LA
9      Richmond City    VA
10        Saint Mary    LA
11  Saint Louis City    MO
12            Mclean    KY
13             Union    LA
14         Bienville    LA
15    Covington City    VA
16 Martinsville City    VA
17         Claiborne    LA
18    King And Queen    VA
19            Mclean    ND
20            Mcminn    TN
21    Prince Georges    MD

我使用 adist 创建了一个模糊字符串匹配算法，该算法将大约 80% 的县与 fips 中的县名称相匹配。但是，有时它会匹配两个拼写相似但来自不同州的县(例如，“Webster, LA”匹配“Webster, GA”而不是“Webster Parrish, LA”)。

distance <- adist(tomatch$county, 
                  fips$countyname, 
                  partial = TRUE)


min.name <- apply(distance, 1, min)

matchedcounties <- NULL  

for(i in 1:nrow(distance)) {

  s2.i <- match(min.name[i], distance[i, ])
  s1.i <- i

  matchedcounties <- rbind(data.frame(s2.i = s2.i,
                                      s1.i = s1.i,
                                      s1name = tomatch[s1.i, ]$county, 
                                      s2name = fips[s2.i, ]$countyname, 
                                      adist = min.name[i]),
                           matchedcounties)

}

因此，我想将县的模糊字符串匹配限制为具有匹配州的拼写正确的版本。

我当前的算法创建一个大矩阵，计算两个源之间的标准 Levenshtein 距离，然后选择距离最小的值。

为了解决我的问题，我猜我需要创建一个可以通过 ddply 应用于每个“状态”组的函数，但我很困惑我应该如何做指示 ddply 函数中的组值应与另一个数据帧匹配。 dplyr 解决方案或使用任何其他包的解决方案也将受到赞赏。

创建 FIPS 数据集的代码:

download.file('http://www2.census.gov/geo/docs/reference/codes/files/national_county.txt',
              './nationalfips.txt')

fips <- read.csv('./nationalfips.txt', 
                 stringsAsFactors = FALSE, colClasses = 'character', header = FALSE)
names(fips) <- c('state', 'statefips', 'countyfips', 'countyname', 'classfips')

# remove 'County' from countyname
fips$countyname <- sub('County', '', fips$countyname, fixed = TRUE)
fips$countyname <- stringr::str_trim(fips$countyname)

Answer 1

这是 dplyr 的一种方法。我首先按州加入 tomatch data.frame 与 FIPS 名称(仅允许州内匹配):

require(dplyr)
df <- tomatch %>% 
  left_join(fips, by="state")

接下来，我注意到很多县没有“Saint”，而是“St.”在 FIPS 数据集中。首先清理它应该可以改善获得的结果。

df <- df %>%
    mutate(county_clean = gsub("Saint", "St.", county))

然后，按县对这个 data.frame 进行分组，并使用 adist 计算距离:

df <- df %>%
  group_by(county_clean) %>%                # Calculate the distance per county
  mutate(dist = diag(adist(county_clean, countyname, partial=TRUE))) %>%
  arrange(county, dist) # Used this for visual inspection.

请注意，我从结果矩阵中取出了对角线，因为 adist 返回一个 n x m 矩阵，其中 n 代表 x 向量，m 代表 y 向量(它计算所有组合)。或者，您可以添加 agrep 结果:

df <- df %>%
  rowwise() %>% # 'group_by' a single row. 
  mutate(agrep_result = agrepl(county_clean, countyname, max.distance = 0.3)) %>%
  ungroup()   # Always a good idea to remove 'groups' after you're done.

然后像之前一样进行过滤，取最小距离:

df <- df %>%
  group_by(county_clean) %>%   # Causes it to calculate the 'min' per group
  filter(dist == min(dist)) %>%
  ungroup()

请注意，这可能会导致 tomatch 中的每一输入行返回多行。
或者，一次运行即可完成所有操作(一旦我确信代码正在执行其应该执行的操作，我通常会将其更改为这种格式):

df <- tomatch %>% 
  # Join on all names in the relevant state and clean 'St.'
  left_join(fips, by="state") %>%
  mutate(county_clean = gsub("Saint", "St.", county)) %>% 

  # Calculate the distances, per original county name.
  group_by(county_clean) %>%                
  mutate(dist = diag(adist(county_clean, countyname, partial=TRUE))) %>%

  # Append the agrepl result
  rowwise() %>%
  mutate(string_agrep = agrepl(county_clean, countyname, max.distance = 0.3)) %>%
  ungroup() %>%  

  # Only retain minimum distances
  group_by(county_clean) %>%   
  filter(dist == min(dist))

两种情况的结果:

              county      county_clean state                countyname dist string_agrep
1         Beauregard        Beauregard    LA         Beauregard Parish    0         TRUE
2            De Soto           De Soto    LA            De Soto Parish    0         TRUE
3             Dekalb            Dekalb    GA                    DeKalb    1         TRUE
4            Webster           Webster    LA            Webster Parish    0         TRUE
5       Saint Joseph        St. Joseph    IN                St. Joseph    0         TRUE
6     West Feliciana    West Feliciana    LA     West Feliciana Parish    0         TRUE
7  Ketchikan Gateway Ketchikan Gateway    AK Ketchikan Gateway Borough    0         TRUE
8         Evangeline        Evangeline    LA         Evangeline Parish    0         TRUE
9      Richmond City     Richmond City    VA             Richmond city    1         TRUE
10        Saint Mary          St. Mary    LA           St. Mary Parish    0         TRUE
11  Saint Louis City    St. Louis City    MO            St. Louis city    1         TRUE
12            Mclean            Mclean    KY                    McLean    1         TRUE
13             Union             Union    LA              Union Parish    0         TRUE
14         Bienville         Bienville    LA          Bienville Parish    0         TRUE
15    Covington City    Covington City    VA            Covington city    1         TRUE
16 Martinsville City Martinsville City    VA         Martinsville city    1         TRUE
17         Claiborne         Claiborne    LA          Claiborne Parish    0         TRUE
18    King And Queen    King And Queen    VA            King and Queen    1         TRUE
19            Mclean            Mclean    ND                    McLean    1         TRUE
20            Mcminn            Mcminn    TN                    McMinn    1         TRUE
21    Prince Georges    Prince Georges    MD           Prince George's    1         TRU