在R中高效地创建向量的错排

Question

在R中高效地创建向量的错排

4

我正在寻找一种在R中高效创建一个错排（以及相反的特定排列）的方法，与此相关的基础函数似乎没有，这方面在SO上也没有太多信息。

一个明显的开始是使用sample来创建向量的排列。但我需要这个排列没有固定点，因此是向量的一个错排。关于这个话题的一个不错的解释，请参考这篇Cross Validated文章。

这是我的第一种方法：

derangr <- function(x){

  while(TRUE){

    xp <- sample(x)

     if(sum(xp == x) == 0) break

  }

  return(xp)

}

在一个while循环中，我正在检查向量x和称为xp的x的给定排列之间是否存在不动点。如果没有，则我会打破循环并返回该向量。

结果表明，它运行良好：

> derangr(1:10)
 [1]  4  5  6 10  7  2  1  9  3  8

> derangr(LETTERS)
 [1] "C" "O" "L" "J" "A" "I" "Y" "M" "G" "T" "S" "R" "Z" "V" "N" "K" "D" "Q" "B" "H" "F" "E" "X" "W" "U" "P"

我在思考是否有更好的方法来做这件事，可能是通过某种向量化方式替换while。同时，我也想关注可伸缩性。

以下是两个示例的microbenchmark：

library(microbenchmark)

> microbenchmark(derangr(1:10),times = 10000)
Unit: microseconds
          expr   min     lq    mean  median      uq      max neval
 derangr(1:10) 8.359 15.492 40.1807 28.3195 49.4435 6866.453 10000

> microbenchmark(derangr(LETTERS),times = 10000)
Unit: microseconds
             expr    min     lq     mean  median      uq      max neval
 derangr(LETTERS) 24.385 31.123 34.75819 32.4475 34.3225 10200.17 10000

同样的问题也适用于反过来，即产生具有给定数量固定点n的排列。

arrangr <- function(x,n){

  while(TRUE){

    xp <- sample(x)

     if(sum(xp == x) == n) break
  }

  return(xp)

}

- Val

2

你的向量中是否有一些值出现了多次，就像 rep(LETTERS, 2) 中那样？如果是这样的话，如果第一个“A”与第二个“A”等互换，是否会有影响？ - loki

我正在寻找一个通用解决方案，所以你提出了一个很好的观点。我的函数假设唯一值。如果您有重复值，那么无论第一个“A”是否被第二个“A”替换，只要没有元素（或相反n）元素保留在它们之前的位置，就不会有影响。 - Val

2个回答

1

您目前排列函数的主要低效之处在于，如果它在排列中找到一个固定点，则重新生成整个排列，而不是仅进行一些最小更改以尝试去除固定点。更快的方法是从生成排列开始，然后将固定点与随机元素交换，直到没有更多的固定点。使用此方法，每次找到一个固定点时，您只交换两个值（随机选择），而不是重新生成整个排列。

如果您想将其概括为指定固定点数（而不是零），则可以通过首先对固定点进行随机抽样，然后使用剩余元素的无进一步固定点的置换来扩展算法。这被称为广义错排问题，它是没有固定点的经典错排问题的自然扩展。

你可以在derange函数中找到一个算法来产生经典的和广义的错排。这个链接的函数是“向量化”的，可以生成多个错排，而且还有一些其他的花哨功能，会减慢运行时间。特别地，这个函数允许你生成任意可能数量的固定点的广义错排。如果你只想生成经典的错排（没有固定点），那么---简化为其本质---算法看起来像这样：

derange <- function(set) {
  
  #Check input set
  n <- length(set)
  if (n < 2)         stop('Error: Input set must have at least two elements')
  
  #Generate derangement
  PERM  <- sample.int(n, size = n, replace = FALSE)
  FIXED <- sum(PERM == 1:n)
  while (FIXED > 0) {
    i <- which(PERM == 1:n)[1]
    j <- (1:n)[-i][sample.int(n-1, size = 1)]
    SWAP    <- PERM[j]
    PERM[j] <- PERM[i]
    PERM[i] <- SWAP
    FIXED <- sum(PERM == 1:n) }
  set[PERM] }

您可以检查此功能是否生成了输入集的有效置换（请注意，如果输入集中有重复元素，则可以有效地交换这些元素，并且这不被视为“固定点”）。如果您想要向量化功能，可以使用链接版本。下面我进行了基准测试，以查看当前函数与本帖中其他函数的性能表现如何。毫不奇怪，目前的方法稍微快一些。

#Benchmarking test
library(microbenchmark)
microbenchmark(derangr(LETTERS), derangr2(LETTERS), derange(LETTERS), times = 10^6)

Unit: microseconds
              expr min  lq     mean median   uq     max neval
  derangr(LETTERS) 4.6 5.9 16.89053   11.1 20.5 58666.6 1e+06
 derangr2(LETTERS) 5.0 6.4 17.12375   11.5 20.7 20171.4 1e+06
  derange(LETTERS) 4.2 5.4 11.74055    9.9 14.0 37522.1 1e+06

- Ben

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- loki · Accepted Answer

如果您没有唯一的值，可以重新排列索引并将其用于按新顺序对输入向量进行子集化。在这种情况下，如果您有例如rep(LETTERS, 2)，第一个A和第二个A是可互换的。Q中提出的derangr()函数也会重新排列这些内容。

derangr2 <- function(x){
  ind <- seq_along(x)
  while(TRUE){
    indp <- sample(ind)
    if(sum(indp == ind) == 0) break

  }
  return(x[indp])
}

一些基准测试结果：

microbenchmark(derangr(rep(LETTERS, 4)), 
               derangr2(rep(LETTERS, 4)), times = 1000)

# Unit: microseconds
#                      expr   min       lq       mean  median      uq      max neval
#  derangr(rep(LETTERS, 4)) 6.258 113.4895 441.831094 251.724 549.384 5837.143  1000
# derangr2(rep(LETTERS, 4)) 6.542   7.3960  23.173800  12.800  22.755 4645.936  1000

然而，如果你面对的是唯一值，这种方法并没有太多的改进。

microbenchmark(derangr(1:1000), derangr2(1:1000), times = 1000)
# Unit: microseconds
#             expr    min     lq     mean median      uq      max neval
#  derangr(1:1000) 19.341 21.333 61.55154 40.959 78.0775 2770.382  1000
# derangr2(1:1000) 23.608 25.884 72.76647 46.079 84.1930 2674.243  1000