防止列表“溢出”

Question

我想到了以下问题：

假设有 5 个球：

• 红色
• 蓝色
• 绿色
• 黄色
• 橙色

我想知道这 5 个球的排序方式有多少：

• “红”球可以位于第一个或第二个位置（从左到右）
• “蓝”球和“绿”球之间必须至少有 2 个位置
• “黄色”球不能在最后一个位置

在上一个问题 (Filtering a Data Frame based on Row Conditions) 中，我学习了如何首先生成一个列表，其中列出了可以订购这 5 个球的所有可能方式，然后仅在此列表中保留满足上述约束的条目：

# generate all possible combinations (120 combinations)

library(combinat)
library(dplyr)
library(data.table)
library(tidyverse)

my_list = c("Red", "Blue", "Green", "Yellow", "Orange")

d = permn(my_list)

all_combinations  = as.data.frame(matrix(unlist(d), ncol = 120)) %>%
  setNames(paste0("col", 1:120))

# keep combinations that match constraints

 tpose = transpose(all_combinations)

tpose %>%
  mutate(blue_delete = case_when(V1 == "Blue" & V2 == "Green" ~ TRUE,
                                 V1 == "Blue" & V3 == "Green" ~ TRUE,
                                 V2 == "Blue" & V3 == "Green" ~ TRUE,
                                 V3 == "Blue" & V4 == "Green" ~ TRUE,
                                 V4 == "Blue" & V5 == "Green" ~ TRUE,
                                 TRUE ~ FALSE)) %>%
  filter(V3 != "Red" & V4 != "Red" & V5 != "Red",
         V5 != "Yellow",
         blue_delete == FALSE) %>%
  select(-blue_delete)

# preview answer (28 ways)

       V1     V2     V3     V4     V5
1  Orange    Red   Blue Yellow  Green
2     Red Orange   Blue Yellow  Green
3     Red   Blue Orange Yellow  Green
4     Red   Blue Yellow Orange  Green
5     Red   Blue Yellow  Green Orange
6     Red Yellow   Blue Orange  Green
7  Yellow    Red   Blue Orange  Green

我的问题：在上述方法中，必须首先生成可以对球进行排序的所有可能方式的列表 - 因为我们正在处理阶乘，所以随着球数的增加，列表会迅速“爆炸”，而这个庞大的列表将无法存储在计算机的内存中。

是否可以以一般的方式重构上述代码，例如：

• 第 1 步：生成随机排序的球

• 第 2 步：如果第 1 步的排序满足条件，则将其保存在单独的列表中 - 如果不满足条件，则丢弃。

• 第 3 步：生成新的随机排序

• 第 4 步：继续，直到第 2 步的列表包含固定数量的条目（例如 1000）

这样，即使我们可能无法识别任何可能的排序 - 我们至少可以识别一些潜在的排序，与会导致“溢出”的原始方法相比（对于有大量球）。

有谁知道是否有任何标准的方法来处理这类问题？

Answer 1

我最初在您的链接问题中提供的解决方案将继续在这里工作 - 必要的主要修改是创建数据的方式。

首先让我们创建一个函数，该函数将从颜色数据集中生成一组随机排列。

library(tidyverse)
generate_permutations = function(num_perm, num_new_colours) {
  if (num_new_colours == 0) {
    new_colours = character(0)
  } else {
    new_colours = paste0("colour", 1:num_new_colours)
  }
  colours = c(
    "Red", "Blue", "Green", "Yellow", "Orange", new_colours
  )
  map(1:num_perm, ~ sample(colours))
}

permutations = generate_permutations(3, 5)

[[1]]
 [1] "Red"     "Yellow"  "Blue"    "colour4" "Green"   "Orange" 
 [7] "colour5" "colour3" "colour2" "colour1"

[[2]]
 [1] "colour3" "Blue"    "Orange"  "colour4" "Green"   "colour2"
 [7] "colour1" "Red"     "Yellow"  "colour5"

[[3]]
 [1] "Yellow"  "colour1" "colour4" "Blue"    "colour3" "colour5"
 [7] "Red"     "colour2" "Green"   "Orange" 

您可以修改此函数，以便您只使用您选择的真实颜色，而不是生成像colour1 这样的虚拟颜色。

