Ускорение цикла расчета расстояния Яро-Винклера в R

Question

Я новичок здесь в нескольких смыслах. Первый пост о моем первом скрипте в моей первой попытке освоить любой язык программирования. В свете этого вы могли бы посчитать этот проект слишком амбициозным, но эй, обучение на практике всегда было подходящим способом. Я делаю все возможное, чтобы встретить здесь этикет-стекопоток, но дайте мне знать, если я что-то нарушаю.

Я хотел написать фрагмент кода, который может применять нечеткую логику при сопоставлении таблицы неструктурированных названий компаний (например, Google) с таблицей структурированных названий компаний (например, Google Inc.) и датскими идентификаторами компаний (CVR).

Я смог найти некоторые фрагменты кода, поиграв в поисках, и мне удалось манипулировать ими для работы с моим проектом. Я обнаружил, что алгоритм Яро-Винклера, который содержится в stringdist Пакет особенно хорошо работает с названиями компаний. Сценарий прекрасно работает при попытке сравнить и сопоставить 40 неструктурированных названий компаний с несколькими сотнями структурированных имен, но мне нужно сравнить и сопоставить около 4000 неструктурированных имен с таблицей, содержащей 700 тыс. Структурированных имен. Как вы уже догадались, это займет вечность. Чтобы дать вам представление, я попытался сопоставить 6 неструктурированных имен с 700k, что заняло три часа. Быстрый подсчет говорит мне, что если это средняя скорость работы скрипта, мне потребуется почти 3 месяца для обработки 4000 компаний, что немного ошеломляет. Я понимаю, что это должно сделать несколько миллиардов вычислений и что это не может быть сделано за несколько минут. Однако, если бы я мог минимизировать это до нескольких дней, я был бы более чем счастлив, и я чувствую, что это должно быть возможно.

Итак, я ищу методы, чтобы ускорить этот кусок кода. Я уже успел улучшить его, предварительно сопоставив точные совпадения с match() функция, которая оставляет около 500 компаний для дальнейшей обработки с помощью алгоритма нечеткого соответствия. Тем не менее, это занимает много времени, если не сказать больше.

Я надеюсь, что мне удалось объяснить себя ясно! Любые предложения будут высоко оценены.

library(stringdist)

#Reading the two files to be compared and making sure that I'm dealing with characters
companies.unstructured <- read.csv(
  "https://www.dropbox.com/s/opbk0s2q14l5c71/unstructured_companies.csv?dl=0", 
  sep = ";", 
  stringsAsFactors = FALSE
)
companies.structured <- read.csv(
  "https://www.dropbox.com/s/kyi0rvz77frr7sd/structured_companies_w_CVR.csv?dl=0", 
  sep=";", 
  stringsAsFactors = FALSE
)

#Using the match function to match up all 100% identical companies to avoid unnecessary workload for the Jaro-Winkler loop
companies.unstructured$CVR = companies.structured$CVR[match(companies.unstructured$Company, 
                                                            companies.structured$Company)]
companies.exact.match <- companies.unstructured[!is.na(companies.unstructured$CVR), ]

#Creating a subset to work on with the Jaro-Winkler loop.
companies.unstructured.na <- subset(companies.unstructured, is.na(CVR))

#And here's the loop measuring the distance between the company names using the Jaro-Winkler algorithm.
distance.methods<- c('jw')
dist.methods<-list()
for(m in 1:length(distance.methods))
{
  dist.name.enh<-matrix(NA, ncol = length(companies.structured$Company),
                        nrow = length(companies.unstructured.na$Company))
  for(i in 1:length(companies.structured$Company)) {
    for(j in 1:length(companies.unstructured.na$Company)) { 
      dist.name.enh[j,i]<-stringdist(tolower(companies.structured[i,]$Company),
                                     tolower(companies.unstructured.na[j,]$Company),
                                     method = distance.methods[m])      
    }  
  }
  dist.methods[[distance.methods[m]]]<-dist.name.enh
}

#matching up pairs of minimum distance
match.s1.s2.enh<-NULL
for(m in 1:length(dist.methods))
{

  dist.matrix<-as.matrix(dist.methods[[distance.methods[m]]])
  min.name.enh<-apply(dist.matrix, 1, base::min)
  for(i in 1:nrow(dist.matrix))
  {
    s2.i<-match(min.name.enh[i],dist.matrix[i,])
    s1.i<-i
    match.s1.s2.enh<-rbind(data.frame(s2.i=s2.i,
                                      s1.i=s1.i,
                                      s1Company=companies.unstructured.na[s1.i,]$Company,
                                      s2Company=companies.structured[s2.i,]$Company,
                                      CVR=companies.structured[s2.i,]$CVR,
                                      adist=min.name.enh[i],
                                      method=distance.methods[m]),
                           match.s1.s2.enh)
  }
}

