使用非重复元素生成向量的多个排列

Question

我有一个矢量:

seq1<-c('a','b','c','b','a','b','c','b','a','b','c')

我希望置换此向量的元素以创建多个(理想情况下多达5000个)向量,条件是置换向量不能在连续元素中的向量内具有重复元素.例如,"abbca ...."是不允许的,因为'bb'是重复.

我意识到,对于这个小例子,可能没有5000个解决方案.我通常处理更大的向量.我也愿意考虑更换样品,但目前我正在研究无需更换的解决方案.

我正在寻找比我目前的想法更好的解决方案.

选项1. - 蛮力.

在这里,我只是重复采样并检查是否有任何连续的元素是重复的.

set.seed(18)
seq1b <-  sample(seq1a)
seq1b
#[1] "b" "b" "a" "a" "c" "b" "b" "c" "a" "c" "b"
sum(seq1b[-length(seq1b)]==seq1b[-1])  #3

这不是解决方案,因为有3个重复的连续元素.我也意识到这lag可能是检查重复元素的更好方法,但由于某种原因它很挑剔(我认为它被我加载的另一个包掩盖了).

set.seed(1000)
res<-NULL
for (i in 1:10000){res[[i]]<-sample(seq1a)}
res1 <- lapply(res, function(x) sum(x[-length(x)]==x[-1]))
sum(unlist(res1)==0) #228

这在10000次迭代中产生228个选项.但是,让我们看看有多少独特的:

res2 <- res[which(unlist(res1)==0)]
unique(unlist(lapply(res2, paste0, collapse="")))  #134

在10000次尝试中,我们只从这个简短的示例向量中获得134个唯一的.

以下是134个生成的示例序列中的3个:

# "bcbabcbabca" "cbabababcbc" "bcbcababacb"

事实上,如果我尝试超过500,000个样本,我只能得到212个符合我的非重复标准的独特序列.这可能接近可能的上限.

选项2. - 迭代

我的第二个想法是对方法更加迭代.

seq1a
table(seq1a)
#a b c 
#3 5 3

我们可以将其中一个字母作为起点.然后从剩下的那些中取样另一个,检查它是否与先前选择的相同,如果没有,则将其添加到最后.等等等等...

set.seed(10)
newseq <- sample(seq1a,1)  #b
newseq #[1] "b"

remaining <-seq1a[!seq1a %in% newseq | duplicated(seq1a)]
table(remaining)
#a b c 
#3 4 3 

set.seed(10)
newone <- sample(remaining,1) #c

#check if newone is same as previous one.
newone==newseq[length(newseq)] #FALSE
newseq <- c(newseq, newone) #update newseq
newseq #[1] "b" "c"

remaining <-seq1a[!seq1a %in% newseq | duplicated(seq1a)] #update remaining
remaining
table(remaining)

#a b c 
#3 4 2 

这可能有用,但我也可以看到它遇到很多问题 - 例如我们可以去:

# "a" "c" "a" "c" "a" "b"  ...

然后留下3个'b',它们不能在最后,因为它们是重复的.

当然,如果我允许更换采样,这将会容易得多,但是现在我试图在没有替换的情况下这样做.

Answer 1

您可以使用该iterpc包来处理组合和迭代.在尝试回答这个问题之前我没有听说过,所以可能还有更有效的方法来使用相同的包.

在这里,我习惯于iterpc设置一个迭代器,并getall根据迭代器查找向量的所有组合.这似乎只是报告了独特的组合,使它比找到所有组合更好expand.grid.

#install.packages("iterpc")
require("iterpc")

seq1 <- c('a','b','c','b','a','b','c','b','a','b','c')

I <- iterpc(n = table(seq1), ordered=TRUE)

all_seqs <- getall(I)

