5

在为这个问题苦苦挣扎了一段时间后，我希望在这里得到一些建议。我想知道是否有人知道基于重要性确定成对分组标签的自动化方法。该问题与显着性检验无关（例如 Tukey 用于参数或 Mann-Whitney 用于非参数） - 考虑到这些成对比较，一些箱线图类型的图通常用下标表示这些分组：

在此处输入图像描述

我手工完成了这个例子，这可能很乏味。我认为算法中的标记顺序应该基于每个组中的级别数 - 例如，应该首先命名包含与所有其他级别显着不同的单个级别的组，然后是包含 2 个级别的组，然后是 3 个，等等，同时检查新分组是否添加了新的所需分组并且不违反和差异。

在下面的示例中，棘手的部分是让算法识别级别 1 应与 3 和 5 分组，但不应将 3 和 5 分组（即共享一个标签）。

示例代码：

set.seed(1)
n <- 7
n2 <- 100
mu <- cumsum(runif(n, min=-3, max=3))
sigma <- runif(n, min=1, max=3)

dat <- vector(mode="list", n)
for(i in seq(dat)){
    dat[[i]] <- rnorm(n2, mean=mu[i], sd=sigma[i])
}

df <- data.frame(group=as.factor(rep(seq(n), each=n2)), y=unlist(dat))

bp <- boxplot(y ~ group, df, notch=TRUE)
kr <- kruskal.test(y ~ group, df)
kr
mw <- pairwise.wilcox.test(df$y, df$g)
mw
mw$p.value > 0.05 # TRUE means that the levels are not significantly different at the p=0.05 level

#      1     2     3     4     5     6
#2 FALSE    NA    NA    NA    NA    NA
#3  TRUE FALSE    NA    NA    NA    NA
#4 FALSE FALSE FALSE    NA    NA    NA
#5  TRUE FALSE FALSE FALSE    NA    NA
#6 FALSE FALSE FALSE  TRUE FALSE    NA
#7 FALSE FALSE FALSE FALSE FALSE FALSE

text(x=1:n, y=bp$stats[4,], labels=c("AB", "C", "A", "D", "B", "D", "E"), col=1, cex=1.5, pos=3, font=2)
4

3 回答 3

8

很酷的代码。

我认为您需要在调用时引用函数 order() do.call：

reord<-do.call("order", data.frame(
do.call(rbind, 
    lapply(res, function(x) c(sort(x), rep.int(0, ml-length(x))))
)
))
于 2014-10-24T14:25:46.760 回答
3

首先让我用图论的语言重申这个问题。定义如下图。每个样本都会产生一个代表它的顶点。在两个顶点之间，当且仅当某些测试表明由这些顶点表示的样本无法在统计上区分时，才存在边。在图论中，团是一组顶点，使得集合中每两个顶点之间都有一条边。我们正在寻找一个派系的集合，使得图中的每条边都属于（至少？确切地说？）其中一个派系。我们希望尽可能少地使用派系。（这个问题称为团边缘覆盖，而不是团覆盖。）然后我们为每个团分配自己的字母并用该字母标记其成员。与所有其他样本区分开来的每个样本也都有自己的字母。

例如，与您的样本输入对应的图形可以这样绘制。

3---1---5       4--6

我提出的算法如下。构造图并使用Bron-Kerbosch 算法找到所有最大团。对于上图，它们是 {1, 3}、{1, 5} 和 {4, 6}。例如，集合 {1} 是一个 clique，但它不是最大的，因为它是 clique {1, 3} 的一个子集。集合 {1, 3, 5} 不是团，因为 3 和 5 之间没有边。在图中

  1
 / \
3---5       4--6,

最大派系将是 {1, 3, 5} 和 {4, 6}。

现在递归搜索小团边缘覆盖。我们的递归函数的输入是一组剩余要被覆盖的边和最大团的列表。找到剩余集合中的最小边，例如，边 (1,2) < (1,5) < (2,3) < (2,5) < (3,4)。对于包含该边的每个最大团，构造一个由该团和递归调用的输出组成的候选解决方案，其中从剩余边集中删除团边。输出最佳候选。

除非边缘很少，否则这可能太慢了。第一个性能改进是 memoize：维护递归函数的输入到输出的映射，这样我们就可以避免重复工作。如果这不起作用，那么 R 应该有一个到整数程序求解器的接口，我们可以使用整数编程来确定最佳派系集合。（如果其他方法不足，我将对此进行更多解释。）

于 2014-05-15T16:21:52.957 回答
1

我想我会发布我能够从以下问题中获得额外帮助的解决方案：

set.seed(1)
n <- 7
n2 <- 100
mu <- cumsum(runif(n, min=-3, max=3))
sigma <- runif(n, min=1, max=3)

dat <- vector(mode="list", n)
for(i in seq(dat)){
    dat[[i]] <- rnorm(n2, mean=mu[i], sd=sigma[i])
}
df <- data.frame(group=as.factor(rep(seq(n), each=n2)), y=unlist(dat))
bp <- boxplot(y ~ group, df, notch=TRUE)


#significance test
kr <- kruskal.test(y ~ group, df)
mw <- pairwise.wilcox.test(df$y, df$g)

#matrix showing connections between levels
g <- as.matrix(mw$p.value > 0.05)
g <- cbind(rbind(NA, g), NA)
g <- replace(g, is.na(g), FALSE)
g <- g + t(g)
diag(g) <- 1
rownames(g) <- 1:n
colnames(g) <- 1:n
g

#install.packages("igraph")
library(igraph)

# Load data
same <- which(g==1)
topology <- data.frame(N1=((same-1) %% n) + 1, N2=((same-1) %/% n) + 1)
topology <- topology[order(topology[[1]]),] # Get rid of loops and ensure right naming of vertices
g3 <- simplify(graph.data.frame(topology,directed = FALSE))
get.data.frame(g3)

# Plot graph
plot(g3)

# Calcuate the maximal cliques
res <- maximal.cliques(g3)

# Reorder given the smallest level
res <- sapply(res, sort)
res <- res[order(sapply(res,function(x)paste0(sort(x),collapse=".")))]

ml<-max(sapply(res, length))
reord<-do.call(order, data.frame(
    do.call(rbind, 
        lapply(res, function(x) c(sort(x), rep.int(0, ml-length(x))))
    )
))
res <- res[reord]

lab.txt <- vector(mode="list", n)
lab <- letters[seq(res)]
for(i in seq(res)){
    for(j in res[[i]]){
        lab.txt[[j]] <- paste0(lab.txt[[j]], lab[i])
    }
}

bp <- boxplot(y ~ group, df, notch=TRUE, outline=FALSE, ylim=range(df$y)+c(0,1))
text(x=1:n, y=bp$stats[5,], labels=lab.txt, col=1, cex=1, pos=3, font=2)

在此处输入图像描述

于 2014-05-19T04:29:05.517 回答