Question

我一直在努力将下面的代码转换为使用* apply系列函数，所以现在请求StackOverflow社区提供一些帮助。一些背景，这是我正在开发的分析三组倾向评分方法的方法的一部分。因此，我从三个矩阵开始，表示每对组之间的距离（倾向得分的差异）。也就是说，矩阵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)

Answer 1

经过一些工作，我已经想出如何用嵌套的lapply函数调用替换三个嵌套的for循环。为了简化这两种方法的测试，我将它们移到了下面包含的函数中。第一个夹头设置了三个矩阵：

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)
}

有没有一种更有效的方法来嵌套三个for循环？

1 个答案: