【问题标题】：Sum named vector values where the names are reversed in R求和命名向量值，其中名称在 R 中颠倒
【发布时间】：2022-04-06 06:07:13
【问题描述】：

我有一个命名向量列表。我试图总结他们的价值观。但是向量中的一些名称具有相反的等价物。例如，如果我有一些看起来像这样的数据：

myList <- list(`1` = c('x1:x2' = 2, 'x2:x1' = 1, 'x3:x4' = 1),
               `2` = c('x1:x2' = 3, 'x6:x1' = 2, 'x1:x1' = 1, 'x4:x3' = 1),
               `3` = c('x3:x4' = 2, 'x1:x2' = 1, 'x4:x3' = 4),
               `4` = c('x5:x2' = 1, 'x2:x5' = 1)
               )
> myList
$`1`
x1:x2 x2:x1 x3:x4
    2     1     1

$`2`
x1:x2 x6:x1 x1:x1 x4:x3
    3     2     1     1

$`3`
x3:x4 x1:x2 x4:x3
    2     1     4

$`4`
x5:x2 x2:x5
    1     1

在这里，我们可以看到在myList[[1]] 中有x1:x2 = 2 和x2:x1 = 1。因为它们是相反的，所以它们是等价的，所以本质上是x1:x2 = 3。

我正在尝试将每个命名元素（包括反向）的值与每个列表元素相加。

我想要的输出看起来像这样：

    var count listNo
1 x1:x2     3      1
2 x3:x4     1      1
3 x1:x2     3      2
4 x6:x1     2      2
5 x1:x1     1      2
6 x4:x3     1      2
7 x3:x4     6      3
8 x1:x2     1      3
9 x5:x2     2      4

【问题讨论】：

标签： r

【解决方案1】：

这很棘手。我有兴趣看到更优雅的解决方案

`row.names<-`(do.call(rbind, Map(function(vec, name) {  
    x <- names(vec)
    l <- sapply(strsplit(x, ":"), function(y) {
      paste0("x", sort(as.numeric(sub("\\D", "", y))), collapse = ":")
      })
    df <- setNames(as.data.frame(table(rep(l, vec))), c("var", "count"))
    df$listNo <- name
    df
  }, vec = myList, name = names(myList))), NULL)

#>     var count listNo
#> 1 x1:x2     3      1
#> 2 x3:x4     1      1
#> 3 x1:x1     1      2
#> 4 x1:x2     3      2
#> 5 x1:x6     2      2
#> 6 x3:x4     1      2
#> 7 x1:x2     1      3
#> 8 x3:x4     6      3
#> 9 x2:x5     2      4

^{由reprex package (v2.0.1) 于 2022-03-06 创建}

【讨论】：

如果所有的名字都是'x'、个位数、':'、'x'、个位数的形式，那么在我看来，一旦你在':'上拆分，你可以只做字符串排序。对于多个数字，您会遇到“x10”是否比“x2”更早排序的问题，因此您希望将所有数字填充为 0（或者只是接受事物具有字典顺序）。

【解决方案2】：

解决方案

这是与dplyr::bind_rows() 混合的基本 R 方法：

tmp <- lapply(1:length(myList), function(i) {
  tapply(setNames(myList[[i]], 
                  sapply(strsplit(names(myList[[i]]), ":"), 
                         function(x) paste0(sort(x), collapse = ":"))), 
         sapply(strsplit(names(myList[[i]]), ":"), 
                function(x) paste0(sort(x), collapse = ":")), sum)
})

bind_rows(tmp, .id = "listNo") |> 
  pivot_longer(!listNo, names_to = "var", values_to = "count", values_drop_na = T)

# A tibble: 9 x 3
  listNo var   count
  <chr>  <chr> <dbl>
1 1      x1:x2     3
2 1      x3:x4     1
3 2      x1:x2     3
4 2      x3:x4     1
5 2      x1:x1     1
6 2      x1:x6     2
7 3      x1:x2     1
8 3      x3:x4     6
9 4      x2:x5     2