接下来，我们创建这些排列的数据框。请注意，在我的功能中，我只保留不同的球排列。

generate_data = function(permutations) {
  permutations %>%
    map(~ set_names(.x, paste0("ball", 1:length(.x)))) %>%
    do.call(bind_rows, args = .) %>%
    distinct() %>%
    mutate(id = row_number())
}

data = generate_data(permutations)

# A tibble: 3 x 11
  ball1   ball2   ball3   ball4   ball5   ball6  ball7   ball8   ball9   ball10     id
  <chr>   <chr>   <chr>   <chr>   <chr>   <chr>  <chr>   <chr>   <chr>   <chr>   <int>
1 Red     Blue    colour4 colour5 colour1 Green  colour3 Yellow  colour2 Orange      1
2 colour2 Yellow  Orange  colour3 colour4 Blue   Green   colour5 colour1 Red         2
3 colour1 colour2 Blue    Red     Yellow  Orange colour3 colour4 Green   colour5     3

在继续之前，我们可以稍微概括一下规则。让我们使用以下参数来表达规则：

• 条件一：红球必须在x的前几位。

• 条件 2：绿球和蓝球之间必须至少有 y 位置。

• 条件3：黄球不能在最后的z位置。

现在我们可以创建一个基于这些参数过滤数据的函数。该功能与我在上一个问题中提供的解决方案几乎相同。

filter_data = function(data, x = 1, y = 2, z = 1) {
  num_balls = length(data) - 1
  data %>%
    pivot_longer(-id) %>%
    mutate(ball_number = as.numeric(str_extract(name, "[0-9]+"))) %>%
    group_by(id) %>%
    filter(
      # Condition 1
      ball_number[value == "Red"] <= x,
      # Condition 2
      abs(ball_number[value == "Blue"] - ball_number[value == "Green"]) > y,
      # Condition 3
      ball_number[value == "Yellow"] <= num_balls - z
    ) %>%
    select(-ball_number) %>% 
    pivot_wider(values_from = "value", names_from = "name") %>%
    ungroup()
}

正如我在上一个答案中提到的，这种方法的一个好处是该函数中条件制定的通用性。您可以轻松修改这些条件或添加新条件，而无需硬编码诸如蓝球和绿球相对于彼此的确切位置之类的东西。

现在我们准备将所有内容放在一个脚本中：

library(tidyverse)
set.seed(123)
valid_perms = generate_permutations(
  num_perm = 10000, 
  num_new_colours = 20
) %>%
  generate_data() %>%
  filter_data(x = 5, y = 3, z = 1)

即使使用num_perm = 10000，代码仍然可以在不到一秒的时间内运行，并产生 1528 个解决方案：

# A tibble: 1,528 x 26
# Groups:   id [1,528]
      id ball1  ball2  ball3 ball4 ball5 ball6 ball7 ball8 ball9 ball10
   <int> <chr>  <chr>  <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr> 
 1    13 colou~ colou~ Oran~ colo~ Red   colo~ colo~ Blue  colo~ colou~
 2    16 Red    colou~ colo~ Yell~ colo~ colo~ colo~ colo~ colo~ Blue  
 3    27 colou~ colou~ Red   colo~ Oran~ colo~ colo~ colo~ colo~ colou~
 4    33 Red    Blue   colo~ colo~ Oran~ Yell~ Green colo~ colo~ colou~
 5    44 colou~ colou~ colo~ colo~ Red   colo~ colo~ Oran~ colo~ colou~
 6    45 colou~ Orange colo~ Red   colo~ colo~ Green Yell~ colo~ colou~
 7    48 colou~ colou~ Red   colo~ colo~ colo~ Blue  colo~ Oran~ colou~
 8    52 Green  colou~ Red   colo~ colo~ colo~ colo~ colo~ Blue  colou~
 9    58 colou~ colou~ colo~ colo~ Red   colo~ colo~ colo~ Oran~ colou~
10    60 colou~ Red    colo~ Blue  Oran~ colo~ colo~ colo~ colo~ colou~
# ... with 1,518 more rows, and 15 more variables: ball11 <chr>,
#   ball12 <chr>, ball13 <chr>, ball14 <chr>, ball15 <chr>,
#   ball16 <chr>, ball17 <chr>, ball18 <chr>, ball19 <chr>,
#   ball20 <chr>, ball21 <chr>, ball22 <chr>, ball23 <chr>,
#   ball24 <chr>, ball25 <chr>

