Генерация псевдослучайной двоичной последовательности, в которой одно и то же число не встречается более двух раз подряд
Я хочу иметь возможность генерировать (псевдо)случайную двоичную последовательность (например, последовательность R и L, например RLLRRLR), которая уравновешивается таким образом, что один и тот же элемент не встречается в последовательности более двух раз подряд, и если я Например, есть последовательность из 20, я получаю по 10 штук. Есть ли в R функция, которая может сделать что-то подобное?
Я сам пытался написать такую функцию. Вот попытка:
RL_seq <- function(n_L = 10, n_R = 10, max_consec = 2, initial_seq = NULL) {
while(n_L > 0 | n_R > 0){
side <- sample(c("R", "L"), 1)
if (side == "R" & n_R > 0 & length(grep("R", tail(initial_seq, max_consec))) != max_consec) {
initial_seq <- append(initial_seq, side)
n_R <- n_R - 1
} else if (side == "L" & n_L > 0 & length(grep("L", tail(initial_seq, max_consec))) != max_consec) {
initial_seq <- append(initial_seq, side)
n_L <- n_L - 1
}
}
print(initial_seq)
}
# The function does not stop with the following seed
set.seed(1)
RL_seq()
Однако зависит от случая, застрянет код или нет. Я также надеялся, что смогу изменить правила последовательности (например, допустив 3 последовательных R), но код имеет тенденцию ломаться, если я касаюсь аргументов. На этом этапе я был бы счастлив, если бы мог запустить его с аргументами по умолчанию и не допустить зависания.
Я искал вокруг, но не могу найти ответа.
Стронг согласен с Джоном здесь - с более длинной последовательностью вы могли бы применить конструктивный подход: начать со случайного выбора LRLRLR... или RLRLRL, а затем случайным образом выбрать равное количество L и R для удвоения.
Я бы подумал о генераторе цепи Маркова на дублетах/тройках (чтобы за RR, LL никогда не следовал третий повтор), но я не знаю, как обеспечить баланс.
Связанные бумага и последовательность.
Комментарий к вашей попытке: строка initial_seq <- append(initial_seq, side) — это антишаблон, называемый «выращивание объекта в цикле». С каждой итерацией вашего цикла whileinitial_seq становится длиннее, и это дорогостоящая операция, поскольку ей может не хватить места, где бы она ни хранилась на вашем диске, и ее придется скопировать в другое место, где будет достаточно места. Гораздо эффективнее «предварительно выделить» вектор, создав его уже с его окончательной длиной, а затем заполняя значения по ходу дела. Подробнее читайте в The R Inferno
Ответы 6
Здесь я сначала определяю сочетание элементов, затем несколько раз перемешиваю, пока не получится ничья без слишком большого количества последовательных выборов. Я уверен, что существует более эффективный в вычислительном отношении подход (например, когда мы не перезаписываем seq на каждой итерации), но этого может быть достаточно. Например, для max_consec = 2 требуется ~0,002 секунды или несколько секунд, чтобы найти розыгрыш без повторов (max_consec = 1), даже если для поиска потребуется более 100 тысяч розыгрышей.
Любой подход (вроде двух предложенных до сих пор), основанный на случайном отборе, будет плохо работать для больших последовательностей, поскольку его случайное возникновение в последовательности с небольшим количеством повторяющихся строк станет исчезающе маловероятным.
RL_seq <- function(n_L = 10, n_R = 10, max_consec = 2) {
# make a sequence that is all the Ls then all the Rs
seq = c(rep("L", n_L), rep("R", n_R))
consec = max_consec + 1 # we know the first attempt won't work
while(consec > max_consec) {
# overwrite the sequence with a shuffle of it
seq = sample(seq, length(seq), replace = FALSE)
# what is the maximum "run length encoding" (rle) length of the sequence?
consec = max(rle(seq)[1]$lengths)
}
seq
}
RL_seq()
Ну, в частном случае max_consec = 1 вы будете более эффективны в вычислениях с if (runif (1) < .5) rep(c("L", "R"), n_L) else rep(c("R", "L"), n_L) ;)
Отличный момент, возможно, стоит добавить, если этот случай необходим для большей эффективности. Мне интересно, какие подходы будут иметь смысл, когда n_L/n_R станут больше, например, 40, 50 или даже 1000, так что простое случайное рисование вряд ли найдет рабочую последовательность при первом, скажем, миллионе или миллиарде розыгрышей.
При таком подходе мы генерируем n_try последовательности-кандидаты с равным количеством единиц и нулей (при желании вы можете изменить их на R и L в конце). Затем мы отфильтровываем любые последовательности, которые не удовлетворяют условию максимального последовательного значения.
С помощью этого начального числа генерация 100 последовательностей-кандидатов длиной 10 дает 13 подходящих результатов. (Считайте каждый столбец результата последовательностью.)
set.seed(47)
n_try = 1e2
out_length = 10
n_l = out_length / 2
n_r = out_length / 2
max_in_a_row = 2
letter_space = c(rep(1, n_l), rep(0, n_r))
r = replicate(n_try, sample(letter_space, size = out_length, replace = FALSE))
r = r[, apply(r, MARGIN = 2, FUN = \(x) sum(diff(x) == 0) <= max_in_a_row)]
r
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13]
# [1,] 1 0 0 0 0 1 0 0 0 1 0 0 0
# [2,] 0 1 1 1 1 1 1 1 1 0 1 1 1
# [3,] 0 0 1 0 0 0 0 0 0 1 0 1 0
# [4,] 1 0 0 0 1 1 1 1 1 0 0 0 0
# [5,] 0 1 1 1 0 0 0 0 1 0 1 1 1
# [6,] 1 1 0 1 1 0 1 1 0 1 0 0 1
# [7,] 0 0 0 0 0 1 1 0 1 0 1 1 0
# [8,] 1 1 1 1 1 0 0 1 0 1 0 0 1
# [9,] 0 0 0 0 1 1 1 1 1 1 1 0 0
# [10,] 1 1 1 1 0 0 0 0 0 0 1 1 1
Для результата в 20 длин я поднял n_try до 1e5, в результате чего получилось 108 квалификационных последовательностей менее чем за секунду.
ОП/Саймон отметил, что мой подход был быстрым, но чрезмерно ограничительным; с принудительными проверками, неблагоприятно ограничивающими диапазон возможностей в начале строк; В одном из комментариев Грегора упоминалась идея сделать половину, а затем удвоить; поэтому мой окончательный подход использует именно такую идею; принудительная ребалансировка произойдет только во второй половине строящейся колонны. У меня было предупреждение на случай сбоя; Я оставляю старое решение под новым:
library(tidyverse)
RL_v2 <- function(desired_length, max_consec = 2) {
stopifnot(desired_length %% 2==0)
half_length <- desired_length / 2
possible_tokens <- c("R", "L")
# later will use the following tokens when building an explain list
# explain_tokens <- c("1","2","O","F")
# 1 - we had to add 1/R to balance
# 2 - we had to add 2/L to balance
# we had to choose opposite to previous to not make too long consecutive
# we had a free choice
rlseq <- character(0)
explain_seq <- character(0)
while (length(rlseq) < desired_length) {
current_tail <- tail(rlseq, max_consec)
suppressWarnings(max_tail <- max(rle(current_tail)[1L]$lengths))
if (max_tail < max_consec) {
# we are free to choose either R or L ;
# must we choose one or the other to maintain 'parity'?
sumdiff <- (sum(rlseq==possible_tokens[[1]])-
sum(rlseq==possible_tokens[[2]]))
if (sumdiff<0 & length(rlseq)>=half_length){
# more 2 than 1 so must add 1
rlseq <- c(rlseq, possible_tokens[[1]])
explain_seq <- c(explain_seq,"1")
} else if (
sumdiff>0 & length(rlseq)>=half_length
){
# more 1 than 2 so must add 2
rlseq <- c(rlseq, possible_tokens[[2]])
explain_seq <- c(explain_seq,"2")
} else {
# a blessed free choice
rlseq <- c(rlseq, sample(possible_tokens, size = 1L))
explain_seq <- c(explain_seq,"F")
}
} else {
# forced opposite
rlseq <- c(rlseq, setdiff(possible_tokens,tail(rlseq,1L)))
explain_seq <- c(explain_seq,"O")
}
}
sumdiff <- (sum(rlseq==possible_tokens[[1]])-
sum(rlseq==possible_tokens[[2]]))
if (sumdiff!=0){
warning(paste0("Wasnt able to balance\t:",sumdiff))
}
list(seq=rlseq,
explain=explain_seq)
}
#is RRLRR inside 20 length sequences ?
sapply(1:200,\(x){
(res <- RL_v2(20,max_consec = 2))
str_detect(paste0(res$seq,collapse = ""),
pattern = fixed("RRLRR"))
}) |> table()
# FALSE TRUE
# 104 96
# about half the time
#are we beginning with RRLL?
sapply(1:200,\(x){
(res <- RL_v2(20,max_consec = 2))
str_detect(paste0(res$seq,collapse = ""),
pattern = "^RRLL")
}) |> table()
# about 10%
ОТРЕДАКТИРОВАНО: Мой метод работает конструктивно, проверяя хвост того, что было выбрано, и если у нас есть свобода, мы используем его, а если нет, мы принимаем принудительный выбор, он должен работать в линейном времени, что делает его масштабируемым. расширен, чтобы проверить, не является ли струна несбалансированной, и выполнить ее балансировку по ходу дела. возврат представляет собой список результатов и пояснение, показывающее, когда в соответствии с правилами был сделан свободный выбор, а не принудительный выбор.
RLx <- function(desired_length, max_consec = 2) {
possible_tokens <- c("R", "L")
# later will use the following tokens when building an explain list
# explain_tokens <- c("1","2","O","F")
# 1 - we had to add 1/R to balance
# 2 - we had to add 2/L to balance
# we had to choose opposite to previous to not make too long consecutive
# we had a free choice
rlseq <- character(0)
explain_seq <- character(0)
while (length(rlseq) < desired_length) {
current_tail <- tail(rlseq, max_consec)
suppressWarnings(max_tail <- max(rle(current_tail)[1L]$lengths))
if (max_tail < max_consec) {
# we are free to choose either R or L ;
# must we choose one or the other to maintain 'parity'?
sumdiff <- (sum(rlseq==possible_tokens[[1]])-
sum(rlseq==possible_tokens[[2]]))
if (sumdiff<0){
# more 2 than 1 so must add 1
rlseq <- c(rlseq, possible_tokens[[1]])
explain_seq <- c(explain_seq,"1")
} else if (
sumdiff>0
){
# more 1 than 2 so must add 2
rlseq <- c(rlseq, possible_tokens[[2]])
explain_seq <- c(explain_seq,"2")
} else {
# a blessed free choice
rlseq <- c(rlseq, sample(possible_tokens, size = 1L))
explain_seq <- c(explain_seq,"F")
}
} else {
# forced opposite
rlseq <- c(rlseq, setdiff(possible_tokens,tail(rlseq,1L)))
explain_seq <- c(explain_seq,"O")
}
}
list(seq=rlseq,
explain=explain_seq)
}
(res <- RLx(300,max_consec = 2))
Кажется, это проверяет только последовательное ограничение, но я думаю, что оно игнорирует ограничение, заключающееся в том, что в конечной последовательности имеется равное количество L и R?
Спасибо за этот комментарий; Я отредактирую, чтобы включить это ограничение
Мне нравится этот подход, но мне кажется, что он слишком агрессивно меняет баланс. Например, последовательность никогда не может начинаться или заканчиваться RR или LL. Вы также не можете получить такие последовательности, как RRLRR, в последовательности длиной 20, хотя на это нет никаких ограничений. Я попытался изменить это с помощью (length(rlseq) > (desired_length*0.9) & sumdiff < 0) | sumdiff < -1 вместо sumdiff<0 и наоборот для sumdiff>0, то есть строгое ограничение применяется только в конце. Это позволяет использовать начало и конец RR и LL, а также более свободный выбор, но не решает проблему RRLRR.
Надеюсь, это редактирование поможет
Идея
На самом деле вы можете искусственно создать «псевдо» процесс, используя rmultinom, скажем, x_1 + x_2 + ... + x_k = n для категорий L и R, но с ограничением на x_i, например, x_i <= l, где k определяет минимальное расстояние для двух последовательных L, разделенных R, например.
Как только набор {x_i} сохранится в результате ограниченной выборки, вы можете выполнить следующие два шага:
- сделайте
{x_i}и{y_i} := sample({x_i})для распределения последовательныхLиRсоответственно - Чередуйте
LиRвместе с соответствующими повторениями, чтобы построить последовательность, например,[rep('L',x_1), rep('R',y_1), rep('L',x_2), rep('R',y_2),..., rep('L',x_k), rep('R',y_k)]
Код
f <- function(Ntot, l = 2) {
n <- Ntot / 2
k <- ceiling(n / l) + 1
repeat {
d <- c(rmultinom(1, n, rep(1, k)))
if (max(d) <= l && min(d) > 0) break
}
cnts <- c(rbind(d, sample(d)))
rep(rep(sample(c("L", "R")), length.out = length(cnts)), cnts)
}
Пример вывода
Для воспроизводимости вы можете установить set.seed(0) перед выполнением следующих тестов.
> (out <- f(60, 3))
[1] "L" "L" "L" "R" "R" "L" "L" "L" "R" "R" "R" "L" "L" "L" "R" "R" "R" "L" "L"
[20] "L" "R" "R" "R" "L" "L" "L" "R" "R" "R" "L" "L" "L" "R" "R" "R" "L" "L" "R"
[39] "R" "R" "L" "L" "R" "R" "L" "L" "L" "R" "R" "R" "L" "L" "R" "R" "L" "L" "L"
[58] "R" "R" "R"
> table(out)
out
L R
30 30
> max(rle(out)$lengths)
[1] 3
и
> (out2 <- f(82, 5))
[1] "R" "R" "R" "L" "L" "L" "L" "L" "R" "R" "R" "R" "L" "L" "L" "L" "R" "R" "R"
[20] "L" "L" "L" "L" "R" "R" "R" "L" "L" "L" "L" "L" "R" "R" "R" "R" "R" "L" "L"
[39] "L" "R" "R" "R" "R" "R" "L" "L" "L" "R" "R" "R" "R" "R" "L" "L" "L" "L" "R"
[58] "R" "R" "R" "L" "L" "L" "L" "L" "R" "R" "R" "R" "R" "L" "L" "L" "L" "L" "R"
[77] "R" "R" "R" "L" "L" "L"
> table(out2)
out2
L R
41 41
> max(rle(out2)$lengths)
[1] 5
Я бы использовал для этого подход MCMC. Определите распределение перестановок, которое имеет наибольшее значение для последовательностей, соответствующих вашему условию, и более низкие значения для каждого нарушения условия. Начните со случайной перестановки символов, затем запустите Метрополис-Гастингс или что-то подобное, где ходы представляют собой замену случайно выбранных пар. В конечном итоге большую часть времени он будет тратить на последовательности, которые вы считаете приемлемыми.
Полученные выборки не будут независимыми, но средние значения функций из них будут сходиться к среднему значению генеральной совокупности.
Или, если вас не слишком заботит распределение, просто запускайте его со случайной перестановкой, пока не получите одно значение, а затем начните все сначала. Эти последовательности будут независимыми, но могут не быть равномерно распределены по приемлемым перестановкам.
Вот код, который можно использовать для генерации 5 последовательностей:
RL_seq <- function(n_L = 10, n_R = 10, max_consec = 2, n = 1,
alpha = 0.1 ) {
# alpha is a tuning parameter. Smaller values make the chain
# move faster, but it will also move to sequences you don't
# want, so you might get slower output.
score <- function(seq) {
# Compute a penalty score for violating the rule
# An acceptable solution has score 0
lens <- rle(seq)$lengths
lens <- lens - max_consec
sum(lens[lens > 0])
}
X <- sample(c(rep("L", n_L), rep("R", n_R)))
Xscore <- score(X)
result <- matrix(NA, n, length(X))
count <- 0
while (count < n) {
Y <- X
# Randomly select a pair of entries that are different.
repeat {
i <- sample(length(X), 2)
if (Y[i[1]] != Y[i[2]])
break
}
# Swap them
temp <- Y[i[1]]
Y[i[1]] <- Y[i[2]]
Y[i[2]] <- temp
Yscore <- score(Y)
# Always accept the proposal if it is at least as good,
# and sometimes if it is worse, using the Metropolis ratio
if (Xscore >= Yscore || runif (1) < exp(alpha * (Xscore - Yscore))) {
X <- Y
Xscore <- Yscore
}
if (Xscore == 0) {
count <- count + 1
result[count,] <- X
}
}
result
}
set.seed(1)
RL_seq(10, 10, n = 5)
#> [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14]
#> [1,] "R" "L" "R" "R" "L" "R" "L" "L" "R" "R" "L" "L" "R" "L"
#> [2,] "R" "R" "L" "R" "L" "R" "L" "R" "L" "R" "L" "L" "R" "R"
#> [3,] "R" "R" "L" "L" "R" "L" "R" "R" "L" "R" "R" "L" "L" "R"
#> [4,] "R" "R" "L" "L" "R" "L" "R" "R" "L" "R" "R" "L" "L" "R"
#> [5,] "R" "R" "L" "L" "R" "R" "L" "R" "L" "R" "R" "L" "L" "R"
#> [,15] [,16] [,17] [,18] [,19] [,20]
#> [1,] "R" "R" "L" "L" "R" "L"
#> [2,] "L" "L" "R" "R" "L" "L"
#> [3,] "L" "R" "L" "L" "R" "L"
#> [4,] "L" "L" "R" "L" "R" "L"
#> [5,] "L" "L" "R" "L" "R" "L"
Created on 2024-03-13 with reprex v2.1.0
В данном случае все 5 последовательностей различны, но очень похожи.
Ниже представлена функция rbinvec2, которая эффективно осуществляет равномерную выборку с заменой из набора допустимых векторов длины m. Он способен генерировать 100 тысяч действительных выборок вектора длиной 101 менее чем за 1 секунду.
Когда у меня будет время, я планирую обновить ответ, включив в него вывод основного PMF.
Функция
library(RcppAlgos) # for `permuteGeneral`
library(Rfast) # for `colShuffle`
rbinvec2 <- function(n, m) {
# handle small `m` values with `RcppAlgos`
if (m == 1) {
return(sample(0:1, n, 1))
} else if (m == 2) {
return(matrix(c(0:1, 1:0), 2, 2)[sample(1:2, n, 1),])
} else if (m == 3) {
return(permuteGeneral(0:1, 3, TRUE, NULL, 2, 7)[sample(6, n, 1),])
}
odd <- m%%2 == 1
kk <- (m - sqrt(m^2%%8))/2 # maximum number of doubles
k <- 0:kk
mk <- m - k
mk1 <- (mk + 1)%/%2
mk <- mk%/%2
m1 <- m - 1
m2 <- m%/%2
# calculate the exact (log) PMF of `k`, including the special cases when `m`
# is odd
p <- cbind(lchoose(mk1, k%/%2) + lchoose(mk, (k + 1)%/%2), -Inf)
i <- seq(1, kk + 1, 2)
if (odd) { # special cases
p[-i, 1] <- p[-i, 1] + log(2)
p[i, 2] <- lchoose(mk1[i], -1:(kk%/%2 - 1)) + lchoose(mk[i], 1:(kk%/%2 + 1))
}
# sample the PMF
k <- array(c(rmultinom(1, n, exp(p - max(p[1,])))), dim(p))
# k[-i,] <- rowSums(k[-i,])
s <- rowSums(k)
b <- vector("list", kk + 1) # initialize the list of compositions
# special case: no doubles
if (s[1]) b[[1]] <- rep(1, m*s[1])
s[1] <- 0L
if (odd) { # odd `m`
for (i in which(s != 0L)) {
b[[i]] <- if (i%%2L) {
# even number of doubles
j1 <- (m - i)/2 # 1 partition length
j0 <- j1 + 1 # 0 partition length
i2 <- (i - 1)/2
d0 <- j0 - i2
d1 <- j1 - i2
c(
if (k[i, 1]) { # balanced doubles--1 more 0 than 1
rbind(
# 0 composition
c(colShuffle(matrix(rep.int(1:2, c(d0, i2)), j0, k[i, 1]))),
# 1 composition
c(rbind(
colShuffle(matrix(rep.int(1:2, c(d1, i2)), j1, k[i, 1])),
0L
))
)
} else integer(0)
,
if (k[i, 2]) { # unbalanced doubles--1 more 1 than 0
rbind(
# 0 composition
c(colShuffle(matrix(rep.int(1:2, c(d0 + 1, i2 - 1)), j0, k[i, 2]))),
# 1 composition
c(rbind(
colShuffle(matrix(rep.int(1:2, c(d1 - 1, i2 + 1)), j1, k[i, 2])),
0L
))
)
} else integer(0)
)
} else {
# odd number of doubles
i2 <- i/2 - 1 # min number of (0,0)
j <- m2 - i2 # even/odd composition lengths
idx <- sample(1:2, s[i], 1) # extra 0, or extra 1?
bb <- cbind(rep.int(1:2, c(j - i2, i2)), # extra 0
rep.int(1:2, c(j - i2 - 1, i2 + 1))) # extra 1
c(
rbind(
c(colShuffle(matrix(bb[,idx], j))), # 0 compositions
c(colShuffle(matrix(bb[,3 - idx], j))) # 1 compositions
)
)
}
}
} else { # even `m`
for (i in which(s != 0L)) {
i2 <- (i - 1)%/%2 # number of (0,0)
j <- m2 - i2 # 0 composition length
b[[i]] <- c(
if (i%%2L) {
# even number of doubles--equivalent partition for 0 and 1
matrix(
colShuffle(matrix(rep.int(1:2, c(j - i2, i2)), j, 2*s[i])),
2, j*s[i], 1
)
} else { # odd number of doubles--1 more double 1 than double 0
rbind(
# 0-composition
c(colShuffle(matrix(rep.int(1:2, c(j - i2, i2)), j, s[i]))),
# 1 composition
c(rbind(
colShuffle(
matrix(rep.int(1:2, c(j - i2 - 2, i2 + 1)), j - 1, s[i])
), 0L
))
)
}
)
}
}
abs(
matrix(
# convert the compositions to 0's and 1's
rep.int(rep(0:1, length.out = sum(lengths(b))), unlist(b)), n, m, 1
# shuffle the n samples and perform a full 0 <-> 1 swap in random vectors
)[sample(n),] - sample(0:1, n, 1)
)
}
Пример использования
rbinvec2(10, 8) # 10 samples of vector of length 8
#> [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
#> [1,] 0 1 0 1 0 1 0 1
#> [2,] 0 1 0 1 0 0 1 1
#> [3,] 0 1 0 0 1 0 1 1
#> [4,] 0 0 1 1 0 1 1 0
#> [5,] 0 0 1 0 1 0 1 1
#> [6,] 1 0 1 0 1 1 0 0
#> [7,] 1 0 1 0 1 0 0 1
#> [8,] 1 0 1 0 1 0 1 0
#> [9,] 1 0 1 0 1 0 1 0
#> [10,] 1 0 0 1 0 0 1 1
rbinvec2(10, 9)# 10 samples of vector of length 9
#> [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
#> [1,] 0 0 1 1 0 0 1 0 1
#> [2,] 0 1 1 0 1 1 0 0 1
#> [3,] 1 0 0 1 0 1 1 0 0
#> [4,] 1 0 0 1 0 1 0 1 0
#> [5,] 1 1 0 0 1 1 0 0 1
#> [6,] 1 1 0 1 0 0 1 0 0
#> [7,] 0 1 0 1 0 0 1 0 1
#> [8,] 1 0 1 0 0 1 0 0 1
#> [9,] 1 1 0 0 1 0 1 1 0
#> [10,] 0 0 1 0 0 1 1 0 1
Тайминг
system.time(rbinvec2(1e6, 10)) # 1M samples of vector of length 10
#> user system elapsed
#> 1.52 0.12 1.75
system.time(rbinvec2(1e5, 101)) # 100K samples of vector of length 101
#> user system elapsed
#> 0.69 0.09 0.82
Проверьте правильность поведения
library(data.table) # for checks
fcheck1 <- function(m) {
# returns the number of valid vectors of length `m`
# generate all balanced permutations
x <- if (m%%2) {
rbind(
permuteGeneral(0:1, m, TRUE, c((m + 1)%/%2, m%/%2)),
permuteGeneral(0:1, m, TRUE, c(m%/%2, (m + 1)%/%2))
)
} else {
permuteGeneral(0:1, m, TRUE, c(m%/%2, m%/%2))
}
# count the permutations with no more than two sequential repeated values
sum(!rowSums(x[,-1:-2] == x[,c(-1, -m)] & x[,c(-1, -m)] == x[,-m:(1 - m)]))
}
fcheck2 <- function(n, m) {
# return the unique samples along with their counts
setorder(as.data.table(rbinvec2(n, m))[,.(.N), eval(paste0("V", 1:m))])[]
}
fcheck1(6) # the number of valid vectors of length 6
#> [1] 14
fcheck2(1e6, 6)
#> V1 V2 V3 V4 V5 V6 N
#> <int> <int> <int> <int> <int> <int> <int>
#> 1: 0 0 1 0 1 1 71195
#> 2: 0 0 1 1 0 1 71249
#> 3: 0 1 0 0 1 1 71237
#> 4: 0 1 0 1 0 1 71588
#> 5: 0 1 0 1 1 0 71469
#> 6: 0 1 1 0 0 1 71482
#> 7: 0 1 1 0 1 0 71242
#> 8: 1 0 0 1 0 1 71368
#> 9: 1 0 0 1 1 0 71638
#> 10: 1 0 1 0 0 1 71606
#> 11: 1 0 1 0 1 0 71645
#> 12: 1 0 1 1 0 0 71867
#> 13: 1 1 0 0 1 0 71107
#> 14: 1 1 0 1 0 0 71307
fcheck1(7)
#> [1] 36 # the number of valid vectors of length 7
fcheck2(1e6, 7)
#> V1 V2 V3 V4 V5 V6 V7 N
#> <int> <int> <int> <int> <int> <int> <int> <int>
#> 1: 0 0 1 0 0 1 1 27612
#> 2: 0 0 1 0 1 0 1 27728
#> 3: 0 0 1 0 1 1 0 27451
#> 4: 0 0 1 1 0 0 1 27707
#> 5: 0 0 1 1 0 1 0 27689
#> 6: 0 0 1 1 0 1 1 27460
#> 7: 0 1 0 0 1 0 1 27891
#> 8: 0 1 0 0 1 1 0 27562
#> 9: 0 1 0 1 0 0 1 27805
#> 10: 0 1 0 1 0 1 0 27947
#> 11: 0 1 0 1 0 1 1 27761
#> 12: 0 1 0 1 1 0 0 27893
#> 13: 0 1 0 1 1 0 1 28044
#> 14: 0 1 1 0 0 1 0 27899
#> 15: 0 1 1 0 0 1 1 27756
#> 16: 0 1 1 0 1 0 0 27477
#> 17: 0 1 1 0 1 0 1 27769
#> 18: 0 1 1 0 1 1 0 27756
#> 19: 1 0 0 1 0 0 1 27955
#> 20: 1 0 0 1 0 1 0 27726
#> 21: 1 0 0 1 0 1 1 27931
#> 22: 1 0 0 1 1 0 0 27896
#> 23: 1 0 0 1 1 0 1 27652
#> 24: 1 0 1 0 0 1 0 27720
#> 25: 1 0 1 0 0 1 1 28005
#> 26: 1 0 1 0 1 0 0 28072
#> 27: 1 0 1 0 1 0 1 27802
#> 28: 1 0 1 0 1 1 0 27579
#> 29: 1 0 1 1 0 0 1 27593
#> 30: 1 0 1 1 0 1 0 27846
#> 31: 1 1 0 0 1 0 0 27745
#> 32: 1 1 0 0 1 0 1 27760
#> 33: 1 1 0 0 1 1 0 27840
#> 34: 1 1 0 1 0 0 1 27704
#> 35: 1 1 0 1 0 1 0 27884
#> 36: 1 1 0 1 1 0 0 28083
#> V1 V2 V3 V4 V5 V6 V7 N
Распределение каждого уникального вектора соответствует равномерной выборке полного набора допустимых векторов для обоих случаев.
Два ответа, которые мы отправили до сих пор, предполагают, что
n_Lиn_Rненамного больше 20 или 30, поскольку розыгрыши, соответствующие вашим критериямmax_consec, станут исчезающе маловероятными для более длинных последовательностей. Если вы хотите создавать более крупные последовательности, этот подход перестанет иметь смысл.