寻找R中数对之间的层次关系

uklbhaso 于 5个月前发布在其他

关注(0)|答案(5)|浏览(41)

我想找到一种有效的方法来确定一个数字对表的整个层次类型关系，然后用向量或字符串表示这种关系，这样我就可以确定关于每个数字对的层次结构的其他有用信息，例如最高相关整数，最低相关整数和相关整数的总数。
例如，我有一个整数对表：

字符串
如果一个记录对中的任何一个值被另一个记录对中的任何其他值共享，则该记录与另一个记录相关。最终的表看起来像这样：

X    Y    Related ID's
  ---  ---  ---------------   
  5    10    3,5,10,11,12,13 
  5    11    3,5,10,11,12,13 
  11   12    3,5,10,11,12,13 
  11   13    3,5,10,11,12,13 
  13   3     3,5,10,11,12,13 
  20   18    17,18,20,21,50
  17   18    17,18,20,21,50
  50   18    17,18,20,21,50
  20   21    17,18,20,21,50

型
我现在所做的是无可否认的混乱。它使用一个带有匹配函数的fuzzy_join，该函数将x，y作为向量并在它们之间进行匹配。该匹配然后创建一个包含所有四个匹配数字的更大向量，该向量返回fuzzy_join再次进行匹配。这会循环，直到没有更多的匹配。它很快变得很糟糕，在大约4k记录时，它不再响应。整个初始对表将保持< 100k记录

来源：https://stackoverflow.com/questions/63305399/finding-the-hierarchy-relationships-between-number-pairs-in-r

5条答案

按热度按时间

sulc1iza1#

在R中，你可以这样做：

relation <- function(dat){
  .relation <- function(x){
    k = unique(sort(c(dat[dat[, 1] %in% x, 2], x, dat[dat[, 2] %in% x, 1])))
    if(setequal(x,k)) toString(k) else .relation(k)}
  sapply(dat[,1],.relation)
}

df$related <- relation(df)

df
   X  Y              related
1  5 10 3, 5, 10, 11, 12, 13
2  5 11 3, 5, 10, 11, 12, 13
3 11 12 3, 5, 10, 11, 12, 13
4 11 13 3, 5, 10, 11, 12, 13
5 13  3 3, 5, 10, 11, 12, 13
6 20 18   17, 18, 20, 21, 50
7 17 18   17, 18, 20, 21, 50
8 50 18   17, 18, 20, 21, 50
9 20 21   17, 18, 20, 21, 50

字符串
如果你安装了igraph，你可以：

library(igraph)
a <- components(graph_from_data_frame(df, FALSE))$membership
b <- tapply(names(a),a,toString)
df$related <- b[a[as.character(df$X)]]

型
编辑：
如果我们比较函数的速度，请注意，在我上面的函数中，最后一个语句ie sapply(dat[,1], ...)即使在计算之前也会计算每个元素的值。例如sapply(c(5,5,5,5)...)将计算组4次而不是一次。现在用途：

relation <- function(dat){
  .relation <- function(x){
    k <- unique(c(dat[dat[, 1] %in% x, 2], x, dat[dat[, 2] %in% x, 1]))
    if(setequal(x,k)) sort(k) else .relation(k)}
  d <- unique(dat[,1])
  m <- setNames(character(length(d)),d)
  while(length(d) > 0){
    s <- .relation(d[1])
    m[as.character(s)] <- toString(s)
    d <- d[!d%in%s]
  }
  dat$groups <- m[as.character(dat[,1])]
  dat
}

型
现在执行基准测试：

df1 <- do.call(rbind,rep(list(df),100))
 microbenchmark::microbenchmark(relation(df1), group_pairs(df1),unit = "relative")

 microbenchmark::microbenchmark(relation(df1), group_pairs(df1))
Unit: milliseconds
             expr      min        lq       mean    median       uq      max neval
    relation(df1)   1.0909   1.17175   1.499096   1.27145   1.6580   3.2062   100
 group_pairs(df1) 153.3965 173.54265 199.559206 190.62030 213.7964 424.8309   100