# result is a matrix with permutations as rows:
head(all_seqs)
#     [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]
#[1,] "a"  "a"  "a"  "b"  "b"  "b"  "b"  "b"  "c"  "c"   "c"  
#[2,] "a"  "a"  "a"  "b"  "b"  "b"  "b"  "c"  "b"  "c"   "c"  
#[3,] "a"  "a"  "a"  "b"  "b"  "b"  "b"  "c"  "c"  "b"   "c"  
#[4,] "a"  "a"  "a"  "b"  "b"  "b"  "b"  "c"  "c"  "c"   "b"  
#[5,] "a"  "a"  "a"  "b"  "b"  "b"  "c"  "b"  "b"  "c"   "c"  
#[6,] "a"  "a"  "a"  "b"  "b"  "b"  "c"  "b"  "c"  "b"   "c" 

该rle函数告诉我们关于向量中彼此相等的连续值.lengths输出的组件告诉我们values重复每个元素的次数:

rle(c("a", "a", "b", "b", "b", "c", "b"))

# Run Length Encoding
#   lengths: int [1:3] 2 3 1 1
#   values : chr [1:3] "a" "b" "c" "b"

仅对于没有连续重复的组合,长度values或lengths将等于原始向量的长度.

因此,您可以应用于rle每一行,计算长度values或lengths保持行all_seqs的计算值与长度相同seqs1.

#apply the rle function 
all_seqs_rle <- apply(getall(I), 1, function(x) length(rle(x)$values))

# keep rows which have an rle with a length equal to length(seq1)
all_seqs_good <- all_seqs[which(all_seqs_rle == length(seq1)), ]

all_seqs_good有一个nrow212,表明你确实找到了你的示例向量的所有可能的组合.

nrow(all_seqs_good)
# 212 

从技术上讲,这仍然是强制性的(除了它不计算每个可能的组合 - 只有唯一的组合),但对你的例子来说相当快.我不确定它将如何处理更大的载体呢......

编辑:对于较大的向量,这似乎失败了.一种解决方案是将较大的向量分解为较小的块,然后如上所述处理这些块并将它们组合 - 仅保留符合您标准的组合.

例如,将长度为24的矢量分成两个长度为12的向量,然后组合结果可以为您提供200,000多种符合您的标准的组合,并且非常快(对我来说大约1分钟):

# function based on the above solution
seq_check <- function(mySeq){
I = iterpc(n = table(mySeq), ordered=TRUE)
all_seqs <- getall(I)
all_seqs_rle <- apply(getall(I), 1, function(x) length(rle(x)$values))
all_seqs_good <- all_seqs[which(all_seqs_rle == length(mySeq)), ]
return(all_seqs_good)
}

set.seed(1)
seq1<-sample(c(rep("a", 8), rep("b", 8), rep("c", 8)),24)

seq1a <- seq1[1:12]
seq1b <- seq1[13:24]

#get all permutations with no consecutive repeats
seq1a = apply(seq_check(seq1a), 1, paste0, collapse="")
seq1b = apply(seq_check(seq1b), 1, paste0, collapse="")

#combine seq1a and seq1b: 
combined_seqs <- expand.grid(seq1a, seq1b)
combined_seqs <- apply(combined_seqs, 1, paste0, collapse="") 

#function to calculate rle lengths
rle_calc <- function(x) length(rle(unlist(strsplit(x, "")))$values)

#keep combined sequences which have rle lengths of 24
combined_seqs_rle <- sapply(combined_seqs, rle_calc)
passed_combinations <- combined_seqs[which(combined_seqs_rle == 24)]

#find number of solutions
length(passed_combinations)
#[1] 245832
length(unique(passed_combinations))
#[1] 245832

您可能需要重新排序起始矢量以获得最佳结果.例如,如果seq1在上面的例子中连续八次以"a"开头,则没有通过的解决方案.例如,尝试拆分解决方案seq1 <- c(rep("a", 8), rep("b", 8), rep("c", 8))并且您没有得到任何解决方案,即使随机序列的解决方案数量确实相同.

它看起来不像你需要找到每个可能的传递组合,但是如果你那么对于较大的向量你可能需要迭代I使用getnext函数from iterpc,并在循环中检查每个非常慢.