Быстрый способ группировки переменных на основе прямого и косвенного сходства в нескольких столбцах - PullRequest
Новая
       45

Быстрый способ группировки переменных на основе прямого и косвенного сходства в нескольких столбцах

13 голосов
/ 24 июня 2019

У меня относительно большой набор данных (1 750 000 строк, 5 столбцов), который содержит записи с уникальными значениями идентификаторов (первый столбец), описанные по четырем критериям (4 других столбца).Вот небольшой пример: 

# example
library(data.table)
dt <- data.table(id=c("a1","b3","c7","d5","e3","f4","g2","h1","i9","j6"), 
                 s1=c("a","b","c","l","l","v","v","v",NA,NA), 
                 s2=c("d","d","e","k","k","o","o","o",NA,NA),
                 s3=c("f","g","f","n","n","s","r","u","w","z"),
                 s4=c("h","i","j","m","m","t","t","t",NA,NA))

, который выглядит следующим образом: 

   id   s1   s2 s3   s4
 1: a1    a    d  f    h
 2: b3    b    d  g    i
 3: c7    c    e  f    j
 4: d5    l    k  n    m
 5: e3    l    k  n    m
 6: f4    v    o  s    t
 7: g2    v    o  r    t
 8: h1    v    o  u    t
 9: i9 <NA> <NA>  w <NA>
10: j6 <NA> <NA>  z <NA>

Моя конечная цель - найти все записи с одним и тем же символом в любом описании.столбцы (без учета NA) и сгруппировать их под новым идентификатором, чтобы можно было легко идентифицировать дублированные записи.Эти идентификаторы создаются путем объединения идентификаторов каждой строки.

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

ШАГ 1 - Построение дублированных идентификаторов на основе прямых дубликатов 

# grouping ids with duplicated info in any of the columns
#sorry, I could not find search for duplicates using multiple columns simultaneously...
dt[!is.na(dt$s1),ids1:= paste(id,collapse="|"), by = list(s1)]
dt[!is.na(dt$s1),ids2:= paste(id,collapse="|"), by = list(s2)]
dt[!is.na(dt$s1),ids3:= paste(id,collapse="|"), by = list(s3)]
dt[!is.na(dt$s1),ids4:= paste(id,collapse="|"), by = list(s4)]

# getting a unique duplicated ID for each row
dt$new.id <- apply(dt[,.(ids1,ids2,ids3,ids4)], 1, paste, collapse="|")
dt$new.id <- apply(dt[,"new.id",drop=FALSE], 1, function(x) paste(unique(strsplit(x,"\\|")[[1]]),collapse="|"))

Эта операция приводит к следующему, с определением уникального дублированного идентификатора.as "new.id": 

   id   s1   s2 s3   s4     ids1     ids2  ids3     ids4   new.id
 1: a1    a    d  f    h       a1    a1|b3 a1|c7       a1 a1|b3|c7
 2: b3    b    d  g    i       b3    a1|b3    b3       b3    b3|a1
 3: c7    c    e  f    j       c7       c7 a1|c7       c7    c7|a1
 4: d5    l    k  n    m    d5|e3    d5|e3 d5|e3    d5|e3    d5|e3
 5: e3    l    k  n    m    d5|e3    d5|e3 d5|e3    d5|e3    d5|e3
 6: f4    v    o  s    t f4|g2|h1 f4|g2|h1    f4 f4|g2|h1 f4|g2|h1
 7: g2    v    o  r    t f4|g2|h1 f4|g2|h1    g2 f4|g2|h1 f4|g2|h1
 8: h1    v    o  u    t f4|g2|h1 f4|g2|h1    h1 f4|g2|h1 f4|g2|h1
 9: i9 <NA> <NA>  w <NA>     <NA>     <NA>  <NA>     <NA>       NA
10: j6 <NA> <NA>  z <NA>     <NA>     <NA>  <NA>     <NA>       NA

Обратите внимание, что записи "b3" и "c7" дублируются косвенно через "a1" (все остальные примеры являются прямыми дубликатами, которые должны оставаться такими же).Вот почему нам нужен следующий шаг.

ШАГ 2 - Обновление дублированных идентификаторов на основе косвенных дубликатов 

#filtering the relevant columns for the indirect search
dt = dt[,.(id,new.id)]

#creating the patterns to be used by grepl() for the look-up for each row
dt[,patt:= .(paste(paste("^",id,"\\||",sep=""),paste("\\|",id,"\\||",sep=""),paste("\\|",id,"$",sep=""),collapse = "" ,sep="")), by = list(id)]

#Transforming the ID vector into factor and setting it as a 'key' to the data.table (speed up the processing)
dt$new.id = as.factor(dt$new.id)
setkeyv(dt, c("new.id"))

#Performing the loop using sapply
library(stringr)
for(i in 1:nrow(dt)) {
  pat = dt$patt[i] # retrieving the research pattern
  tmp = dt[new.id %like% pat] # searching the pattern using grepl()
  if(dim(tmp)[1]>1) {
    x = which.max(str_count(tmp$new.id, "\\|"))
    dt$new.id[i] = as.character(tmp$new.id[x])
  }
}

#filtering the final columns 
dt = dt[,.(id,new.id)]

Финальная таблица выглядит следующим образом: 

   id   new.id
 1: a1 a1|b3|c7
 2: b3 a1|b3|c7
 3: c7 a1|b3|c7
 4: d5    d5|e3
 5: e3    d5|e3
 6: f4 f4|g2|h1
 7: g2 f4|g2|h1
 8: h1 f4|g2|h1
 9: i9       NA
10: j6       NA

Обратите внимание, что теперь первые три записи («a1», «b3», «c7») сгруппированы по более широкому дублированному идентификатору, который содержит как прямые, так и косвенные записи.