微基准

出于好奇，我在现有答案上运行了microbenchmark，似乎@ThomasIsCoding 的解决方案在时间上已经击败了@AllanCameron：

microbenchmark::microbenchmark(
  Allan = {
    `row.names<-`(do.call(rbind, Map(function(vec, name) {  
      x <- names(vec)
      l <- sapply(strsplit(x, ":"), function(y) {
        paste0("x", sort(as.numeric(sub("\\D", "", y))), collapse = ":")
      })
      df <- setNames(as.data.frame(table(rep(l, vec))), c("var", "count"))
      df$listNo <- name
      df
    }, vec = myList, name = names(myList))), NULL)
    },
  benson23 = {
    tmp <- lapply(1:length(myList), function(i) {
      tapply(setNames(myList[[i]], 
                      sapply(strsplit(names(myList[[i]]), ":"), 
                             function(x) paste0(sort(x), collapse = ":"))), 
             sapply(strsplit(names(myList[[i]]), ":"), 
                    function(x) paste0(sort(x), collapse = ":")), sum)
    })
    
    bind_rows(tmp, .id = "listNo") |> 
      pivot_longer(!listNo, names_to = "var", values_to = "count", values_drop_na = T)
    
  },
  tmfmnk = {
    map_dfr(myList, enframe, .id = "listNo") %>%
      mutate(var = map_chr(str_split(name, ":"), ~ str_c(sort(.), collapse = ":"))) %>%
      group_by(listNo, var) %>%
      summarise(count = sum(value))
  },
  zephryl = {
    tibble(count = myList, listNo = names(myList)) %>%
      unnest_longer(count, indices_to = "var") %>% 
      mutate(
        var = str_extract_all(var, "\\d+"),
        var = map_chr(var, ~ str_glue("x{sort(.x)[[1]]}:x{sort(.x)[[2]]}"))
      ) %>% 
      group_by(listNo, var) %>%
      summarize(count = sum(count), .groups = "drop")
  },
  PaulS = {
    map_dfr(myList, identity, .id = "listNo") %>%
      pivot_longer(cols = -listNo, values_drop_na = T) %>% 
      rowwise %>%
      mutate(name = str_split(name, ":", simplify = T) %>% sort %>% 
               str_c(collapse = ":")) %>% 
      group_by(name, listNo) %>% 
      summarise(count = sum(value), .groups = "drop") 
  },
  TIC1 = {
    aggregate(
      count ~ .,
      transform(
        cbind(
          setNames(do.call(rbind, Map(stack, myList)), c("count", "var")),
          listNo = rep(seq_along(myList), lengths(myList))
        ),
        var = sapply(
          strsplit(as.character(var), ":"),
          function(x) paste0(sort(x), collapse = ":")
        )
      ),
      sum
    )
  },
  TIC2 = {
    aggregate(
      count ~ .,
      cbind(
        var = unlist(sapply(
          myList,
          function(x) {
            sapply(
              strsplit(names(x), ":"),
              function(v) paste0(sort(v), collapse = ":")
            )
          }
        )),
        setNames(stack(myList), c("count", "listNo"))
      ),
      sum
    )
  },
  Maël = {
    myList %>% 
      imap(~ .x %>% 
             enframe() %>% 
             separate(name, into = c("c1", "c2")) %>% 
             graph.data.frame(., directed = F) %>% 
             get.data.frame() %>% 
             group_by(from, to) %>% 
             summarise(count = sum(value)) %>% 
             unite(c("from","to"), col = "var", sep = ":") %>% 
             mutate(listNo = .y)) %>%
      bind_rows()
  })

