列表中所有可能的組合

Question

我的數據框：

data <- structure(list(group = c(1L, 1L, 1L, 1L, 1L, 1L,1L,1L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), col1 = c(9, 
9.05, 7.15, 7.21, 7.34, 8.12, 7.5, 7.84, 7.8, 7.52, 8.84, 6.98, 
6.1, 6.89, 6.5, 7.5, 7.8, 5.5, 6.61, 7.65, 7.68,8.0,9.0), col2 = c(11L, 
11L, 10L, 1L, 3L, 7L, 11L, 11L, 11L, 11L, 4L, 1L, 1L, 1L, 2L, 
2L, 1L, 4L, 8L, 8L, 1L,3L,4L), col3 = c(7L, 11L, 3L, 7L, 11L, 2L, 11L, 
5L, 11L, 11L, 5L, 11L, 11L, 2L, 9L, 9L, 3L, 8L, 11L, 11L, 2L,5L,6L), 
    col4 = c(11L, 11L, 11L, 11L, 6L, 11L, 11L, 11L, 10L, 7L, 
    11L, 2L, 11L, 3L, 11L, 11L, 6L, 11L, 1L, 11L, 11L,13L,12L), col5 = c(11L, 
    1L, 2L, 2L, 11L, 11L, 1L, 10L, 2L, 11L, 1L, 3L, 11L, 11L, 
    8L, 8L, 11L, 11L, 11L, 2L, 9L,4L,5L)), .Names = c("group", "col1", 
"col2", "col3", "col4", "col5"), class = "data.frame", row.names = c(NA, 
-21L))

功能：

comb <- list(c(2, 4), c(3, 5), c(4, 6))

test.fun <- function(dat) { 
  do.call(rbind, lapply(comb, function(x) {
    SUM <- dat[[x[1]]]+dat[[x[2]]]
    data.frame(NAME = sprintf('Group %s by Group %s', x[1], x[2]),
                SUM)
   
  }))
}

result <- purrr::map_df(split(data, data$group), test.fun, .id = 'Group')

現在此函數處理list(c(2, 4), c(3, 5), c(4, 6)) 2 列列表。 我希望它處理任何金額，例如：

list(c(2, 4, 6), c(3, 5, 6), c(3, 4, 6), c(2, 3), c(3, 5))

Answer 1

可能這有幫助

test.fun <- function(dat, comb) { 
  do.call(rbind, lapply(comb, function(x) {
    SUM <- rowSums(dat[x], na.rm = TRUE)
    data.frame(NAME = paste0("Group ", toString(x)),
                SUM)
   
  }))
}

-測試

comb2 <- list(c(2, 4, 6), c(3, 5, 6), c(3, 4, 6), c(2, 3), c(3, 5))

purrr::map_df(split(data, data$group), test.fun, comb = comb2, .id = 'Group') %>%
    as_tibble

-輸出

# A tibble: 115 × 3
   Group NAME            SUM
   <chr> <chr>         <dbl>
 1 1     Group 2, 4, 6  27  
 2 1     Group 2, 4, 6  21.0
 3 1     Group 2, 4, 6  12.2
 4 1     Group 2, 4, 6  16.2
 5 1     Group 2, 4, 6  29.3
 6 1     Group 2, 4, 6  21.1
 7 1     Group 2, 4, 6  19.5
 8 1     Group 2, 4, 6  22.8
 9 1     Group 3, 5, 6  33  
10 1     Group 3, 5, 6  23  
# … with 105 more rows

---

對於成對，使用combn

 bind_rows(lapply(comb2, function(x) {
   SUM <- combn(x, 2, FUN = function(y) rowSums(data[y], 
          na.rm = TRUE))
   nm1 <- rep(combn(x, 2, FUN = paste, collapse="_"), 
       each = nrow(data))
   data.frame(NAME= nm1, SUM)}))

Answer 2

一種避免昂貴的數據split outer方式。 SUM是在Vectorize d FUN派生的子集上使用rowSums實現的。 我使用了更多組的不同數據，

groupFun <- function(data, comb2) {
  FUN <- Vectorize(function(x, y) rowSums(data[data$group == x, y]), SIMPLIFY=F)
  o <- outer(unique(data$group), comb2, FUN)
  res <- cbind(
    expand.grid(
      Group=as.character(data$group), 
      NAME=sapply(comb2, function(x) sprintf('Group %s by Group %s', x[1], x[2])),
      stringsAsFactors=FALSE), 
    SUM=unlist(o))
  res <- res[order(res$Group), ]  ## optional
  return(res)
}

在哪里：