РЕДАКТИРОВАТЬ: Вот несколько примеров данных для работы: structd_companies_w_CVR и unstructured_companies

Answer 1

Я профилировал ваш код и нашел несколько ускорений. Я сохранил как можно больше ваших соглашений об именах, чтобы вы могли сопоставить различия. Я сохранил файлы в моем рабочем каталоге для тестирования.

1. Создан пустой фрейм данных на основе нужных вам столбцов и нужных записей. В цикле вы обновляете запись вместо использования cbind. Это немного ускоряет код. Я продолжал получать system.time = 0. Поскольку R не знает размер фрейма данных, он делает постоянные копии с rbind и имеет тенденцию замедлять процесс, если у вас много строк. Смотрите также этот пост. Обновление записей происходит намного быстрее, даже если размер данных больше необходимого.

   редактировать: мне удалось удалить все, кроме функции соответствия, из цикла, а остальное для информационного кадра можно сделать с помощью векторов / входных данных из других частей данных, уже доступных.

2. Я добавил параллельную опцию в коде и использовал stringdistmatrix. Эта функция работает параллельно, если она доступна, но вам также не нужен цикл для расчета расстояния.

раздел кода:

library(stringdist)
library(parallel)


#Reading the two files to be compared and making sure that I'm dealing with characters
companies.unstructured <- read.csv("unstructured_companies.csv", 
                                   sep = ";", 
                                   stringsAsFactors = FALSE)
companies.structured <- read.csv("structured_companies_w_CVR.csv", 
                                 sep=";",
                                 stringsAsFactors = FALSE)

#Using the match function to match up all 100% identical companies to avoid unnecessary workload for the Jaro-Winkler loop
companies.unstructured$CVR <- companies.structured$CVR[match(companies.unstructured$Company, 
                                                             companies.structured$Company)]
companies.exact.match <- companies.unstructured[!is.na(companies.unstructured$CVR), ]

#Creating a subset to work on with the Jaro-Winkler loop.
companies.unstructured.na <- subset(companies.unstructured, is.na(CVR))

distance.method <- "jw"

# Parallel section starts here
# set number of cores to use. 
cores = 3
# initialize cluster
cl = makeCluster(cores, type = "SOCK")


# create distance matrix, shortest column will be recycled. 
# See stringdistmatrix documentation
dist.name.enh <- stringdistmatrix(tolower(companies.structured$Company),
                                  tolower(companies.unstructured.na$Company),
                                  method = distance.method,
                                  nthread = getOption("sd_num_thread"))

# get the minimun jaro distances from the matrix
min.name.enh <- parApply(cl, dist.name.enh, 2, base::min)

# stop the cluster
stopCluster(cl)
# Parallel section ends here

# create dataframe prefilled with empty values.
match.s1.s2.enh2 <- data.frame(s2.i = rep(NA, nrow(companies.unstructured.na)),
                               s1.i = rep(NA, nrow(companies.unstructured.na)),
                               s1Company = rep(NA, nrow(companies.unstructured.na)),
                               s2Company = rep(NA, nrow(companies.unstructured.na)),
                               CVR = rep(NA, nrow(companies.unstructured.na)),
                               adist = rep(NA, nrow(companies.unstructured.na)),
                               method = rep(NA, nrow(companies.unstructured.na)))

# fill s2.i with NA values for the length needed in the for loop
s2.i <- rep(NA, ncol(dist.name.enh))

# matching up pairs of minimum distance.
for(i in 1:ncol(dist.name.enh)) {
  s2.i[i]<-match(min.name.enh[i],dist.name.enh[,i])
}

match.s1.s2.enh2$s2.i <- s2.i
match.s1.s2.enh2$s1.i <- 1:ncol(dist.name.enh)
match.s1.s2.enh2$s1Company <- companies.unstructured.na$Company
match.s1.s2.enh2$adist <- min.name.enh
match.s1.s2.enh2$method <- distance.method
match.s1.s2.enh2$s2Company <- companies.structured$Company[s2.i] 
match.s1.s2.enh2$CVR <- companies.structured$CVR[s2.i]