Unit: milliseconds
     expr     min       lq      mean   median       uq      max neval  cld
    Allan  2.1327  2.25920  2.475978  2.33445  2.45270  12.3697   100 a   
 benson23  3.5083  3.80855  4.150929  4.03700  4.27685  13.3313   100 a   
   tmfmnk  5.4928  5.88520  6.324940  6.24190  6.66975   8.1777   100 ab  
  zephryl 10.1629 10.89110 14.813878 11.58475 12.14085 221.0931   100   c 
    PaulS  7.7565  8.44360 11.402325  9.10860  9.47480 124.1965   100  bc 
     TIC1  3.5233  3.88805  8.240207  4.06640  4.26765 202.9082   100 a c 
     TIC2  1.8722  2.03240  2.247993  2.13230  2.24045  10.7320   100 a   
     Maël 35.3066 39.52920 44.456091 40.96870 42.39480 170.8322   100    d

【讨论】：

【解决方案3】：

另一个tidyverse 选项可能是：

map_dfr(myList, enframe, .id = "listNo") %>%
    mutate(var = map_chr(str_split(name, ":"), ~ str_c(sort(.), collapse = ":"))) %>%
    group_by(listNo, var) %>%
    summarise(count = sum(value))

  listNo var   count
  <chr>  <chr> <dbl>
1 1      x1:x2     3
2 1      x3:x4     1
3 2      x1:x1     1
4 2      x1:x2     3
5 2      x1:x6     2
6 2      x3:x4     1
7 3      x1:x2     1
8 3      x3:x4     6
9 4      x2:x5     2

【讨论】：

【解决方案4】：

{tidyverse} 解决方案：

library(tidyverse)
               
tibble(count = myList, listNo = names(myList)) %>%
  unnest_longer(count, indices_to = "var") %>% 
  mutate(
    var = str_extract_all(var, "\\d+"),
    var = map_chr(var, ~ str_glue("x{sort(.x)[[1]]}:x{sort(.x)[[2]]}"))
  ) %>% 
  group_by(listNo, var) %>%
  summarize(count = sum(count), .groups = "drop")

# # A tibble: 9 x 3
#   listNo var   count
#   <chr>  <chr> <dbl>
# 1 1      x1:x2     3
# 2 1      x3:x4     1
# 3 2      x1:x1     1
# 4 2      x1:x2     3
# 5 2      x1:x6     2
# 6 2      x3:x4     1
# 7 3      x1:x2     1
# 8 3      x3:x4     6
# 9 4      x2:x5     2

【讨论】：

【解决方案5】：

另一种可能的解决方案，tidyverse-based：

library(tidyverse)

map_dfr(myList, identity, .id = "listNo") %>%
  pivot_longer(cols = -listNo, values_drop_na = T) %>% 
  rowwise %>%
  mutate(name = str_split(name, ":", simplify = T) %>% sort %>% 
         str_c(collapse = ":")) %>% 
  group_by(name, listNo) %>% 
  summarise(count = sum(value), .groups = "drop") 

#> # A tibble: 9 × 3
#>   name  listNo count
#>   <chr> <chr>  <dbl>
#> 1 x1:x1 2          1
#> 2 x1:x2 1          3
#> 3 x1:x2 2          3
#> 4 x1:x2 3          1
#> 5 x1:x6 2          2
#> 6 x2:x5 4          2
#> 7 x3:x4 1          1
#> 8 x3:x4 2          1
#> 9 x3:x4 3          6

【讨论】：

【解决方案6】：

使用aggregate + stack + strsplit 的两个基本 R 选项

TIC1 <- function() {
  aggregate(
    count ~ .,
    transform(
      cbind(
        setNames(do.call(rbind, Map(stack, myList)), c("count", "var")),
        listNo = rep(seq_along(myList), lengths(myList))
      ),
      var = sapply(
        strsplit(as.character(var), ":"),
        function(x) paste0(sort(x), collapse = ":")
      )
    ),
    sum
  )
}

或