all.equal(purrr::map_df(split(data, data$group), test.fun, .id = 'Group'),
          `rownames<-`(groupFun(data, comb), NULL))
# [1] TRUE

結果

comb2 <- list(c(2, 4, 6), c(3, 5, 6), c(3, 4, 6), c(2, 3), c(3, 5))

groupFun(data, comb2)
#    Group               NAME   SUM
# 1      1 Group 2 by Group 4 16.56
# 2      1 Group 2 by Group 4 13.26
# 13     1 Group 3 by Group 5 14.00
# 14     1 Group 3 by Group 5 12.00
# 25     1 Group 3 by Group 4 22.00
# 26     1 Group 3 by Group 4 14.00
# 37     1 Group 2 by Group 3 12.56
# 38     1 Group 2 by Group 3  7.26
# 49     1 Group 3 by Group 5 11.00
# 50     1 Group 3 by Group 5  9.00
# 3      2 Group 2 by Group 4 17.84
# 4      2 Group 2 by Group 4 24.43
# 15     2 Group 3 by Group 5 14.00
# 16     2 Group 3 by Group 5 10.00
# 27     2 Group 3 by Group 4 14.00
# 28     2 Group 3 by Group 4 17.00
# 39     2 Group 2 by Group 3 13.84
# 40     2 Group 2 by Group 3 11.43
# 51     2 Group 3 by Group 5 10.00
# 52     2 Group 3 by Group 5  4.00
# 5      3 Group 2 by Group 4 24.10
# 6      3 Group 2 by Group 4 17.02
# 17     3 Group 3 by Group 5 26.00
# 18     3 Group 3 by Group 5 22.00
# 29     3 Group 3 by Group 4 23.00
# 30     3 Group 3 by Group 4 21.00
# 41     3 Group 2 by Group 3 15.10
# 42     3 Group 2 by Group 3 14.02
# 53     3 Group 3 by Group 5 15.00
# 54     3 Group 3 by Group 5 12.00
# 7      4 Group 2 by Group 4 20.97
# 8      4 Group 2 by Group 4 22.87
# 19     4 Group 3 by Group 5 24.00
# 20     4 Group 3 by Group 5 11.00
# 31     4 Group 3 by Group 4 25.00
# 32     4 Group 3 by Group 4 19.00
# 43     4 Group 2 by Group 3 11.97
# 44     4 Group 2 by Group 3 13.87
# 55     4 Group 3 by Group 5 18.00
# 56     4 Group 3 by Group 5  7.00
# 9      5 Group 2 by Group 4 25.45
# 10     5 Group 2 by Group 4 21.83
# 21     5 Group 3 by Group 5 22.00
# 22     5 Group 3 by Group 5 22.00
# 33     5 Group 3 by Group 4 25.00
# 34     5 Group 3 by Group 4 20.00
# 45     5 Group 2 by Group 3 20.45
# 46     5 Group 2 by Group 3 19.83
# 57     5 Group 3 by Group 5 16.00
# 58     5 Group 3 by Group 5 14.00
# 11     6 Group 2 by Group 4 14.89
# 12     6 Group 2 by Group 4 25.77
# 23     6 Group 3 by Group 5 22.00
# 24     6 Group 3 by Group 5 18.00
# 35     6 Group 3 by Group 4 20.00
# 36     6 Group 3 by Group 4 20.00
# 47     6 Group 2 by Group 3 14.89
# 48     6 Group 2 by Group 3 15.77
# 59     6 Group 3 by Group 5 17.00
# 60     6 Group 3 by Group 5 12.00

基准

# Unit: milliseconds
#  expr      min       lq     mean   median       uq       max neval cld
# purrr 7.067411 7.173874 7.887650 7.253130 8.325982 17.341812   100   b
# outer 3.233047 3.296393 3.499889 3.366309 3.466582  5.976934   100  a 

快兩倍多。

---

數據

data <- structure(list(group = c(1L, 1L, 2L, 2L, 3L, 3L, 4L, 4L, 5L, 
5L, 6L, 6L), col1 = c(2.13, 8.91, 8.72, 1.26, 10.7, 1.23, 2.05, 
2.77, 9.35, 8.82, 8.41, 1.1), col2 = c(4, 8, 9, 1, 11, 6, 6, 
11, 1, 7, 9, 1), col3 = c(10, 2, 9, 7, 10, 7, 4, 10, 4, 10, 11, 
1), col4 = c(5, 6, 8, 7, 2, 6, 10, 4, 10, 3, 4, 10), col5 = c(4, 
8, 9, 4, 1, 9, 7, 7, 7, 8, 2, 9)), row.names = c(NA, -12L), class = "data.frame")