型

赞(0）回复(0）举报 5个月前

pod7payv2#

igraph的另一种选择

library(igraph)
clt <- clusters(graph_from_data_frame(df,directed = FALSE))$membership
within(df, ID <- ave(names(clt),clt,FUN = toString)[match(as.character(X),names(clt))])

字符串
使得

X  Y                   ID
1  5 10 5, 11, 13, 10, 12, 3
2  5 11 5, 11, 13, 10, 12, 3
3 11 12 5, 11, 13, 10, 12, 3
4 11 13 5, 11, 13, 10, 12, 3
5 13  3 5, 11, 13, 10, 12, 3
6 20 18   20, 17, 50, 18, 21
7 17 18   20, 17, 50, 18, 21
8 50 18   20, 17, 50, 18, 21
9 20 21   20, 17, 50, 18, 21

型

赞(0）回复(0）举报 5个月前

7y4bm7vi3#

我想你也可以在tidyverse中做类似的事情（我使用了一个精心设计的框架，增加了一些行）。这个策略将保持accumulate（累积）related_ids。这里id只是一个rowid，没有任何特殊用途。你也可以放弃这一步。

df <- data.frame(X = c(5,5,11,11,13,20, 17,50, 20, 5, 1, 17),
                 Y = c(10, 11, 12, 13, 3, 18, 18, 18, 21, 13, 2, 50))

library(tidyverse)

df %>% arrange(pmax(X, Y)) %>% 
  mutate(id = row_number()) %>% rowwise() %>%
  mutate(related_ids = list(c(X, Y))) %>% ungroup() %>%
  mutate(related_ids = accumulate(related_ids, ~if(any(.y %in% .x)){union(.x, .y)} else {.y})) %>%
  as.data.frame()
#>     X  Y id          related_ids
#> 1   1  2  1                 1, 2
#> 2   5 10  2                5, 10
#> 3   5 11  3            5, 10, 11
#> 4  11 12  4        5, 10, 11, 12
#> 5  11 13  5    5, 10, 11, 12, 13
#> 6  13  3  6 5, 10, 11, 12, 13, 3
#> 7   5 13  7 5, 10, 11, 12, 13, 3
#> 8  17 18  8               17, 18
#> 9  20 18  9           17, 18, 20
#> 10 20 21 10       17, 18, 20, 21
#> 11 50 18 11   17, 18, 20, 21, 50
#> 12 17 50 12   17, 18, 20, 21, 50

字符串
创建于2021-06-01由reprex package（v2.0.0）

赞(0）回复(0）举报 5个月前

rryofs0p4#

这远不如Onyambu的基本R答案那么优雅，但我的基准测试速度快了4到5倍。它的工作原理是将每行分配给一个组，将其内容添加到该组中所有数字的集合中，然后找到下一个未分配的行，该行至少有一个成员在集合中。一旦没有更多的匹配行，它就会跳转到下一个未分配的行。

group_pairs <- function(df)
{
  df$ID <- numeric(nrow(df))
  ID <- 1
  row <- 1
  current_set <- numeric()
  
  while(any(df$ID == 0))
  {
    
    df$ID[row]  <- ID
    current_set <- unique(c(current_set, df$x[row], df$y[row]))
    nextrows    <- c(which(df$x %in% current_set & df$ID == 0), 
                     which(df$y %in% current_set & df$ID == 0))
    if (length(nextrows) > 0)
    {
      row <- unique(nextrows)[1]
    }
    else
    {
      ID <- ID + 1
      row <- which(df$ID == 0)[1]
      current_set <- numeric()
    }
  }
  
  df$ID <- sapply(split(df[-3], df$ID), 
                  function(i) paste(sort(unique(unlist(i))), collapse = ", "))[df$ID]
  df
}

字符串
因此，您可以：

group_pairs(df)
#>    x  y                   ID
#> 1  5 10 3, 5, 10, 11, 12, 13
#> 2  5 11 3, 5, 10, 11, 12, 13
#> 3 11 12 3, 5, 10, 11, 12, 13
#> 4 11 13 3, 5, 10, 11, 12, 13
#> 5 13  3 3, 5, 10, 11, 12, 13
#> 6 20 18   17, 18, 20, 21, 50
#> 7 17 18   17, 18, 20, 21, 50
#> 8 50 18   17, 18, 20, 21, 50
#> 9 20 21   17, 18, 20, 21, 50

型
和

microbenchmark::microbenchmark(relation(df), group_pairs(df))
#> Unit: milliseconds
#>             expr      min       lq     mean   median       uq      max neval cld
#>     relation(df) 4.535100 5.027551 5.737164 5.829652 6.256301 7.669001   100   b
#>  group_pairs(df) 1.022502 1.159601 1.398604 1.338501 1.458950 8.903800   100  a

型

赞(0）回复(0）举报 5个月前

fzsnzjdm5#

已更新我觉得你也可以使用下面的解决方案，虽然比较繁琐，但我觉得还是很有效的：

library(dplyr)

# First I created an id column to be able to group the observations with any duplicated 
# values
df %>%
  arrange(X, Y) %>%
  mutate(dup = ifelse((X == lag(X, default = 0) | X == lag(Y, default = 0)) |
                        (Y == lag(X, default = 0) | Y == lag(Y, default = 0)) |
                        (X == lag(X, n = 2L, default = 0) | Y == lag(Y, n = 2L, default = 0)) |
                        (X == lag(Y, n = 2L, default = 0) | Y == lag(X, n = 2L, default = 0)) |
                        (X == lag(Y, n = 3L, default = 0) | Y == lag(X, n = 3L, default = 0)) |
                        (X == lag(X, n = 3L, default = 0) | Y == lag(Y, n = 3L, default = 0)), 1, 0)) %>%
  mutate(id = cumsum(dup == 0)) %>%
  select(-dup) -> df1

df1 %>%
  group_by(id) %>%
  pivot_longer(c(X, Y), names_to = "Name", values_to = "Val") %>%
  arrange(Val) %>%
  mutate(dup = Val == lag(Val, default = 10000)) %>%
  filter(!dup) %>%
  mutate(across(Val, ~ paste(.x, collapse = "-"))) %>%
  select(-dup) %>%
  slice(2:n()) %>%
  select(-Name) %>%
  right_join(df1, by = "id") %>%
  group_by(Val, X, Y) %>%
  distinct() %>%
  select(-id) %>%
  relocate(X, Y)

# A tibble: 9 x 3
# Groups:   Val, X, Y [9]
      X     Y Val            
  <int> <int> <chr>          
1     5    10 3-5-10-11-12-13
2     5    11 3-5-10-11-12-13
3    11    12 3-5-10-11-12-13
4    11    13 3-5-10-11-12-13
5    13     3 3-5-10-11-12-13
6    17    18 17-18-20-21-50 
7    20    18 17-18-20-21-50 
8    20    21 17-18-20-21-50 
9    50    18 17-18-20-21-50

字符串
我还尝试了@AnilGoyal精心制作的数据框架：

# A tibble: 12 x 3
# Groups:   Val, X, Y [12]
       X     Y Val            
   <dbl> <dbl> <chr>          
 1     1     2 1-2            
 2     5    10 3-5-10-11-12-13
 3     5    11 3-5-10-11-12-13
 4     5    13 3-5-10-11-12-13
 5    11    12 3-5-10-11-12-13
 6    11    13 3-5-10-11-12-13
 7    13     3 3-5-10-11-12-13
 8    17    18 17-18-20-21-50 
 9    17    50 17-18-20-21-50 
10    20    18 17-18-20-21-50 
11    20    21 17-18-20-21-50 
12    50    18 17-18-20-21-50

型

赞(0）回复(0）举报 5个月前

我来回答

寻找R中数对之间的层次关系

5条答案

相关问题

热门标签

最新问答