R: Создание самой длинной цепочки имен в кадре данных - PullRequest
Новая
       32

R: Создание самой длинной цепочки имен в кадре данных

1 голос
/ 24 марта 2020

У меня есть датафрейм из более чем 5000 имен и фамилий. Вот первые 20 строк. 

df <- data.frame(
        First.Name = c("Larry","Darren","Howard",
                       "Antonio","John","Alex","Tom","Jose","Robert","Michael",
                       "Will","Kareem","Jack","Howard","Sam","David",
                       "Carlo","Johnson","Andy","Rodger"),
         Last.Name = c("James","King","Singer",
                       "Howard","Michael","Peters","John","Reyes",
                       "Blake","Samuel","Woods","Patrick","Shun",
                       "Dieter","Johnson","Fant","Patrick","James",
                       "Berry","Black")
)

Я пытаюсь создать цепочки имен и найти самую длинную цепочку имен. Например, Антонио Ховард и Говард Сингер объединяются, создавая цепочку «Антонио Ховард Сингер». Каждое имя может быть использовано один раз. Я думаю, что много задумался, но я придумал код, который работает частично. Это позволяет мне найти количество имен в самой длинной цепочке для каждого имени и показывает мне индексы строк, которые соответствуют имени с фамилией данной строки. Вот код, чтобы вы могли лучше понять: 

#Store the indices of each person's name match in a list
matches <- list()

for (i in 1:nrow(df)) {
  x <- c()
  for (j in 1:nrow(df)) {
    if (df$Last.Name[i] == df$First.Name[j]) {
      x <- c(x,j)
    } 
  }
  print(i)
  matches[[i]] <- x
}



#Function to get the indices of each person's matches


getmatches <- function(x){
  a <- c()
  if (length(x) < 1){
    break()
  } else{
    for(i in 1:length(x)){
      a <- c(a, matches[[x[i]]])
    }
  }
  if(length(a) >= 1){
    for (j in 1:length(a)){
      #Remove if a last name is the same as the person's own first name
      if (a[j] == x){
        a <- a[-j]
      } else {
        next()
      }
    }
  }  
  return(a)
}


#Get the length of longest name chain starting with each 
#person's name

df$longestchain <- 0

for (i in 1:nrow(df)){
  y <- getmatches(df[i])
  x <- 1
  while(length(y) > 0){
    x <- x + 1
    y <- getmatches(y)
  }
  df$longestchain[i] <- x
}

Это дает мне имя, которое запускает самую длинную цепочку имен, и я могу посмотреть на совпадения из списка совпадений и найти самую длинную цепочку имен. Тем не менее, это не самый эффективный способ ведения дел и не работает для более сложных задач. Например: если каждая комбинация имени / фамилии также считается противоположной (Ларри Джеймс также может быть Джеймсом Ларри). Как я могу изменить это или полностью воссоздать, чтобы алгоритм просто дал мне самую длинную цепочку имен, используя каждое имя один раз?

Ответы [ 2 ]

2 голосов
/ 24 марта 2020

Преобразование в график и поднабор путей, расстояние которых равно диаметру графика. 

library(igraph)

g = graph.data.frame(df, directed = FALSE)
#plot(g)

d = diameter(g)

sp = shortest.paths(g)

# From https://stackoverflow.com/a/28054408/7128934
get_paths_by_length <- function(g, len) {
    sp <- shortest.paths(g)
    sp[lower.tri(sp,TRUE)] <- NA
    wp <- which(sp==len, arr.ind=TRUE)
    mapply(function(a,b) get.shortest.paths(g, a, b)$vpath, wp[,1], wp[,2])
}

get_paths_by_length(g, d)

#$Larry
#+ 4/33 vertices, named, from e20fe05:
#[1] Larry   James   Johnson Sam    

#$Tom
#+ 4/33 vertices, named, from e20fe05:
#[1] Tom     John    Michael Samuel
0 голосов
/ 24 марта 2020

Я думаю, это может быть просто merge (или объединение): 

out <- merge(df, df, by.x = "Last.Name", by.y = "First.Name", all = TRUE)
out <- out[ complete.cases(out), ]
out[,c(2, 1, 3)]
#    First.Name Last.Name Last.Name.y
# 12    Antonio    Howard      Dieter
# 13    Antonio    Howard      Singer
# 17        Tom      John     Michael
# 18        Sam   Johnson       James
# 23       John   Michael      Samuel

Хорошо, теперь давайте автоматизируем это, чтобы найти более длинные цепочки. 

outs <- list(df)
iter <- 50
while (iter > 0 && NROW(last <- tail(outs, 1)[[1]]) > 0) {
  this <- merge(last, df, by.x = tail(names(last),1), by.y = "First.Name")
  outs <- c(outs, list(this[, c(intersect(names(last), names(this)), setdiff(names(this), names(last)))]))
}

outs
# [[1]]
#    First.Name Last.Name
# 1       Larry     James
# 2      Darren      King
# 3      Howard    Singer
# 4     Antonio    Howard
# 5        John   Michael
# 6        Alex    Peters
# 7         Tom      John
# 8        Jose     Reyes
# 9      Robert     Blake
# 10    Michael    Samuel
# 11       Will     Woods
# 12     Kareem   Patrick
# 13       Jack      Shun
# 14     Howard    Dieter
# 15        Sam   Johnson
# 16      David      Fant
# 17      Carlo   Patrick
# 18    Johnson     James
# 19       Andy     Berry
# 20     Rodger     Black
# [[2]]
#   First.Name Last.Name Last.Name.y
# 1    Antonio    Howard      Dieter
# 2    Antonio    Howard      Singer
# 3        Tom      John     Michael
# 4        Sam   Johnson       James
# 5       John   Michael      Samuel
# [[3]]
#   First.Name Last.Name.y Last.Name.x Last.Name.y.y
# 1        Tom     Michael        John        Samuel
# [[4]]
# [1] First.Name    Last.Name.y   Last.Name.x   Last.Name.y.y Last.Name    
# <0 rows> (or 0-length row.names)

Имена будут по-прежнему неясен здесь, но (1) while l oop принимает имена как есть, (2) имена не будут конфликтовать (по логикам merge * c) и (3) мы всегда можем разобраться с ними позже.

Я добавил счетчик / ограничитель iter в том случае, если существует достаточно общности, чтобы имя могло само слиться в al oop. Я не знаю, что это может произойти, но так как я не доказал, что это не может произойти, я защищаюсь от бесконечного l oop.

...