此解决方案适用于更昂贵的设置。我尝试了100个球和100000个排列，在10秒内得到了15647个排列。

您可以编写一个函数来运行上面的代码，直到您也达到所需的排列数量：

get_permutations = function(desired, num_new_colours, x = 1, y = 2, z = 1) {
  valid_perms = tibble()
  num_it = 1
  while (nrow(valid_perms) < desired && num_it <= 100) {
    cur_num = nrow(valid_perms)
    new_perms = generate_permutations(
      num_perm = 1000, 
      num_new_colours = num_new_colours
    ) %>%
      generate_data() %>%
      filter_data(x, y, z) %>%
      select(-id)
    valid_perms = valid_perms %>%
      bind_rows(new_perms) %>%
      distinct()
    
    if (nrow(valid_perms) == cur_num) break
    num_it = num_it + 1
  }
  head(valid_perms, min(desired, nrow(valid_perms)))
}

请注意，我将迭代次数限制为 100，并且如果当前的 1000 个排列的随机集合没有向当前列表添加一个新的排列，我也会中断循环。

get_permutations(
  desired = 1000,
  num_new_colours = 20,
  # The original conditions:
  x = 2, y = 2, z = 1
)

# A tibble: 1,000 x 25
   ball1  ball2 ball3 ball4 ball5 ball6 ball7 ball8 ball9 ball10 ball11
   <chr>  <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr>  <chr> 
 1 colou~ Red   colo~ colo~ colo~ colo~ colo~ colo~ colo~ Yellow Green 
 2 colou~ Red   colo~ Blue  colo~ colo~ Green colo~ Oran~ Yellow colou~
 3 Red    colo~ Yell~ colo~ colo~ colo~ colo~ colo~ colo~ colou~ colou~
 4 Red    Green colo~ colo~ colo~ colo~ Blue  colo~ colo~ colou~ Orange
 5 colou~ Red   colo~ colo~ colo~ Oran~ colo~ colo~ colo~ colou~ colou~
 6 Yellow Red   colo~ colo~ colo~ colo~ colo~ colo~ colo~ colou~ Green 
 7 Red    colo~ Green colo~ colo~ colo~ colo~ colo~ colo~ colou~ colou~
 8 colou~ Red   colo~ colo~ colo~ Green colo~ colo~ colo~ colou~ colou~
 9 Red    colo~ colo~ colo~ colo~ Green colo~ colo~ Blue  colou~ colou~
10 colou~ Red   colo~ colo~ colo~ colo~ colo~ colo~ colo~ colou~ colou~
# ... with 990 more rows, and 14 more variables: ball12 <chr>,
#   ball13 <chr>, ball14 <chr>, ball15 <chr>, ball16 <chr>,
#   ball17 <chr>, ball18 <chr>, ball19 <chr>, ball20 <chr>,
#   ball21 <chr>, ball22 <chr>, ball23 <chr>, ball24 <chr>,
#   ball25 <chr>

这运行了大约 3 秒。如果您将 x、y 和 z 参数更改为限制较少，代码将运行得更快，因为更容易找到满足条件的排列。

最后，如果我们尝试找到与原始问题完全相同的解决方案（只有五个球），会发生以下情况：

get_permutations(
  desired = 100,
  num_new_colours = 0,
  # Original conditions:
  x = 2, y = 2, z = 1
)
# A tibble: 10 x 5
   ball1 ball2 ball3  ball4  ball5 
   <chr> <chr> <chr>  <chr>  <chr> 
 1 Red   Green Orange Yellow Blue  
 2 Red   Green Yellow Orange Blue  
 3 Blue  Red   Orange Yellow Green 
 4 Red   Blue  Yellow Orange Green 
 5 Green Red   Yellow Orange Blue  
 6 Blue  Red   Yellow Orange Green 
 7 Red   Blue  Orange Yellow Green 
 8 Blue  Red   Yellow Green  Orange
 9 Green Red   Orange Yellow Blue  
10 Green Red   Yellow Blue   Orange