[英]Is there a way to target an overall sample size when using stratified sampling in R?
[英]Efficient multinomial sampling when sample size and probability vary
該問題涉及具有不同樣本大小和概率的多項分布的有效采樣。 下面我描述了我使用的方法,但想知道它是否可以通過一些智能矢量化來改進。
我正在模擬多個群體中的生物傳播。 來自人口j
個體以概率p[i, j]
分散到種群i
。 鑒於種群1的初始豐度為10,分別為種群1,2和3的擴散c(0.1, 0.3, 0.6)
概率,我們可以用rmultinom
模擬分散過程:
set.seed(1)
rmultinom(1, 10, c(0.1, 0.3, 0.6))
# [,1]
# [1,] 0
# [2,] 3
# [3,] 7
我們可以擴展這個來考慮n
源群:
set.seed(1)
n <- 3
p <- replicate(n, diff(c(0, sort(runif(n-1)), 1)))
X <- sample(100, n)
上面, p
是從一個群體(列)移動到另一個群體(行)的概率矩陣, X
是初始種群大小的向量。 現在可以模擬分散在每對種群(以及它們所在的種群)之間的個體數量:
sapply(seq_len(ncol(p)), function(i) {
rmultinom(1, X[i], p[, i])
})
# [,1] [,2] [,3]
# [1,] 19 42 11
# [2,] 8 18 43
# [3,] 68 6 8
其中第i
行和第j
列的元素值是從群體j
移動到群體i
的個體數量。 此矩陣的rowSums
給出了新的種群大小。
我想用常數概率矩陣重復這一次,但具有不同的(預定義的)初始豐度。 以下小例子實現了這一點,但是對於更大的問題效率低下。 得到的基質在5個模擬中的每一個中給出三個群體中的每一個的后擴散豐度,其中群體具有不同的初始豐度。
X <- matrix(sample(100, n*5, replace=TRUE), nrow=n)
apply(sapply(apply(X, 2, function(x) {
lapply(seq_len(ncol(p)), function(i) {
rmultinom(1, x[i], p[, i])
})
}), function(x) do.call(cbind, x), simplify='array'), 3, rowSums)
# [,1] [,2] [,3] [,4] [,5]
# [1,] 79 67 45 28 74
# [2,] 92 99 40 19 52
# [3,] 51 45 16 21 35
有沒有辦法更好地矢量化這個問題?
這是多多項式的RcppGSL實現。 但是,它需要您獨立安裝gsl ....這可能不太實用。
// [[Rcpp::depends(RcppGSL)]]
#include <RcppGSL.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <unistd.h> // getpid
Rcpp::IntegerVector rmn(unsigned int N, Rcpp::NumericVector p, gsl_rng* r){
size_t K = p.size();
Rcpp::IntegerVector x(K);
gsl_ran_multinomial(r, K, N, p.begin(), (unsigned int *) x.begin());
return x; // return results vector
}
Rcpp::IntegerVector gsl_mmm_1(Rcpp::IntegerVector N, Rcpp::NumericMatrix P, gsl_rng* r){
size_t K = N.size();
int i;
Rcpp::IntegerVector x(K);
for(i=0; i<K; i++){
x += rmn(N[i], P(Rcpp::_, i), r);
}
return x;
}
// [[Rcpp::export]]
Rcpp::IntegerMatrix gsl_mmm(Rcpp::IntegerMatrix X_, Rcpp::NumericMatrix P){
int j;
gsl_rng * r = gsl_rng_alloc (gsl_rng_mt19937);
long seed = rand()/(((double)RAND_MAX + 1)/10000000) * getpid();
gsl_rng_set (r, seed);
Rcpp::IntegerMatrix X(X_.nrow(), X_.ncol());
for(j=0; j<X.ncol(); j++){
X(Rcpp::_, j) = gsl_mmm_1(X_(Rcpp::_,j), P, r);
}
gsl_rng_free (r);
return X;
}
我還將它與純R實現和jbaums的版本進行比較
library(Rcpp)
library(microbenchmark)
sourceCpp("gsl.cpp")
P = matrix(c(c(0.1,0.2,0.7),c(0.3,0.3,0.4),c(0.5,0.3,0.2)),nc=3)
X = matrix(c(c(30,40,30),c(20,40,40)), nc=2)
mmm = function(X, P){
n = ncol(X)
p = nrow(X)
Reduce("+", lapply(1:p, function(j) {
Y = matrix(0,p,n)
for(i in 1:n) Y[,i] = rmultinom(1, X[j,i], P[,j])
Y
}))
}
jbaums = function(X,P){
apply(sapply(apply(X, 2, function(x) {
lapply(seq_len(ncol(P)), function(i) {
rmultinom(1, x[i], P[, i])
})
}), function(x) do.call(cbind, x), simplify='array'), nrow(X), rowSums)
}
microbenchmark(jbaums(X,P), mmm(X,P), gsl_mmm(X, P))
這就是結果
> microbenchmark(jbaums(X,P), mmm(X,P), gsl_mmm(X, P))
Unit: microseconds
expr min lq median uq max neval
jbaums(X, P) 165.832 172.8420 179.185 187.2810 339.280 100
mmm(X, P) 60.071 63.5955 67.437 71.5775 92.963 100
gsl_mmm(X, P) 10.529 11.8800 13.671 14.6220 40.857 100
gsl版本比純R版本快6倍。
例如:
# make the example in Rcpp you mention:
library(Rcpp)
library(inline)
src <- 'Environment stats("package:stats");
Function rmultinom = stats["rmultinom"];
NumericVector some_p(1000, 1.0/1000);
return(rmultinom(1,1, some_p));'
fx <- rcpp(signature(), body=src)
# now compare the two
library(rbenchmark)
benchmark(fx(),rmultinom(1,1,c(1000,1/1000)),replications=10000)
# test replications elapsed relative user.self sys.self user.child sys.child
# 1 fx() 10000 1.126 13.901 1.128 0 0 0
# 2 rmultinom(1, 1, c(1/1000)) 10000 0.081 1.000 0.080 0 0 0
我發現, BH
包帶來boost
庫表。 這將啟用以下內容,它產生與@ RandyLai的gsl_mmm
相同的輸出以及上面問題中的代碼。 (我相信啟用c ++ 11支持應該在沒有BH
情況下random
可用。)
// [[Rcpp::depends(BH)]]
#include <Rcpp.h>
#include <boost/random.hpp>
#include <boost/random/mersenne_twister.hpp>
#include <boost/random/discrete_distribution.hpp>
using namespace Rcpp;
typedef boost::mt19937 RNGType;
RNGType rng(123);
NumericVector rowSumsC(IntegerMatrix x) {
int nrow = x.nrow(), ncol = x.ncol();
IntegerVector out(nrow);
for (int i = 0; i < nrow; i++) {
double total = 0;
for (int j = 0; j < ncol; j++) {
total += x(i, j);
}
out[i] = total;
}
return wrap(out);
}
// [[Rcpp::export]]
IntegerMatrix rmm(IntegerMatrix X, NumericMatrix P) {
int niter = X.ncol(), nx = X.nrow();
IntegerMatrix out(nx, niter);
for (int j = 0; j < niter; j++) {
IntegerMatrix tmp(nx, nx);
for (int i = 0; i < nx; i++) {
for (int n = 0; n < X(i, j); n++) {
boost::random::discrete_distribution<> dist(P(_, i));
tmp(dist(rng), i)++;
}
}
out(_, j) = rowSumsC(tmp);
}
return out;
}
rowSumsC
由rowSumsC
提供, 在這里 。
但是,在我的機器上,這比Randy的gsl_mmm
慢得多,而且當有很多試驗時,確實比我的R版慢。 我懷疑這是由於編碼效率低,但是boost的discrete_distribution
也單獨執行每個多項式試驗,而這個過程在使用gsl
時會出現矢量化。 我是c ++的新手,所以不確定這是否可以提高效率。
P <- matrix(c(c(0.1, 0.2, 0.7), c(0.3, 0.3, 0.4), c(0.5, 0.3, 0.2)), nc=3)
X <- matrix(c(c(30, 40, 30), c(20, 40, 40)), nc=2)
library(BH)
microbenchmark(jbaums(X, P), rmm(X, P))
# Unit: microseconds
# expr min lq median uq max neval
# jbaums(X, P) 124.988 129.5065 131.464 133.8735 348.763 100
# rmm(X, P) 59.031 60.0850 62.043 62.6450 117.459 100
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.