基于ifelse，生成数据框的所有组合

Question

我很难应对以下问题： 我有一个数据框，看起来像这样：

  aa<-c(0,0,0,1,1,0,0)
  bb<-c(1,1,0,0,1,0,1)
  cc<-c(0,1,0,0,0,1,0)

  d<-data.frame(aa,bb,cc)

数据始终是二进制的，用于编码缺失/存在的数据。

我想要的是符合某些假设的变量所有可能组合的新列。对于这个数据框，它将会是：

d$aabb<-ifelse(d$aa=="1"&d$bb=="1"&d$cc=="0",1,0) #aa=1,bb=1,cc=0
d$aacc<-ifelse(d$aa=="1"&d$cc=="1"&d$bb=="0",1,0) #aa=1,bb=0,cc=1
d$bbcc<-ifelse(d$bb=="1"&d$cc=="1"&d$aa=="0",1,0) #aa=0,bb=1,cc=0
d$daabbcc<-ifelse(d$aa=="1"&d$bb=="1"&d$cc=="1",1,0) #aa=bb==cc=1

不过，我有30个列不想手动填写它们所有的内容。还有一个很好的事情是生成的列名是原始列名称的组合 (aa+bb->aabb) 等等。

我看了一下 expand.grid() 函数，但这不是我要找的东西。 提前感谢。

- user2386786

---

我想确认一下，您是否需要一个变量，当所有30个变量都为1时，29个变量为1，28个变量为1等等。因此，您需要类似于sapply(2:30, function(n)choose(30,n))的列吗？ - user1609452

如果你一开始有30列，考虑到所有可能的组合后，最终会得到2^30约等于10亿个列。你应该重新思考你的问题，看看是否真的需要这样做。至少，你应该列出哪些假设必须满足才能涉及这些组合。 - Hong Ooi

好的，你是对的。30列太多了。我将数据集减少到6个变量。但是我该如何将ifelse语句放入sapply中呢？ - user2386786

我完全同意@HongOoi的观点，并怀疑你是XY问题的受害者 :-) 你应该询问你实际想要做的最终目标。相反，你犯了一个错误，询问如何完成你心中已有的解决方案，没有给我们找到更好的解决方案的机会。 - Tomas

Answer 1

一些数据：

aa<-c(0,0,0,1,1,0,0)
bb<-c(1,1,0,0,1,0,1)
cc<-c(0,1,0,0,0,1,0)
dd<-rbinom(7,1,.5)
ee<-rbinom(7,1,.5)
ff<-rbinom(7,1,.5)
d<-data.frame(aa,bb,cc,dd,ee,ff)

创建一个变量，其中包含所有可能的值组合：

combinations <- apply(d,1,function(x) paste(names(d)[as.logical(x)],collapse=""))

将该变量转换为一组命名变量，并将结果绑定到d。

d2 <- sapply(unique(combinations), function(x) as.numeric(combinations==x))

防止重复列名，在原始df中只有一个值时：

colnames(d2) <- paste0(colnames(d2),"1") # could be any naming convention
d2 <- cbind(d, d2)

- Thomas

---

+1 我不太确定在 sapply 中使用 assign 是否合适（也许可以），但这样做可以很好地完成工作。干得好。 - Simon O'Hanlon

我认为这并不能完成任务。OP想要的是一个2^6 = 64列的数据集，其中包含从aa到ff的所有可能组合。每个列都是由AND运算得出的，其结果是由组成该特定组合的起始列组成的。 - Hong Ooi

2的6次方减1，因为似乎不需要d$NULL。 - user1609452

嗯，OP并没有明确说明他需要所有可能的组合还是只需要当前的组合。我的直觉是后者。 - Thomas

@SimonO101 我更新了；似乎 assign 实际上并不是必要的。 - Thomas

Thomas，非常感谢，这正是我在寻找的。运行速度非常快。 - user2386786

Answer 2

虽然这个编程练习可能不适用于实际问题，但还是很有趣的。以下是创建6列中所有63个（=2^6 - 1）可能组合的代码，不包括空值。（顺便说一句，我不明白问题有什么不清楚的地方；第二句话就说了“所有可能的组合”，示例代码中创建的一个变量全部为零（d$aabbcc）。）

# create the source data
d <- data.frame(matrix(rbinom(60, 1, 0.5), ncol=6))
names(d) <- letters[1:6]