Все работает нормально, но мойкод ужасно медленныйПотребовалось 2 полных дня, чтобы запустить половину набора данных (~ 800,0000).Я мог бы распараллелить цикл на разные ядра, но все равно это заняло бы часы.И я почти уверен, что мог бы использовать функции data.table лучше, возможно, используя set в цикле.Я потратил часы сегодня, пытаясь реализовать те же самые коды, используя data.table, но я новичок в его синтаксисе, и мне действительно трудно здесь.Любые предложения о том, как я мог бы оптимизировать этот код?

Примечание. Самая медленная часть кода - это цикл, а внутри цикла самый неэффективный шаг - это grepl () шаблонов внутри data.table.Кажется, что установка «ключа» для data.table может ускорить процесс, но я не изменил время, необходимое для выполнения grepl () в моем случае.

Ответы [ 2 ]

12 голосов
/ 24 июня 2019

Вы можете подходить к этому как к проблеме сети.Здесь я использую функции из пакета igraph.Основные шаги:

  1. melt данные в длинном формате.

  2. Используйте graph_from_data_frame для создания графика, где 'id'и столбцы 'value' обрабатываются как крайний список.

  3. Используйте components, чтобы получить связанные компоненты графа, то есть, какие "id" связаны через их критерии, прямо или косвенно.

  4. Выберите элемент membership, чтобы получить «идентификатор кластера, которому принадлежит каждая вершина».

  5. Присоединить членство к исходным данным.

  6. Объединить 'id', сгруппированный по принадлежности к кластеру. 

library(igraph)

# melt data to long format, remove NA values
d <- melt(dt, id.vars = "id", na.rm = TRUE)

# convert to graph
g <- graph_from_data_frame(d[ , .(id, value)])

# get components and their named membership id 
mem <- components(g)$membership

# add membership id to original data
dt[.(names(mem)), on = .(id), mem := mem] 

# for groups of length one, set 'mem' to NA
dt[dt[, .I[.N == 1], by = mem]$V1, mem := NA]

При желании объединить 'id' с помощью 'mem'столбец (для не NA 'mem') (ИМХО это только усложняет дальнейшие манипуляции с данными;)).В любом случае, мы идем: 

dt[!is.na(mem), id2 := paste(id, collapse = "|"), by = mem]

#     id   s1   s2 s3   s4  mem      id2
#  1: a1    a    d  f    h    1 a1|b3|c7
#  2: b3    b    d  g    i    1 a1|b3|c7
#  3: c7    c    e  f    j    1 a1|b3|c7
#  4: d5    l    k  l    m    2    d5|e3
#  5: e3    l    k  l    m    2    d5|e3
#  6: f4    o    o  s    o    3 f4|g2|h1
#  7: g2    o    o  r    o    3 f4|g2|h1
#  8: h1    o    o  u    o    3 f4|g2|h1
#  9: i9 <NA> <NA>  w <NA>   NA     <NA>
# 10: j6 <NA> <NA>  z <NA>   NA     <NA>

Базовый график графика в этом небольшом примере, просто для иллюстрации подключенных компонентов: 

plot(g, edge.arrow.size = 0.5, edge.arrow.width = 0.8, vertex.label.cex = 2, edge.curved = FALSE)

enter image description here

6 голосов
/ 24 июня 2019

Я думаю, что этот рекурсивный подход делает то, что вы хотите.По сути, он выполняет самостоятельное соединение для каждого столбца, по одному за раз, и, если сопоставляется более одной строки (т. Е. Строк, отличных от рассматриваемой строки), он сохраняет все уникальные идентификаторы из совпадения.Он избегает использования строк с NA, используя вторичные индексы .Хитрость в том, что мы делаем рекурсию дважды, один раз с id с, и снова, но с только что созданным new_id с. 

dt[, new_id := .(list(character()))]

get_ids <- function(matched_ids, new_id) {
  if (length(matched_ids) > 1L) {
    list(unique(
      c(new_id[[1L]], unlist(matched_ids))
    ))
  } else {
    new_id
  }
}

find_recursively <- function(dt, cols, pass) {
  if (length(cols) == 0L) return(invisible())

  current <- cols[1L]
  next_cols <- cols[-1L]

  next_dt <- switch(
    pass,

    first = dt[!list(NA_character_),
               new_id := dt[.SD, .(get_ids(x.id, i.new_id)), on = current, by = .EACHI]$V1,
               on = current],

    second = dt[!list(NA_character_),
                new_id := dt[.SD, .(get_ids(x.new_id, i.new_id)), on = current, by = .EACHI]$V1,
                on = current]
  )

  find_recursively(next_dt, next_cols, pass)
}

find_recursively(dt, paste0("s", 1:4), "first")
find_recursively(dt, paste0("s", 1:4), "second")

dt[, new_id := sapply(new_id, function(nid) {
  ids <- unlist(nid)
  if (length(ids) == 0L) {
    NA_character_
  } else {
    paste(ids, collapse = "|")
  }
})]

print(dt)
    id   s1   s2 s3   s4   new_id
 1: a1    a    d  f    h a1|b3|c7
 2: b3    b    d  g    i a1|b3|c7
 3: c7    c    e  f    j a1|c7|b3
 4: d5    l    k  l    m    d5|e3
 5: e3    l    k  l    m    d5|e3
 6: f4    o    o  s    o f4|g2|h1
 7: g2    o    o  r    o f4|g2|h1
 8: h1    o    o  u    o f4|g2|h1
 9: i9 <NA> <NA>  w <NA>     <NA>
10: j6 <NA> <NA>  z <NA>     <NA>

Объединение использует эту идиому .

...