Rのダウンサンプル行列？

Question

私の質問は、行列の列からの置き換えを行わない関数のパフォーマンスを改善する方法です（行列の「希少化」とも呼ばれます...）。このhereの言及がありますが、私に必要なものを行うことを明確に答えます。 b）すぐにそれをする）。

downsampled <- function(data,samplerate=0.8) { 
    data.test <- apply(data,2,function(q) { 
    names(q) <- rownames(data) 
    samplepool <- character() 
    for (i in names(q)) { 
     samplepool <- append(samplepool,rep(i,times=q[i])) 
    } 
    sampled <- sample(samplepool,size=samplerate*length(samplepool),replace = F) 
    tab <- table(sampled) 
    mat <- match(names(tab),names(q)) 
    toret=numeric(length <- length(q)) 
    names(toret) <- names(q) 
    toret[mat] <- tab 
    return(toret) 
    }) 
return(data.test) 
} 

は、私は数百万のエントリを持つ行列をダウンサンプリングする必要があります

は、ここに私の関数です。私は（ここで私は一般的なデータサイズの約20-100x小さい1000×1000の行列を、使用しています）、これは非常に遅いです見つける：

mat <- matrix(sample(0:40,1000*1000,replace=T),ncol=1000,nrow=1000) 
colnames(mat) <- paste0("C",1:1000) 
rownames(mat) <- paste0("R",1:1000) 
system.time(matd <- downsampled(mat,0.8)) 

## user system elapsed 
## 69.322 21.791 92.512 

はIこの操作を実行するためのより迅速/簡単な方法があります考えていない？

Answer 1

節約の1つの源は、repを使用してサンプルプールを追加するforループを削除することです。ここでは再現性の例である：

myRows <- 1:5 
names(myRows) <- letters[1:5] 
# get the repeated values for sampling 
samplepool <- rep(names(myRows), myRows) 

あなたの関数の中で、これは私はあなたがこれが劇的に高速化させることができると思い

samplepool <- rep(names(q), q) 

Answer 2

だろう。あなたが正しくしようとしていることを理解しているなら、samplerate = 0.5とマトリックスのセルがmat[i,j] = 5なら、それぞれのサンプルが5つまでサンプリングされるように、マトリックスの各セルをダウンサンプリングする必要がありますサンプリングされる確率は0.5です。

あなたは、物事をスピードアップするためではなく、行列の各セルを通る行列の列にすべてのこれらの操作を行って、あなたができるだけのループ、mat[i,j] = 5場合、runif（例えばを使用して、そのセルからN物事を描きます0と1の間に5つの乱数を生成し、次に< samplerateという値の数を加算して）、最後に新しい行列に物の数を加えます。私はこれが同じダウンサンプリングスキームを効果的に達成すると思うが、（実行時間とコード行の両方で）はるかに効率的だ。

# Sample matrix 
set.seed(23) 
n <- 1000 
mat <- matrix(sample(0:10,n*n,replace=T),ncol=n,nrow=n) 
colnames(mat) <- paste0("C",1:n) 
rownames(mat) <- paste0("R",1:n) 

# Old function 
downsampled<-function(data,samplerate=0.8) { 
    data.test<-apply(data,2,function(q){ 
    names(q)<-rownames(data) 
    samplepool<-character() 
    for (i in names(q)) { 
     samplepool=append(samplepool,rep(i,times=q[i])) 
    } 
    sampled=sample(samplepool,size=samplerate*length(samplepool),replace = F) 
    tab=table(sampled) 
    mat=match(names(tab),names(q)) 
    toret=numeric(length = length(q)) 
    names(toret)<-names(q) 
    toret[mat]<-tab 
    return(toret) 
    }) 
return(data.test) 
} 

# New function 
downsampled2 <- function(mat, samplerate=0.8) { 
    new <- matrix(0, nrow(mat), ncol(mat)) 
    colnames(new) <- colnames(mat) 
    rownames(new) <- rownames(mat) 
    for (i in 1:nrow(mat)) { 
     for (j in 1:ncol(mat)) { 
      new[i,j] <- sum(runif(mat[i,j], 0, 1) < samplerate) 
     } 
    } 
    return(new) 
} 

# Compare times 
system.time(downsampled(mat,0.8)) 
## user system elapsed 
## 26.840 3.249 29.902 
system.time(downsampled2(mat,0.8)) 
## user system elapsed 
## 4.704 0.247 4.918 

例1000 x 1000の行列を使用すると、私が提供した新しい関数は約6倍高速に実行されます。