# generate matrix of all possible combinations (except the null)
v <- as.matrix(expand.grid(rep(list(c(FALSE, TRUE)), ncol(d))))[-1, ]

# convert the matrix into a list of column indexes
indexes <- lapply(seq_len(nrow(v)), function(x) v[x, ])
names(indexes) <- apply(v, 1, function(x) paste(names(d)[x], collapse="."))

# compute values from the source data
out <- data.frame(lapply(indexes, function(i) as.numeric(apply(d[i], 1, all))))

这里有一些不必要的计算，最明显的是后面的组合没有重复利用前面的值。即使有1000行数据，也只需要几分之一秒，而有100000行数据时只需要几秒钟。由于该问题仅适用于少量列数据，我认为进一步优化并不值得麻烦。

- Hong Ooi

---

对于实际付出努力并用如此简短的代码块来实现这一点，我感到惊讶，但我还是要给你们点赞。 - Thomas

Answer 3

使用sets包的一种可能解决方案...

按照给定的设置进行操作：

aa <- c(0, 0, 0, 1, 1, 0, 0)
bb <- c(1, 1, 0, 0, 1, 0, 1)
cc <- c(0, 1, 0, 0, 0, 1, 0)

d <- data.frame(aa, bb, cc)

准备环境...

require(sets, quietly = T)
require(data.table, quietly = T)

通过从 d 创建一组集合，按 'set' 顺序创建唯一名称列表。

# Created as a list so that duplicates are kept.
namesets <- sapply(seq_len(nrow(d)), function(i) {
    gset(colnames(d), memberships = d[i, ])
})

# Then combine the set memberships into names and assign to the sets.
setnames <- sapply(namesets, function(s) {
    ifelse(set_is_empty(s), "none", paste(as.character(s), collapse = ""))
})
names(namesets) <- setnames

# Creating set of sets from namesets orders the names and removes duplicates.
namesets <- as.set(namesets)

print(namesets)

## {none = {}, aa = {"aa"}, bb = {"bb"}, cc = {"cc"}, aabb = {"aa",
##  "bb"}, bbcc = {"bb", "cc"}}

# Making it easy to create an ordered listing that we can use as a key.
setnames <- ordered(setnames, levels = names(namesets))
print(setnames)

## [1] bb   bbcc none aa   aabb cc   bb  
## Levels: none < aa < bb < cc < aabb < bbcc

将 d 转换为 data.table，我们可以以各种方式填充成员集列...

# First a simple membership to key-by
dt <- data.table(membership = setnames, d, key = "membership")
print(dt)

##    membership aa bb cc
## 1:       none  0  0  0
## 2:         aa  1  0  0
## 3:         bb  0  1  0
## 4:         bb  0  1  0
## 5:         cc  0  0  1
## 6:       aabb  1  1  0
## 7:       bbcc  0  1  1


# That might be enough for some, but the OP wants columns
# indicating a membership; so just join a matrix...
membership.map <- t(sapply(dt$membership, function(m) {
    m == levels(dt$membership)
}) * 1)
colnames(membership.map) <- levels(dt$membership)

dt <- cbind(dt, split = " ==> ", membership.map)

print(dt)

##    membership aa bb cc split none aa bb cc aabb bbcc
## 1:       none  0  0  0  ==>     1  0  0  0    0    0
## 2:         aa  1  0  0  ==>     0  1  0  0    0    0
## 3:         bb  0  1  0  ==>     0  0  1  0    0    0
## 4:         bb  0  1  0  ==>     0  0  1  0    0    0
## 5:         cc  0  0  1  ==>     0  0  0  1    0    0
## 6:       aabb  1  1  0  ==>     0  0  0  0    1    0
## 7:       bbcc  0  1  1  ==>     0  0  0  0    0    1

这一切都可以用一个快速而简单的函数来实现，如下所示：

membership.table <- function(df) {

    namesets <- sapply(seq_len(nrow(d)), function(i) {
        gset(colnames(d), memberships = d[i, ])
    })

    setnames <- sapply(namesets, function(s) {
        ifelse(set_is_empty(s), "none", paste(as.character(s), collapse = ""))
    })
    names(namesets) <- setnames

    namesets <- as.set(namesets)
    setnames <- ordered(setnames, levels = names(namesets))

    dt <- data.table(membership = setnames, d, key = "membership")
    membership.map <- t(sapply(dt$membership, function(m) {
        m == levels(dt$membership)
    }) * 1)
    colnames(membership.map) <- levels(dt$membership)

    cbind(dt, split = " ==> ", membership.map)
}



