Отбор проб из таблицы непредвиденных обстоятельств

Question

Мне удалось дописать код, приведенный ниже, при написании функции для выборки из таблицы непредвиденных обстоятельств - пропорциональной частотам в ячейках.

Он использует expand.grid, а затем table, чтобы вернуться к исходной таблице размеров. Это работает отлично, пока размер выборки достаточно велик, что некоторые категории не полностью отсутствуют. В противном случае команда table возвращает таблицу меньших размеров, чем оригинальная.

FunSample<- function(Full, n) { 
    Frame <- expand.grid(lapply(dim(Full), seq)) 
    table(Frame[sample(1:nrow(Frame), n, prob = Full, replace = TRUE), ]) 
} 
Full<-array(c(1,2,3,4), dim=c(2,2,2)) 
FunSample(Full, 100) # OK 
FunSample(Full, 1) # not OK, I want it to still have dim=c(2,2,2)! 

Мой мозг перестал работать, я знаю, что это должен быть небольшой настройки, чтобы получить его обратно на трек !?

Answer 1

перекрестный также мультиномиальная распределение, так что вы можете использовать rmultinom и сбросить измерение на выходе. Это должно привести к существенному повышению производительности и сокращению кода, который необходимо поддерживать.

> X <- rmultinom(1, 500, Full) 
> dim(X) <- dim(Full) 
> X 
, , 1 

    [,1] [,2] 
[1,] 18 92 
[2,] 45 92 

, , 2 

    [,1] [,2] 
[1,] 28 72 
[2,] 49 104 

> X2 <-rmultinom(1, 4, Full) 
> dim(X2) <- dim(Full) 
> X2 
, , 1 

    [,1] [,2] 
[1,] 0 1 
[2,] 0 0 

, , 2 

    [,1] [,2] 
[1,] 0 1 
[2,] 1 1 

Answer 2

Если вы не хотите table() «бросить» недостающие комбинации, необходимо заставить столбцы Frame быть факторами:

FunSample <- function(Full, n) { 
    Frame <- as.data.frame(lapply(expand.grid(lapply(dim(Full), seq)), factor)) 
    table(Frame[sample(1:nrow(Frame), n, prob = Full, replace = TRUE), ]) 
} 

> dim(FunSample(Full, 1)) 
[1] 2 2 2 
> dim(FunSample(Full, 100)) 
[1] 2 2 2 

Answer 3

Вы могли бы использовать tabulate вместо table; он работает на целочисленных векторах, как вы здесь. Вы также можете получить вывод в массив, используя array напрямую, так же, как при создании исходных данных.

FunSample<- function(Full, n) { 
    samp <- sample(1:length(Full), n, prob = Full, replace = TRUE) 
    array(tabulate(samp), dim=dim(Full)) 
}