2013-02-01 71 views
0

我一直在努力將下面的代碼轉換爲使用* apply系列函數,所以現在要求StackOverflow社區提供一些幫助。一些背景,這是我正在開發的分析三組傾向評分方法的方法的一部分。因此,我從三個矩陣開始,代表每對組之間的距離(傾向得分的差異)。也就是說,矩陣d1是A×B,d2是B×C,而d3是C×A.我需要做的是找到使整體距離最小並且小於某個卡尺的三元組。我儘可能簡化了這個例子,因爲我可以在我想要的時候運行。是否有更有效的方法來嵌套三個for循環?

夫婦的注意事項:

  • 的距離比卡尺檢查(row1 <- row1[row1 < caliper])不太可能在年底完成,如果我要簡單地創建所有可能組合的data.frame(或矩陣)。但是,即使我在這裏設置的組數很少,也會導致3000行!

  • 我在進入下一步之前命令向量。再次,如果我有一個所有可能的組合矩陣,這可以被消除。在我目前的版本中,我有另外一行只查看n個最小的元素以減少執行時間。

  • 這個例子有很小的組。我正在研究一個數據集,每個數據集有5,000到8,000個主題。

在此先感謝您的幫助。我正在爲此撰寫論文,並很樂意致謝。另外,我計劃參加使用R!會議在西班牙會買任何人喝啤酒有助於:-)

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) 
+1

買啤酒?這是不是被視爲StackOverflow上的賄賂形式? :) – juba

+0

顯然「df.sizes」向量缺失。 – juba

+0

對不起,固定的朱巴。 – jbryer

回答

0

後一些更多的工作,我已經找到了如何更換三嵌套與嵌套lapply函數調用的循環。爲了簡化測試這兩種方法,我將它們移到了下面包含的函數中。此第一卡盤設置的三個矩陣:

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