0

私はしばらくの間、以下のコードを* applyファミリーの関数を使用するように変換するのに苦労していたので、StackOverflowコミュニティに少し助けを求めています。いくつかの背景として、これは3つのグループの傾向スコア法を分析するために私が開発している方法の一部です。そのため、グループの各ペア間の距離（傾向スコアの差）を表す3つの行列から始めます。つまり、行列d1はA x B、d2はB x C、d3はC x Aです。私がする必要があるのは、全体の距離を最小にし、キャリパーよりも小さいトリプレットを見つけることです。私は、自分がやろうとしていることを理解しながら、実行できる限り例を単純化しました。

いくつかのメモ：

  • 考えられるすべての組み合わせのdata.frame（またはマトリックス）を単純に作成した場合、最後にキャリパーチェック（）よりも短い距離row1 <- row1[row1 < caliper]を実行できます。ただし、ここで設定したグループの数が少ない場合でも、3,000行になります。

  • 次のステップに進む前に、ベクトルを注文します。繰り返しますが、考えられるすべての組み合わせのマトリックスがあれば、これを排除できます。私の現在のバージョンでは、実行時間を短縮するためにn個の最小要素のみを調べる別の行があります。

  • この例にはかなり小さなグループがあります。私は、グループがそれぞれ5,000〜8,000のサブジェクトを持つデータセットに取り組んでいます。

助けてくれてありがとう。私はこのための論文に取り組んでおり、謝辞を述べたいと思います。また、useRに参加する予定です！スペインでの会議で、助けてくれる人のためにビールを購入します:-)

groups <- c('Control','Treat1','Treat2')
group.sizes <- c(15, 10, 20)
set.seed(2112)

d1 <- matrix(abs(rnorm(group.sizes[1] * group.sizes[2], mean=0, sd=1)), 
             nrow=group.sizes[1], ncol=group.sizes[2],
             dimnames=list(1:group.sizes[1], 
                          (group.sizes[1]+1):(group.sizes[1] + group.sizes[2])) )
d2 <- matrix(abs(rnorm(group.sizes[2] * group.sizes[3], mean=0, sd=1)), 
             nrow=group.sizes[2], ncol=group.sizes[3],
             dimnames=list((group.sizes[1]+1):(group.sizes[1] + group.sizes[2]), 
                          (group.sizes[2] + group.sizes[1] + 1):(sum(group.sizes)) ) )
d3 <- matrix(abs(rnorm(group.sizes[3] * group.sizes[1], mean=0, sd=1)), 
             nrow=group.sizes[3], ncol=group.sizes[1],
             dimnames=list((group.sizes[2] + group.sizes[1] + 1):(sum(group.sizes)), 
                          1:group.sizes[1]) )

caliper <- 1
results <- data.frame(v1=character(), v2=character(), v3=character(),
                      d1=numeric(), d2=numeric(), d3=numeric())
for(i1 in dimnames(d1)[[1]]) {
    row1 <- d1[i1,]
    row1 <- row1[row1 < caliper]
    row1 <- row1[order(row1)]
    for(i2 in names(row1)) {
        row2 <- d2[i2,]
        row2 <- row2[row2 < caliper]
        row2 <- row2[order(row2)]
        for(i3 in names(row2)) {
            val <- d3[i3,i1]
            if(val < caliper) {
                results <- rbind(results, 
                        data.frame(v1=i1, v2=i2, v3=i3,
                                d1=row1[i2], d2=row2[i3], d3=val))
            }
        }
    }
}
head(results)
4

1 に答える 1

0

さらに作業を行った後、ネストされた3つのforループをネストされたlapply関数呼び出しに置き換える方法を理解しました。2つのアプローチのテストを簡素化するために、以下に含まれている関数にそれらを移動しました。この最初のチャックは、3つのマトリックスを設定します。

group.sizes <- c(15, 10, 20)
set.seed(2112)

d1 <- matrix(abs(rnorm(group.sizes[1] * group.sizes[2], mean=0, sd=1)), 
             nrow=group.sizes[1], ncol=group.sizes[2],
             dimnames=list(1:group.sizes[1], 
                          (group.sizes[1]+1):(group.sizes[1] + group.sizes[2])) )
d2 <- matrix(abs(rnorm(group.sizes[2] * group.sizes[3], mean=0, sd=1)), 
             nrow=group.sizes[2], ncol=group.sizes[3],
             dimnames=list((group.sizes[1]+1):(group.sizes[1] + group.sizes[2]), 
                          (group.sizes[2] + group.sizes[1] + 1):(sum(group.sizes)) ) )
d3 <- matrix(abs(rnorm(group.sizes[3] * group.sizes[1], mean=0, sd=1)), 
             nrow=group.sizes[3], ncol=group.sizes[1],
             dimnames=list((group.sizes[2] + group.sizes[1] + 1):(sum(group.sizes)), 
                          1:group.sizes[1]) )

今、時間のある結果

> system.time(results.forloops <- forloops(d1, d2, d3))
   user  system elapsed 
  2.129   0.370   2.530 
> system.time(results.apply <- nestedapply(d1, d2, d3))
   user  system elapsed 
  0.019   0.000   0.019

当然のことlapplyながら、この小さな例でも、この方法は大幅に高速です。警告、上記の係数を変更することで、より大きな行列でこれを試すことができますがgroup.sizes、サイズを少しでもジャンプさせると、ネストされたループが完了するまでに非常に長い時間がかかります。

関数は次のとおりです。

forloops <- function(d1, d2, d3, caliper=1) {
    results <- data.frame(v1=character(), v2=character(), v3=character(),
                          d1=numeric(), d2=numeric(), d3=numeric())
    for(i1 in dimnames(d1)[[1]]) {
        row1 <- d1[i1,]
        row1 <- row1[row1 < caliper]
        #row1 <- row1[order(row1)]
        for(i2 in names(row1)) {
            row2 <- d2[i2,]
            row2 <- row2[row2 < caliper]
            #row2 <- row2[order(row2)]
            for(i3 in names(row2)) {
                val <- d3[i3,i1]
                if(val < caliper) {
                    results <- rbind(results, 
                                     data.frame(v1=i1, v2=i2, v3=i3,
                                               d1=row1[i2], d2=row2[i3], d3=val))
                }
            }
        }
    }
    results$total <- results$d1 + results$d2 + results$d3
    results <- results[order(results$total),]
    results <- results[!duplicated(results[,c('v1','v2')]), ]
    invisible(results)
}

nestedapply <- function(d1, d2, d3, caliper=1) {

    d1[d1 > caliper] <- NA
    d2[d2 > caliper] <- NA
    d3[d3 > caliper] <- NA

    results <- lapply(dimnames(d1)[[1]], FUN=function(i1) {
        row1 <- d1[i1,]
        row1 <- row1[!is.na(row1)]
        lapply(names(row1), FUN=function(i2) {
            row2 <- d2[i2,]
            row2 <- row2[!is.na(row2)]
            lapply(names(row2), FUN=function(i3) {
                val <- d3[i3,i1]
                if(is.na(val)) {
                    return(c())
                } else {
                    c(i1, i2, i3, row1[i2], row2[i3], val)
                }
            })
        })
    })
    results <- as.data.frame(matrix(unlist(results), ncol=6, byrow=TRUE), stringsAsFactors=FALSE)
    names(results) <- c('v1','v2','v3','d1','d2','d3')
    results$d1 <- as.numeric(results$d1)
    results$d2 <- as.numeric(results$d2)
    results$d3 <- as.numeric(results$d3)
    results$total <- results$d1 + results$d2 + results$d3
    invisible(results)
}
于 2013-02-11T01:14:14.263 に答える