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

3

最初に、問題をグラフ理論の言語でもう一度述べさせてください。次のようにグラフを定義します。各サンプルは、それを表す頂点を生成します。2 つの頂点の間にエッジがあるのは、これらの頂点によって表されるサンプルを統計的に区別できないことが何らかのテストで示された場合のみです。グラフ理論では、クリークは頂点のセットであり、セット内の 2 つの頂点ごとにエッジがあります。グラフのすべてのエッジが (少なくとも? 正確に?) クリークの 1 つに属しているようなクリークのコレクションを探しています。できるだけ少数のクリークを使用したいと考えています。(この問題は、クリーク カバーではなく、クリーク エッジ カバーと呼ばれます。) 次に、各クリークに独自の文字を割り当て、そのメンバーにその文字でラベルを付けます。他のすべてのサンプルと区別できる各サンプルには、独自の文字も付けられます。

たとえば、サンプル入力に対応するグラフは次のように描画できます。

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

私の提案するアルゴリズムは次のとおりです。グラフを作成し、Bron--Kerbosch アルゴリズムを使用してすべての最大クリークを見つけます。上のグラフでは、{1, 3}、{1, 5}、および {4, 6} です。たとえば、セット {1} はクリークですが、クリーク {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 です: 再帰関数の入力から出力へのマップを維持して、作業を 2 回行うことを避けることができます。それがうまくいかない場合、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 に答える