Question

我有一个矢量：

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

我希望置换此向量的元素以创建多个（理想情况下最多5000个）向量，条件是置换向量不能在连续元素中的向量内具有重复元素。例如＆＃34; abbca ....＆＃34;不允许作为＆＃39; b-b＆＃39;是重复。

我意识到，对于这个小例子，可能没有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的{{1}}为212，表明您确实找到了示例矢量的所有可能组合。

nrow

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

编辑：对于较大的向量，这似乎失败了。一种解决方案是将较大的向量分解为较小的块，然后按上述方法处理这些块并将它们组合 - 只保留符合条件的组合。

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

nrow(all_seqs_good)
# 212

您可能需要重新排序起始矢量以获得最佳效果。例如，如果上例中的# 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连续八次以“a”开头，那么就没有通过的解决方案。例如，尝试使用seq1拆分解决方案，即使后续序列的解决方案数量确实相同，也无法获得解决方案。

看起来你不需要找到所有可能的传递组合，但是如果你那么对于较大的向量，你可能需要使用seq1 <- c(rep("a", 8), rep("b", 8), rep("c", 8))函数来迭代I getnext 1}}，并在一个非常慢的循环中检查每一个。

Answer 2

这是另一种解决方案。有关算法的说明，请参阅代码中的注释。在某种程度上，它类似于您的第二种（迭代）方法，但它包括

确保下一个元素有效的Virtual Directory | Relative Path to Site Root /sub/aspxfolder | site\wwwroot\sub\aspxfolder /sub | site\wwwroot\sub循环
以及当剩余元素必然形成无效组合时的停止标准

在您的一条评论中给出的while向量越长，该算法也非常有效。但是，如果seq1中有更多独特元素，我猜它的性能会降低。

这里的代码：首先是几个定义

seq1

现在生成组合

set.seed(1234)
seq1=c('a','b','c','b','a','b','c','b','a','b','c')

#number of attempts to generate a valid combination
Nres=10000

#this list will hold the results
#we do not have to care about memory allocation
res_list=list()

现在让我们检查结果

#the outer loop creates the user-defined number of combination attempts
for (i in 1:Nres) {
  #create a "population" from seq1
  popul=seq1
  #pre-allocate an NA vector of the same length as seq1
  res_vec=rep(NA_character_,length(seq1))
  #take FIRST draw from the population
  new_draw=sample(popul,1)
  #remove draw from population
  popul=popul[-match(new_draw,popul)]
  #save new draw
  res_vec[1]=new_draw

  #now take remaining draws
  for (j in 2:length(seq1)) {
    #take new draws as long as
    #1) new_draw is equal to the last draw and
    #2) as long as there are any valid elements left in popul
    while((new_draw==res_vec[j-1])&any(res_vec[j-1]!=popul)) {
      #take new draw
      new_draw=sample(popul,1)
    }
    #if we did not find a valid draw break inner loop
    if (new_draw==res_vec[j-1]) {
      break
    }
    #otherwise save new_draw ...
    res_vec[j]=new_draw
    #... and delete new draw from population
    popul=popul[-match(new_draw,popul)]
  }
  #this is to check whether we had to break the inner loop
  #if not, save results vector
  if (sum(is.na(res_vec[j]))==0) res_list[[length(res_list)+1]]=res_vec
}

Answer 3

你实际工作的速度取决于很多因素（例如存在多少可能的传递组合），但我认为你可以通过使用2个循环相对快速地完成这个任务（类似于你概述的方式，但可能更快）：

置换您的变量集并检查是否存在变量顺序值。
评估传递排列对于已经选择的那些是唯一的

在以下示例中，您设置了两个值来控制搜索过程：nsuccess - 许多唯一排列的所需数量; nmax - 最大排列数（设置计算时间的上限）

实施例

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

set.seed(1)
nsuccess <- 200
nmax <- 30000
res <- matrix(NA, nrow=length(seq1), ncol=nsuccess)
i <- 1
j <- 1
while(i <= nsuccess & j <= nmax){
  s1 <- sample(seq1)
  s1str <- paste(s1, collapse=",")
  test <- rle(s1)$lengths
  if(sum(test) == length(test)) { # check that no values are consecutive
    U <- unique(apply(res, 2, function(x){paste(x, collapse=",")}))
    if(!s1str %in% U){ # check if new permutation is unique
      res[,i] <- s1
      i <- i+1
    }
  }
  j <-j+1
}
print(paste("i =", i, "; j =", j))
res # view the unique permutations

使用非重复元素

3 个答案:

实施例