mt <- membership.table(d)
identical(dt, mt)

## [1] TRUE

现在，当我们按键总结成员表并从原始数据创建广义集时，应该得到匹配结果的成员信息。

mt[, lapply(.SD, sum), by = membership, .SDcols = seq(3 + ncol(d), ncol(mt))]

##    membership none aa bb cc aabb bbcc
## 1:       none    1  0  0  0    0    0
## 2:         aa    0  1  0  0    0    0
## 3:         bb    0  0  2  0    0    0
## 4:         cc    0  0  0  1    0    0
## 5:       aabb    0  1  1  0    1    0
## 6:       bbcc    0  0  1  1    0    1


as.list(as.gset(d))

## $`3`
## (aa = 0, bb = 0, cc = 0)
## 
## $`6`
## (aa = 0, bb = 0, cc = 1)
## 
## $`1`
## (aa = 0, bb = 1, cc = 0)
## 
## $`2`
## (aa = 0, bb = 1, cc = 1)
## 
## $`4`
## (aa = 1, bb = 0, cc = 0)
## 
## $`5`
## (aa = 1, bb = 1, cc = 0)
## 
## attr(,"memberships")
## 
## 1 2 3 4 5 6 
## 1 1 2 1 1 1

请注意，在成员表中，bb 的总和为 2，广义集列表中的第三个项目（表示bb）也显示了 2 个这样的集合。

---

如果将同样的算法应用于洪先生的示例，则结果如下：

##     membership a b c d e f split a bc ce abd acd ade abef acdef abcdef
##  1:          a 1 0 0 0 0 0  ==>  1  0  0   0   0   0    0     0      0
##  2:         bc 0 1 1 0 0 0  ==>  0  1  0   0   0   0    0     0      0
##  3:         ce 0 0 1 0 1 0  ==>  0  0  1   0   0   0    0     0      0
##  4:        abd 1 1 0 1 0 0  ==>  0  0  0   1   0   0    0     0      0
##  5:        acd 1 0 1 1 0 0  ==>  0  0  0   0   1   0    0     0      0
##  6:        ade 1 0 0 1 1 0  ==>  0  0  0   0   0   1    0     0      0
##  7:       abef 1 1 0 0 1 1  ==>  0  0  0   0   0   0    1     0      0
##  8:      acdef 1 0 1 1 1 1  ==>  0  0  0   0   0   0    0     1      0
##  9:     abcdef 1 1 1 1 1 1  ==>  0  0  0   0   0   0    0     0      1
## 10:     abcdef 1 1 1 1 1 1  ==>  0  0  0   0   0   0    0     0      1

虽然这个解决方案做了更多的事情（例如排序和排序），但与Hong的解决方案相比，时间并不太可怕；但与Thomas的解决方案相比...

## Unit: milliseconds
##        expr     min      lq  median      uq     max neval
##          hf 241.810 246.411 253.634 262.544 290.345    10
##          mt 128.105 137.931 142.966 154.244 210.276    10
##          tf   1.754   1.768   1.806   2.312   3.487    10
##  plain.gset   1.220   1.330   1.386   1.475   1.644    10

两种解决方案都很慢。如果只需要处理集合，那么可能需要在集合说明文档中花费一些时间，特别是对于较大的成员。

- Thell

---

抱歉长度有点长，我就是忍不住了。 :) - Thell

当然，与Thomas的解决方案相比，它们很慢，因为它们没有做同样的事情。 - Hong Ooi

Answer 4

由于所有数据都是二进制的，也就是逻辑的，为什么不将每个潜在的组合转换成一个数字（从零到2^N），然后，类似于@Thomas的答案，将数据框中的每一行转换为单个二进制序列，然后你的新列将简单地是row_value[j] == column_numeric_value[k]（廉价伪代码）。也就是说，对于一个简单的三列输入，有8种可能的输出。如果row[j]是1 0 1，那么row_value[j]是十进制的“5”，并且row_value[j] == column_numeric_value[5]为真，并且对于所有其他列都为假。

- Carl Witthoft