TIC2 <- function() {
  aggregate(
    count ~ .,
    cbind(
      var = unlist(sapply(
        myList,
        function(x) {
          sapply(
            strsplit(names(x), ":"),
            function(v) paste0(sort(v), collapse = ":")
          )
        }
      )),
      setNames(stack(myList), c("count", "listNo"))
    ),
    sum
  )
}

给

> TIC1()
    var listNo count
1 x1:x2      1     3
2 x3:x4      1     1
3 x1:x1      2     1
4 x1:x2      2     3
5 x1:x6      2     2
6 x3:x4      2     1
7 x1:x2      3     1
8 x3:x4      3     6
9 x2:x5      4     2

> TIC2()
    var listNo count
1 x1:x2      1     3
2 x3:x4      1     1
3 x1:x1      2     1
4 x1:x2      2     3
5 x1:x6      2     2
6 x3:x4      2     1
7 x1:x2      3     1
8 x3:x4      3     6
9 x2:x5      4     2

基准测试

microbenchmark(
  TIC1(),
  TIC2(),
  Allan()
)

表演

Unit: milliseconds
    expr    min      lq     mean  median      uq     max neval
  TIC1() 4.2614 4.43265 4.902491 4.68145 4.89585 13.2152   100
  TIC2() 2.2116 2.29665 2.707671 2.51175 2.63690 10.3980   100
 Allan() 2.4817 2.59040 3.006702 2.71535 2.91005 16.6410   100

【讨论】：

【解决方案7】：

只是为了好玩，这里有一个data.table 解决方案。看看不同方法在更大列表中的扩展效果会很有趣。

library(data.table)
rowSort <- \(a) matrix(a[order(row(a), a)], nrow=dim(a)[1], byrow=TRUE, dimnames=dimnames(a))
res <- rbindlist(lapply(myList, \(count) as.data.table(count, keep.rownames="var")), idcol="listNo")
res[, c("p1", "p2"):= tstrsplit(var, ":")]
res[, var:=apply(rowSort(as.matrix(res[,.(p1,p2)])), 1, paste, collapse=":")][,
    .(count=sum(count)), .(listNo, var)]
#>    listNo   var count
#> 1:      1 x1:x2     3
#> 2:      1 x3:x4     1
#> 3:      2 x1:x2     3
#> 4:      2 x1:x6     2
#> 5:      2 x1:x1     1
#> 6:      2 x3:x4     1
#> 7:      3 x3:x4     6
#> 8:      3 x1:x2     1
#> 9:      4 x2:x5     2

对于提供的（小）示例列表，此修改似乎稍微快一些（并且勉强击败了我机器上的其他修改）：

tsrt <- \(x) vapply(strsplit(x, ":"), \(y) paste0(sort(y), collapse=":"), FUN.VALUE = NA_character_)
    res <- rbindlist(lapply(myList, \(count) as.data.table(count, keep.rownames="var")), idcol="listNo")
    res[, var:= tsrt(var)][, .(count=sum(count)), .(listNo, var)]

【讨论】：

【解决方案8】：

使用igraph 库，您可以创建无向图并对值求和。虽然有点长，但这个解决方案使用了我认为更容易理解的函数。

library(tidyverse)
library(igraph)

myList %>% 
  imap(~ .x %>% 
        enframe() %>% 
        separate(name, into = c("c1", "c2")) %>% 
        graph.data.frame(., directed = F) %>% 
        get.data.frame() %>% 
        group_by(from, to) %>% 
        summarise(count = sum(value)) %>% 
        unite(c("from","to"), col = "var", sep = ":") %>% 
        mutate(listNo = .y)) %>%
  bind_rows()

输出

# A tibble: 9 x 3
  var   count listNo
  <chr> <dbl> <chr> 
1 x1:x2     3 1     
2 x3:x4     1 1     
3 x1:x1     1 2     
4 x1:x2     3 2     
5 x1:x6     2 2     
6 x4:x3     1 2     
7 x1:x2     1 3     
8 x3:x4     6 3     
9 x5:x2     2 4

【讨论】：