Если в строках есть похожий элемент, оставьте более короткую строку - PullRequest
Новая
       6

Если в строках есть похожий элемент, оставьте более короткую строку

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

У меня есть датафрейм, как показано ниже.

фрейм данных

Данные для репликации: 

x <- data.frame(cluster=c(1,2,3,4,5),
                groups=c('20000127 20000128',
                         '20000127 20000128 20000134',
                         '20000129 20000130 20000131 20000132',
                         '20000133 20000134 20000135 20000136',
                         '20000128 20000133 20000134 20000135 20000136'),
                chr=c(17,26,35,35,44), stringsAsFactors=FALSE)

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

Например, элемент 20000128 присутствует в строках 1, 2 и 5. Поскольку в строке 1 меньше символов, я хочу удалить строки 2 и 5. Я благодарен за любую помощь !!

В идеале конечный результат должен иметь только кластер 1,3,4. Каждый элемент должен появляться только один раз. (кластеры с наименьшим количеством символов)

Ответы [ 2 ]

1 голос
/ 01 апреля 2020

Исследование этой проблемы было забавным. Я узнал, что это разновидность задачи о сетевом покрытии и NP Complete .

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

Я узнал, что есть реализация R жадного алгоритма в пакете RcppGreedySetCover.

Сначала нам нужно преобразовать форму в два столбца. Мы можем использовать dplyr. 

library(tidyverse)
longx <- x %>% 
    mutate(splitgroups = strsplit(as.character(groups), " ")) %>%
    unnest(splitgroups) %>% select(cluster, splitgroups)

Затем мы можем использовать greedySetCover для аппроксимации наименьшего набора, охватывающего все элементы. 

library(RcppGreedySetCover)
greedySetCover(longx)
#100% covered by 3 sets.
#    cluster splitgroups
# 1:       2    20000127
# 2:       3    20000129
# 3:       3    20000130
# 4:       3    20000131
# 5:       3    20000132
# 6:       5    20000128
# 7:       5    20000133
# 8:       5    20000134
# 9:       5    20000135
#10:       5    20000136

Это предполагает набор из 2,3, а 5 охватывает все. Но это не полностью отвечает на ваш вопрос, потому что, как вы знаете, есть набор кластеров, который короче.

Однако, как мы узнали, минимальный набор составляет 3 кластера. Теперь мы можем протестировать все комбинации из 3 кластеров. 

set.size <- length(unique(greedySetCover(longx)$cluster))
binary.matrix <- table(longx)
combinations <- combn(unique(x$cluster),set.size)

total.lengths <- apply(combinations,2,function(x){
  if(sum(as.logical(colSums(binary.matrix[x,]))) == ncol(binary.matrix))
    {sum(rowSums(binary.matrix[x,]))} 
  else {NA}})

min.length <- min(total.lengths,na.rm = TRUE)
min.set <- combinations[,which(total.lengths == min.length)]
x[min.set,]
#  cluster                              groups chr
#1       1                   20000127 20000128  17
#3       3 20000129 20000130 20000131 20000132  35
#4       4 20000133 20000134 20000135 20000136  35

Данные 

x <- data.frame(cluster=c(1,2,3,4,5),
                groups=c('20000127 20000128',
                         '20000127 20000128 20000134',
                         '20000129 20000130 20000131 20000132',
                         '20000133 20000134 20000135 20000136',
                         '20000128 20000133 20000134 20000135 20000136'),
                chr=c(17,26,35,35,44), stringsAsFactors=FALSE)
1 голос
/ 31 марта 2020

Я должен был использовать while l oop, может быть, есть менее зацикленное решение ... 

foo <- function(x) {
  i <- 1
  while(i < nrow(x)) {
    grps <- strsplit(x$groups, " ")
    keep <- unlist(lapply(grps, function(x) identical(x, grps[[i]]) | !any((length(x) > length(grps[[i]]) & duplicated(c(grps[[i]], x))))))
    x <- x[keep,]
    i <- i+1
  }
  x
}

foo(x)
  cluster                              groups chr
1       1                   20000127 20000128  17
3       3 20000129 20000130 20000131 20000132  35
4       4 20000133 20000134 20000135 20000136  35

Объяснение. 

# I created a function to keep things compact and allow it to be used for other datasets. 
# The `x` is the argument, assumed to be your data frame.
# 1: foo <- function(x) {

# Start the ball rolling with a counter to use in the while loop.
# 2: i <- 1

# This starts the while loop and will continue until "i" reaches the end of the data. 
# But note later that the data may change if there are rows that meet your condition.
# 3: while(i < nrow(x)) {

# Split the groups variable at the " " and store in "grps"
# 4: grps <- strsplit(x$groups, " ")

# This next line does the work. 
# It creates a vector of logical indices which are used to remove rows of "x"
# I split this into many lines to explain better.

# 5: keep <- unlist(lapply(grps, function(x) # apply a function to "grps"
#     identical(x, grps[[i]]) |  # Returns TRUE for each row we are checking
#     !any(  # Negate the next conditions. They will return rows to remove.
#         (length(x) > length(grps[[i]]) & # return TRUE (negated=FALSE) if the length of each x is more than all others
#         duplicated(c(grps[[i]], x))))))  # if duplicated, return TRUE (negated=FALSE)

# Update "x" by keeping only the rows that meet the criteria defined in step 5.
# 6:    x <- x[keep,]

# Increase i
# 7:    i <- i+1
# 8:  } # This ends the while loop
# 9:  x # Return the result
} # End of function
...