将因子或整数分组到R中的等价类中
我有一个数据框，表示来自两个集合的成员之间的等价性：将因子或整数分组到R中的等价类中,r,R,我有一个数据框，表示来自两个集合的成员之间的等价性： print(x) G S 1 g1 s2 2 g1 s1 3 g2 s3 4 g3 s3 5 g4 s3 有人知道将对象分组为等价类的函数或有用的数据结构吗？在上面的例子中，结果应该是两个等价类 {g1, s1, s2}, {g2, g3, g4, s3} 您可以使用outer测试相等性，并将它们与|或组合。从该矩阵中获取唯一的行，然后使用apply返回组列表 tt <- outer(x$G, x$G, "==
print(x)
G S
1 g1 s2
2 g1 s1
3 g2 s3
4 g3 s3
5 g4 s3
{g1, s1, s2}, {g2, g3, g4, s3}
您可以使用outer测试相等性，并将它们与|或组合。从该矩阵中获取唯一的行，然后使用apply返回组列表
tt <- outer(x$G, x$G, "==") | outer(x$S, x$S, "==")
tt <- unique(tt)
apply(tt, 1, function(i) unique(unlist(x[i,])))
#[[1]]
#[1] "g1" "s2" "s1"
#
#[[2]]
#[1] "g2" "g3" "g4" "s3"
您可以使用outer测试相等性，并将它们与|或组合。从该矩阵中获取唯一的行，然后使用apply返回组列表
tt <- outer(x$G, x$G, "==") | outer(x$S, x$S, "==")
tt <- unique(tt)
apply(tt, 1, function(i) unique(unlist(x[i,])))
#[[1]]
#[1] "g1" "s2" "s1"
#
#[[2]]
#[1] "g2" "g3" "g4" "s3"
您可以应用以下代码进行分组
# function to categorize incoming `v` within existing `lst`
grp <- function(lst, v) {
if (length(lst) == 0) return(c(lst,list(v)))
idx <- which(unlist(Map(function(x) any(!is.na(match(v,x))), lst)))
if (length(idx) == 0) {
lst <- c(lst,list(v))
} else {
lst[idx] <- list(union(unlist(lst[idx]),v))
}
return(unique(lst))
}
# generate grouping results
df <- unique(df)
res <- Reduce(function(lst,x) grp(lst,x),
c(list(NULL),unname(Map(function(x) as.character(unlist(x)),split(df,seq(nrow(df)))))),
accumulate = F)
给定输入数据df可以应用以下代码进行分组
# function to categorize incoming `v` within existing `lst`
grp <- function(lst, v) {
if (length(lst) == 0) return(c(lst,list(v)))
idx <- which(unlist(Map(function(x) any(!is.na(match(v,x))), lst)))
if (length(idx) == 0) {
lst <- c(lst,list(v))
} else {
lst[idx] <- list(union(unlist(lst[idx]),v))
}
return(unique(lst))
}
# generate grouping results
df <- unique(df)
res <- Reduce(function(lst,x) grp(lst,x),
c(list(NULL),unname(Map(function(x) as.character(unlist(x)),split(df,seq(nrow(df)))))),
accumulate = F)
library(igraph)
g <- graph_from_data_frame(x)
m <- clusters(g)$membership
tapply(names(m), m, sort)
library(igraph)
g <- graph_from_data_frame(x)
m <- clusters(g)$membership
tapply(names(m), m, sort)
为了通过和比较这三个答案的运行时间，我创建了大小不同的随机集n，并测量了从proc.time经过的运行时间 从结果中，我得出结论，依赖IGRAPHE的连接组件分解的方法是最快的：
n chinsoon12 ThomasisCoding GKi
500 0.002 0.054 0.030
2500 0.010 0.203 0.416
5000 0.020 0.379 1.456
7500 0.033 0.670 3.351
10000 0.044 0.832 5.837
library(igraph)
# solution by chinsson12: CC decomposition from igraph
method.A <- function() {
g <- graph_from_data_frame(x)
m <- clusters(g)$membership
res <- tapply(names(m), m, sort)
return(res)
}
# solution by ThomasisCoding
method.B <- function() {
# find 1-to-1 mapping
r <- Reduce(intersect,lapply(names(x), function(v) split(x,x[v])))
r1map <- unlist(Map(toString,Map(unlist,r)))
# removel one-to-one mapping and find N-to-1 mapping
if (length(r1map) >0) {
xx <- x[-as.numeric(rownames(Reduce(rbind,r))),]
} else {
xx <- x
}
rNmap <- c()
if (nrow(xx)> 0) {
rNmap <- sapply(names(xx),
function(v) {
z <- split(xx,xx[v])
u <- z[unlist(Map(nrow,z))>1]
ifelse(length(u)==0, NA, toString(c(names(u),as.vector(u[[1]][,setdiff(names(xx),v)]))))
},USE.NAMES = F)
rNmap <- rNmap[!is.na(rNmap)]
}
# combine both 1-to-1 and n-to-1 mappings
res <- c(r1map,rNmap)
return(res)
}
# solution by GKi: with outer product
method.C <- function() {
tt <- outer(x$G, x$G, "==") | outer(x$S, x$S, "==")
tt <- unique(tt)
res <- apply(tt, 1, function(i) unique(unlist(x[i,])))
return(res)
}
# runtime results
rt <- data.frame()
for (n in seq(500,10000, by=500)) {
# this won't work because of ambigous node ids (see [answer by GKi][6]):
#x <- data.frame(G = sample(1:n,n,replace=TRUE), S = sample(1:n,n,replace=TRUE))
# therefore, make the node ids unique:
x <- data.frame(G = sprintf("g%i", sample(1:n,n,replace=TRUE)), S = sprintf("s%i", sample(1:n,n,replace=TRUE)))
t1 <- proc.time()
method.A()
tA <- proc.time() - t1
t1 <- proc.time()
method.B()
tB <- proc.time() - t1
t1 <- proc.time()
method.C()
tC <- proc.time() - t1
rt <- rbind(rt, data.frame(n=n, t.A=tA[["elapsed"]], t.B=tB[["elapsed"]], t.C=tC[["elapsed"]]))
}
print(rt)
plot(rt$n, rt$t.C, xlab="n", ylab="run time [s]", ylim=c(min(rt$t.A),max(rt$t.C)), type='l')
lines(rt$n, rt$t.B, col="red")
lines(rt$n, rt$t.A, col="blue")
legend("topleft", c("GKi", "ThomasisCoding", "chinsoon12"), lt=c(1,1,1), col=c("black", "red", "blue"))
为了通过和比较这三个答案的运行时间，我创建了大小不同的随机集n，并测量了从proc.time经过的运行时间 从结果中，我得出结论，依赖IGRAPHE的连接组件分解的方法是最快的：
n chinsoon12 ThomasisCoding GKi
500 0.002 0.054 0.030
2500 0.010 0.203 0.416
5000 0.020 0.379 1.456
7500 0.033 0.670 3.351
10000 0.044 0.832 5.837
library(igraph)
# solution by chinsson12: CC decomposition from igraph
method.A <- function() {
g <- graph_from_data_frame(x)
m <- clusters(g)$membership
res <- tapply(names(m), m, sort)
return(res)
}
# solution by ThomasisCoding
method.B <- function() {
# find 1-to-1 mapping
r <- Reduce(intersect,lapply(names(x), function(v) split(x,x[v])))
r1map <- unlist(Map(toString,Map(unlist,r)))
# removel one-to-one mapping and find N-to-1 mapping
if (length(r1map) >0) {
xx <- x[-as.numeric(rownames(Reduce(rbind,r))),]
} else {
xx <- x
}
rNmap <- c()
if (nrow(xx)> 0) {
rNmap <- sapply(names(xx),
function(v) {
z <- split(xx,xx[v])
u <- z[unlist(Map(nrow,z))>1]
ifelse(length(u)==0, NA, toString(c(names(u),as.vector(u[[1]][,setdiff(names(xx),v)]))))
},USE.NAMES = F)
rNmap <- rNmap[!is.na(rNmap)]
}
# combine both 1-to-1 and n-to-1 mappings
res <- c(r1map,rNmap)
return(res)
}
# solution by GKi: with outer product
method.C <- function() {
tt <- outer(x$G, x$G, "==") | outer(x$S, x$S, "==")
tt <- unique(tt)
res <- apply(tt, 1, function(i) unique(unlist(x[i,])))
return(res)
}
# runtime results
rt <- data.frame()
for (n in seq(500,10000, by=500)) {
# this won't work because of ambigous node ids (see [answer by GKi][6]):
#x <- data.frame(G = sample(1:n,n,replace=TRUE), S = sample(1:n,n,replace=TRUE))
# therefore, make the node ids unique:
x <- data.frame(G = sprintf("g%i", sample(1:n,n,replace=TRUE)), S = sprintf("s%i", sample(1:n,n,replace=TRUE)))
t1 <- proc.time()
method.A()
tA <- proc.time() - t1
t1 <- proc.time()
method.B()
tB <- proc.time() - t1
t1 <- proc.time()
method.C()
tC <- proc.time() - t1
rt <- rbind(rt, data.frame(n=n, t.A=tA[["elapsed"]], t.B=tB[["elapsed"]], t.C=tC[["elapsed"]]))
}
print(rt)
plot(rt$n, rt$t.C, xlab="n", ylab="run time [s]", ylim=c(min(rt$t.A),max(rt$t.C)), type='l')
lines(rt$n, rt$t.B, col="red")
lines(rt$n, rt$t.A, col="blue")
legend("topleft", c("GKi", "ThomasisCoding", "chinsoon12"), lt=c(1,1,1), col=c("black", "red", "blue"))
方法结果比较：
method.A()
#$`1`
#[1] "1" "2" "3" "4"
method.A2()
#$`1`
#[1] "3" "1" "4" "2"
#
#$`2`
#[1] "2" "3"
method.B()
#[[1]]
#[1] 3 1 4 2
#
#[[2]]
#[1] 2 3
method.C()
#[[1]]
#[[1]]$All
#[1] 3 1 4 2
#
#[[1]]$G
#[1] 3 1
#
#[[1]]$S
#[1] 4 2 1
#
#
#[[2]]
#[[2]]$All
#[1] 2 3
#
#[[2]]$G
#[1] 2
#
#[[2]]$S
#[1] 3
library(igraph)
method.A <- function() {
g <- graph_from_data_frame(x)
m <- clusters(g)$membership
res <- tapply(names(m), m, sort)
return(res)
}
method.A2 <- function() {
g <- graph_from_data_frame(t(apply(x, 1, function(x) paste0(names(x), x))))
m <- clusters(g)$membership
res <- tapply(substring(names(m),2), m, unique)
return(res)
}
method.B <- function() {
G2S <- function(df,g) {
df[df$G %in% g,]$S
}
S2G <- function(df,s) {
df[df$S %in%s,]$G
}
grpFun <- function(df, g) {
repeat {
gt <- S2G(df, (s<-G2S(df, g)))
if (length(gt) == length(g)) return(list(G = gt, S = s))
g <- gt
}
}
res <- c()
Gpool <- x$G
repeat {
if (length(Gpool)==0) break
grp <- grpFun(x,Gpool[1])
Gpool <- setdiff(Gpool,grp$G)
res <- c(res, list(union(unique(grp$G),unique(grp$S))))
}
return(res)
}
method.C <- function() {
y <- unique(x)
t1 <- tt1 <- y[1,1]
t2 <- tt2 <- y[1,2]
y <- y[-1,]
n <- 1
res <- list(0)
repeat {
i <- y[,1] %in% tt1 | y[,2] %in% tt2
tt <- y[i,]
y <- y[!i,]
tt1 <- unique(tt[!tt[,1] %in% tt1,1])
tt2 <- unique(tt[!tt[,2] %in% tt2,2])
if(length(tt1) + length(tt2) > 0) {
t1 <- c(t1, tt1)
t2 <- c(t2, tt2)
} else {
res[[n]] <- list(All=unique(c(t1, t2)), G=unique(t1), S=unique(t2))
if(nrow(y) == 0) break;
n <- n + 1
t1 <- tt1 <- y[1,1]
t2 <- tt2 <- y[1,2]
y <- y[-1,]
}
}
res
}
方法结果比较：
method.A()
#$`1`
#[1] "1" "2" "3" "4"
method.A2()
#$`1`
#[1] "3" "1" "4" "2"
#
#$`2`
#[1] "2" "3"
method.B()
#[[1]]
#[1] 3 1 4 2
#
#[[2]]
#[1] 2 3
method.C()
#[[1]]
#[[1]]$All
#[1] 3 1 4 2
#
#[[1]]$G
#[1] 3 1
#
#[[1]]$S
#[1] 4 2 1
#
#
#[[2]]
#[[2]]$All
#[1] 2 3
#
#[[2]]$G
#[1] 2
#
#[[2]]$S
#[1] 3
library(igraph)
method.A <- function() {
g <- graph_from_data_frame(x)
m <- clusters(g)$membership
res <- tapply(names(m), m, sort)
return(res)
}
method.A2 <- function() {
g <- graph_from_data_frame(t(apply(x, 1, function(x) paste0(names(x), x))))
m <- clusters(g)$membership
res <- tapply(substring(names(m),2), m, unique)
return(res)
}
method.B <- function() {
G2S <- function(df,g) {
df[df$G %in% g,]$S
}
S2G <- function(df,s) {
df[df$S %in%s,]$G
}
grpFun <- function(df, g) {
repeat {
gt <- S2G(df, (s<-G2S(df, g)))
if (length(gt) == length(g)) return(list(G = gt, S = s))
g <- gt
}
}
res <- c()
Gpool <- x$G
repeat {
if (length(Gpool)==0) break
grp <- grpFun(x,Gpool[1])
Gpool <- setdiff(Gpool,grp$G)
res <- c(res, list(union(unique(grp$G),unique(grp$S))))
}
return(res)
}
method.C <- function() {
y <- unique(x)
t1 <- tt1 <- y[1,1]
t2 <- tt2 <- y[1,2]
y <- y[-1,]
n <- 1
res <- list(0)
repeat {
i <- y[,1] %in% tt1 | y[,2] %in% tt2
tt <- y[i,]
y <- y[!i,]
tt1 <- unique(tt[!tt[,1] %in% tt1,1])
tt2 <- unique(tt[!tt[,2] %in% tt2,2])
if(length(tt1) + length(tt2) > 0) {
t1 <- c(t1, tt1)
t2 <- c(t2, tt2)
} else {
res[[n]] <- list(All=unique(c(t1, t2)), G=unique(t1), S=unique(t2))
if(nrow(y) == 0) break;
n <- n + 1
t1 <- tt1 <- y[1,1]
t2 <- tt2 <- y[1,2]
y <- y[-1,]
}
}
res
}
n t.A t.B t.C
1 500 0.00 0.09 0.13
2 1000 0.01 0.15 0.23
3 1500 0.01 0.22 0.38
4 2000 0.03 0.31 0.50
5 2500 0.05 0.45 0.76
6 3000 0.07 0.51 0.77
7 3500 0.06 0.67 0.97
8 4000 0.07 0.85 1.20
9 4500 0.07 0.90 1.39
10 5000 0.09 1.23 1.55
11 5500 0.09 1.30 1.78
12 6000 0.09 1.51 1.94
13 6500 0.11 1.77 2.20
14 7000 0.13 2.18 2.55
15 7500 0.12 2.37 2.79
16 8000 0.13 2.56 2.96
17 8500 0.14 2.76 3.39
18 9000 0.15 3.03 3.54
19 9500 0.15 3.54 4.23
20 10000 0.16 3.76 4.32
n t.A t.B t.C
1 500 0.00 0.09 0.13
2 1000 0.01 0.15 0.23
3 1500 0.01 0.22 0.38
4 2000 0.03 0.31 0.50
5 2500 0.05 0.45 0.76
6 3000 0.07 0.51 0.77
7 3500 0.06 0.67 0.97
8 4000 0.07 0.85 1.20
9 4500 0.07 0.90 1.39
10 5000 0.09 1.23 1.55
11 5500 0.09 1.30 1.78
12 6000 0.09 1.51 1.94
13 6500 0.11 1.77 2.20
14 7000 0.13 2.18 2.55
15 7500 0.12 2.37 2.79
16 8000 0.13 2.56 2.96
17 8500 0.14 2.76 3.39
18 9000 0.15 3.03 3.54
19 9500 0.15 3.54 4.23
20 10000 0.16 3.76 4.32
哇，真聪明！不幸的是，它只适用于中等大小的数据帧，因为它是^2$例程上的$。@cdalitz是的，对于较长的数据，外部可能会成为一个问题。我添加了三种建议解决方案的运行时比较。事实证明，这种基于外部的解决方案对于大型n来说确实很慢。哇，这很聪明！不幸的是，它只适用于中等大小的数据帧，因为它是^2$例程上的$。@cdalitz是的，对于较长的数据，外部可能会成为一个问题。我添加了三种建议解决方案的运行时比较。事实证明，这种基于外部的解决方案对于大n来说确实很慢。啊，是的，简单地让igraph将图划分为连接的组件。根据igraph文档，这是通过广度优先搜索完成的，因此这应该比使用outer的解决方案快得多。啊，是的，简单地让igraph将图划分为连接的组件。根据igraph文档，这是通过广度优先搜索完成的，因此这应该比使用outer的解决方案快得多。除了此代码产生的错误“names”属性[4]的长度必须与向量[2]相同之外，我必须承认我不理解它。在这种情况下，sapply不应该返回与给定向量namedf一样多的组件，因此不能返回两个以上的组？此外，我想知道运行时的复杂性是什么。您好@cdalitz，您能展示一下发生错误的测试数据吗？我想知道是否由于您使用的数据帧与此不兼容而导致某些问题solution@cdalitz该解决方案的思想是通过所有列中的条目对df进行分类，并选择具有多行的类别，即n-to-1映射，把这些都整理好groups@cdalitz我添加了另一个计算复杂度较低的版本，例如，可能是线性复杂度w.r.t.每组的行数。您可以检查。@cdalitz很抱歉，我在上一个解决方案中有一个小缺陷。现在已经修好了！你可以用igraph继续前进！我只是对在BaseR中等价地实现它非常感兴趣，所以我一遍又一遍地尝试使它正确：除了这个代码产生错误'names'属性的问题之外
e[4]的长度必须与向量[2]的长度相同，我必须承认我不理解它。在这种情况下，sapply不应该返回与给定向量namedf一样多的组件，因此不能返回两个以上的组？此外，我想知道运行时的复杂性是什么。您好@cdalitz，您能展示一下发生错误的测试数据吗？我想知道是否由于您使用的数据帧与此不兼容而导致某些问题solution@cdalitz该解决方案的思想是通过所有列中的条目对df进行分类，并选择具有多行的类别，即n-to-1映射，把这些都整理好groups@cdalitz我添加了另一个计算复杂度较低的版本，例如，可能是线性复杂度w.r.t.每组的行数。您可以检查。@cdalitz很抱歉，我在上一个解决方案中有一个小缺陷。现在已经修好了！你可以用igraph继续前进！我只是对在BaseR中等效地实现它非常感兴趣，所以我一遍又一遍地尝试使它正确：您可以共享代码，以便能够测试其他方法吗？谢谢！您是否意识到，这些方法返回的结果不同？您能否共享代码，以便能够测试其他方法？谢谢！您是否意识到，这些方法返回的结果不同？感谢您的测试！结果表明，唯一正确的结果来自IGRACH CC分解。这在本例中不可见，因为applynames。。。当两个类之间的名称重叠时失败，但m中的结果是正确的。这可以通过使名称唯一来解决，例如G=sprintfg%i，sample…，S=sprintfs%i，sample…@cdalitz，我认为method.C也会得到正确的结果。这已经用于整数，而不仅仅是字符。另外，m中的结果对于方法A中的整数似乎不正确。关于方法C，我已经实现了您的第一个较短版本。较长的版本确实会在属性$All中返回正确的结果。关于方法A，当使用整数且两组整数之间存在重叠时，这些重叠的整数是正确的，但IGRAPHE无法将其解释为相同的节点。然而，methodB确实不正确，但我无法修复它，因为我不理解此解决方案：-感谢您测试此解决方案！结果表明，唯一正确的结果来自IGRACH CC分解。这在本例中不可见，因为applynames。。。当两个类之间的名称重叠时失败，但m中的结果是正确的。这可以通过使名称唯一来解决，例如G=sprintfg%i，sample…，S=sprintfs%i，sample…@cdalitz，我认为method.C也会得到正确的结果。这已经用于整数，而不仅仅是字符。另外，m中的结果对于方法A中的整数似乎不正确。关于方法C，我已经实现了您的第一个较短版本。较长的版本确实会在属性$All中返回正确的结果。关于方法A，当使用整数且两组整数之间存在重叠时，这些重叠的整数是正确的，但IGRAPHE无法将其解释为相同的节点。然而，methodB确实不正确，但我无法修复它，因为我不理解这个解决方案：-@cdalitz添加了一个更新的比较，现在您可以看到不同作者最新方法的性能。只是为了好玩才做这个！感谢您不厌其烦地测试这个！显然，前两种方法具有二次运行时复杂性。您是否也验证了结果是否相同？@cdalitz欢迎！是的，igraph肯定会主宰整个演出。我对几个示例测试了我的代码，结果与method.A相同，但不确定它是否能通过压力测试。当数据集保持为整数时，您可以将非IGRAPHE答案的结果提高~10。因为问题是分组因子或整数，非IGRAPHE可以处理整数，所以我认为可以显示处理整数的时间。@GKi，非常感谢您的建议。添加了整数数据集的运行时。@cdalitz添加了更新的比较，现在您可以看到不同作者的最新方法的性能。只是为了好玩才做这个！感谢您不厌其烦地测试这个！显然，前两种方法具有二次运行时复杂性。您是否也验证了结果是否相同？@cdalitz欢迎！是的，igraph肯定会主宰整个演出。我对几个示例测试了我的代码，结果与method.A相同，但不确定它是否能通过压力测试。当数据集保持为整数时，您可以将非IGRAPHE答案的结果提高~10。因为问题是分组因子或整数，非IGRAPHE可以处理整数，所以我认为可以显示处理整数的时间。@GKi，非常感谢您的建议。添加了整数数据集的运行时。
n t.A t.B t.C
1 500 0.00 0.16 0.26
2 1000 0.02 0.31 0.53
3 1500 0.02 0.51 1.11
4 2000 0.03 0.90 1.47
5 2500 0.03 1.35 2.17
6 3000 0.04 2.08 3.14
7 3500 0.04 2.66 3.97
8 4000 0.07 3.38 4.92
9 4500 0.07 4.38 6.35
10 5000 0.06 5.41 7.58
11 5500 0.08 6.79 9.55
12 6000 0.08 7.81 10.91
13 6500 0.10 9.03 12.06
14 7000 0.09 10.06 14.20
15 7500 0.11 11.76 15.65
16 8000 0.13 13.41 17.84
17 8500 0.11 14.87 20.67
18 9000 0.13 16.88 23.52
19 9500 0.14 18.38 25.57
20 10000 0.14 22.81 30.05
n t.A t.B t.C
1 500 0.00 0.09 0.13
2 1000 0.01 0.15 0.23
3 1500 0.01 0.22 0.38
4 2000 0.03 0.31 0.50
5 2500 0.05 0.45 0.76
6 3000 0.07 0.51 0.77
7 3500 0.06 0.67 0.97
8 4000 0.07 0.85 1.20
9 4500 0.07 0.90 1.39
10 5000 0.09 1.23 1.55
11 5500 0.09 1.30 1.78
12 6000 0.09 1.51 1.94
13 6500 0.11 1.77 2.20
14 7000 0.13 2.18 2.55
15 7500 0.12 2.37 2.79
16 8000 0.13 2.56 2.96
17 8500 0.14 2.76 3.39
18 9000 0.15 3.03 3.54
19 9500 0.15 3.54 4.23
20 10000 0.16 3.76 4.32