Думаю, мы это будем корректировать, но как насчет regex подхода?
Проверь это:

library(tidyverse)

# ----------------
my_numbers <- c(1, 5, 7)
my_combinations <- data.frame(expand.grid(rep(list(my_numbers), 6)))

# Patterns
looking <- str_c(
  sep = "|",
  "1{2}")      # At least two "1"

not_looking <- str_c(
  sep = "|",
  "17",        # 1 can only be followed by either 1 or 5
  "51",        # 5 can only be followed by either 5 or 7
  "71", "75")  # 7 can only be followed by 7

# ----------------
my_output <- my_combinations %>% 
  rowwise() %>% 
  mutate(combo = str_flatten(c_across(starts_with("var")))) %>% 
  filter(str_detect(combo, looking), !str_detect(combo, not_looking))

Выход:

> my_output
# A tibble: 11 × 7
# Rowwise: 
    Var1  Var2  Var3  Var4  Var5  Var6 combo 
   <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <chr> 
 1     1     1     1     1     1     1 111111
 2     1     1     1     1     1     5 111115
 3     1     1     1     1     5     5 111155
 4     1     1     1     5     5     5 111555
 5     1     1     5     5     5     5 115555
 6     1     1     1     1     5     7 111157
 7     1     1     1     5     5     7 111557
 8     1     1     5     5     5     7 115557
 9     1     1     1     5     7     7 111577
10     1     1     5     5     7     7 115577
11     1     1     5     7     7     7 115777

^{Created on 2024-05-01 with reprex v2.1.0}

Код ниже применяет условия, которые вы закодировали в своем вопросе, и дает не все результаты NA.

library(dplyr)

numbers <- c(1, 5, 7)
all_combinations <- data.frame(expand.grid(rep(list(numbers), 6)))

all_combinations %>%
  mutate(
    starts_with_1 = ifelse(Var1 == 1, "yes", "no"),
    numbers_ascending = apply(., 1, function(x) all(diff(as.numeric(x)) >= 0)),
    numbers_ascending = ifelse(numbers_ascending , "yes", "no"),
    at_least_two_ones = apply(., 1, function(x) sum(x == 1) >= 2),
    at_least_two_ones = ifelse(at_least_two_ones, "yes", "no")
  ) %>%
  filter(
    starts_with_1 == "yes",
    numbers_ascending == "yes",
    at_least_two_ones == "yes"
  )

Я не уверен, что определенные вами логические условия дают требуемые результаты, поскольку в выводе ниже вы можете видеть, что есть случай, когда за 1 следует 7. Возможно, есть и другие случаи, которые не соответствуют правилам. ты определил.

Поэтому вам, возможно, придется усовершенствовать свою логику. Но, по крайней мере, этот подход даст вам результаты, на которые стоит обратить внимание.

   Var1 Var2 Var3 Var4 Var5 Var6 starts_with_1 numbers_ascending at_least_two_ones
1     1    1    1    1    1    1           yes               yes               yes
2     1    1    1    1    1    5           yes               yes               yes
3     1    1    1    1    5    5           yes               yes               yes
4     1    1    1    5    5    5           yes               yes               yes
5     1    1    5    5    5    5           yes               yes               yes
6     1    1    1    1    1    7           yes               yes               yes
7     1    1    1    1    5    7           yes               yes               yes
8     1    1    1    5    5    7           yes               yes               yes
9     1    1    5    5    5    7           yes               yes               yes
10    1    1    1    1    7    7           yes               yes               yes
11    1    1    1    5    7    7           yes               yes               yes
12    1    1    5    5    7    7           yes               yes               yes
13    1    1    1    7    7    7           yes               yes               yes
14    1    1    5    7    7    7           yes               yes               yes
15    1    1    7    7    7    7           yes               yes               yes

Вы также можете упростить реализацию следующим образом:

all_combinations %>%
  mutate(
    numbers_ascending = apply(., 1, function(x) all(diff(as.numeric(x)) >= 0)),
    at_least_two_ones = apply(., 1, function(x) sum(x == 1) >= 2)
  ) %>%
  filter(
    Var1 == 1,
    numbers_ascending,
    at_least_two_ones
  )

Вот один из подходов, который вы можете использовать:

fn <- function(numbers, n_cols = 6, n_at_start) {
  v <- seq_along(numbers)
  
  # Generate grid and convert to matrix
  m <- as.matrix(expand.grid(rep(list(v), n_cols)))
  
  # Colwise differences
  dm <- m[, -1] - m[, -n_cols]
  
  # Filter
  m <- m[rowSums(m == 1) >= n_at_start  &   # Row starts with n 1s
         rowSums(dm == 0 | dm == 1) == n_cols - 1, ] # Number followed by itself or next value in sequence
  
  m[] <- numbers[m]
  m

}

fn(c(1,5,7), n_cols = 6, n_at_start = 2)

      Var1 Var2 Var3 Var4 Var5 Var6
 [1,]    1    1    1    1    1    1
 [2,]    1    1    1    1    1    5
 [3,]    1    1    1    1    5    5
 [4,]    1    1    1    5    5    5
 [5,]    1    1    5    5    5    5
 [6,]    1    1    1    1    5    7
 [7,]    1    1    1    5    5    7
 [8,]    1    1    5    5    5    7
 [9,]    1    1    1    5    7    7
[10,]    1    1    5    5    7    7
[11,]    1    1    5    7    7    7

1)expand.grid Индексы чисел должны быть неубывающими, и поскольку должно быть не менее n1 единиц, каждое возможное решение из n чисел должно начинаться с n1 единиц. Остается n-n1 индексов, поэтому сформируйте сетку g, а затем используйте apply, чтобы получить логический вектор, указывающий, какие строки g сохранить, и подмножество g по нему. Наконец преобразуйте индексы в значения x. Этот последний шаг позволяет располагать x в любом порядке.

filter_rows <- function(g, x) {
  ok  <- function(z) all(diff(z) %in% 0:1)
  out <- g[apply(g, 1, ok), ]
  replace(out, TRUE, lapply(out, \(i) x[i]))
}

f <- function(x = c(1,5,7), n=6, n1=2) {
  do.call(expand.grid, rep(list(1, seq_along(x)), c(n1, n-n1))) |>
    filter_rows(x)
}

# test runs
f() # as per question 
f(n1 = 3) # 3 ones
f(c(1, 7, 5)) # change order

2) gtools В gtools есть функция, combinations которая может вычислять комбинации с дубликатами. Функция filter_rows взята из (1).

library(gtools)

f2 <- function(x = c(1,5,7), n=6, n1=2) {
  data.frame(as.list(rep(1, n1)), 
    combinations(length(x), n-n1, repeats.allowed = TRUE)) |>
  filter_rows(x)
}

# test runs
f2() # as per question 
f2(n1 = 3) # 3 ones
f2(c(1, 7, 5)) # change order

3) RcppAlgos Это похоже на (2), за исключением того, что здесь используется combGeneral из RcppAlgos. Функция filter_rows взята из (1).

library(RcppAlgos)

f3 <- function(x = c(1,5,7), n=6, n1=2) {
  data.frame(as.list(rep(1, n1)), 
    comboGeneral(length(x), n-n1, repetition = TRUE)) |>
    filter_rows(x)
}

# test runs
f3() # as per question 
f3(n1 = 3) # 3 ones
f3(c(1, 7, 5)) # change o

Обновлять

• Добавлено (2) и (3)
• Зафиксированный. Добавили одно условие, которое изначально я пропустил.
• вынесенный код, общий для (1), (2) и (3)

Поскольку требуются две единицы, а за единицей может следовать только 1 или 5, первые два столбца должны быть равны одной. Ниже я даю три варианта. Первый требует некоторой фильтрации; другие этого не делают.

В первом варианте используется RcppAlgos::comboGeneral. Результаты по умолчанию будут упорядочены. Единственное условие, которое не будет удовлетворено, — это то, что за 1 не следует 7, поэтому мы фильтруем это условие.

library(RcppAlgos)

v <- c(1, 5, 7)
x <- cbind(1, 1, comboGeneral(v, 4, TRUE))
x[rowSums(x[,-6] == v[1] & x[,-1] == v[3]) == 0,]
#>       [,1] [,2] [,3] [,4] [,5] [,6]
#>  [1,]    1    1    1    1    1    1
#>  [2,]    1    1    1    1    1    5
#>  [3,]    1    1    1    1    5    5
#>  [4,]    1    1    1    1    5    7
#>  [5,]    1    1    1    5    5    5
#>  [6,]    1    1    1    5    5    7
#>  [7,]    1    1    1    5    7    7
#>  [8,]    1    1    5    5    5    5
#>  [9,]    1    1    5    5    5    7
#> [10,]    1    1    5    5    7    7
#> [11,]    1    1    5    7    7    7

Второй вариант меняет расположение перехода 1 -> 5 или 5 -> 7 с помощью аргумента freqs функции RcppAlgos::permuteGeneral. Переходов может быть до двух, а непереходов (исключая первые два столбца) — до четырех.

library(matrixStats)

cbind(1, 1, matrix(v[rowCumsums(permuteGeneral(0:1, 4, TRUE, c(4, 2))) + 1L], ncol = 4))
#>       [,1] [,2] [,3] [,4] [,5] [,6]
#>  [1,]    1    1    1    1    1    1
#>  [2,]    1    1    1    1    1    5
#>  [3,]    1    1    1    1    5    5
#>  [4,]    1    1    1    1    5    7
#>  [5,]    1    1    1    5    5    5
#>  [6,]    1    1    1    5    5    7
#>  [7,]    1    1    1    5    7    7
#>  [8,]    1    1    5    5    5    5
#>  [9,]    1    1    5    5    5    7
#> [10,]    1    1    5    5    7    7
#> [11,]    1    1    5    7    7    7

В третьем варианте используется compositionsGeneral и наблюдение о том, что количество повторений каждого элемента в последних 5 столбцах представляет собой 3-композицию из 5 (с допустимыми нулями):

x <- t(compositionsGeneral(0:5, 3, repetition = TRUE)[,3:1])
cbind(1, matrix(rep(rep(v, ncol(x)), x), ncol(x), 5, 1))
#>       [,1] [,2] [,3] [,4] [,5] [,6]
#>  [1,]    1    1    1    1    1    1
#>  [2,]    1    1    1    1    1    5
#>  [3,]    1    1    1    1    5    5
#>  [4,]    1    1    1    5    5    5
#>  [5,]    1    1    5    5    5    5
#>  [6,]    1    1    1    1    5    7
#>  [7,]    1    1    1    5    5    7
#>  [8,]    1    1    5    5    5    7
#>  [9,]    1    1    1    5    7    7
#> [10,]    1    1    5    5    7    7
#> [11,]    1    1    5    7    7    7

Идея

Поскольку у вас есть требование иметь как минимум две 1, а 1 — это самая маленькая цифра, с которой вы хотите начать. В случае, если у вас всегда есть как минимум два 1 в начале вашей последовательности, например, 11xxxx.

Для следующих четырех заполнителей x вы можете последовательно заполнить его допустимым числом (в зависимости от его прецедентного значения, например, за 1 следует 1 или 5, а за 5 следует 5 или 7 и т. д.) и итеративно обновлять последовательность, пока все четыре x не будут заполнены.

Код (с рекурсией)

Я бы сказал, что expand.grid здесь не лучший выбор, поскольку включает слишком много ненужных комбинаций. Вы можете создать рекурсивную функцию для получения желаемых комбинаций, например:

f <- function(n, v = c(1, 5, 7)) {
    if (n == 2) {
        return(list(c(1, 1)))
    }
    unlist(
        lapply(
            Recall(n - 1),
            \(x)
            Map(
                c,
                list(x),
                unlist(list(v[-3], v[-1], v[3])[match(tail(x, 1), v)])
            )
        ), FALSE
    )
}

который дает

> f(6)
[[1]]
[1] 1 1 1 1 1 1

[[2]]
[1] 1 1 1 1 1 5

[[3]]
[1] 1 1 1 1 5 5

[[4]]
[1] 1 1 1 1 5 7

[[5]]
[1] 1 1 1 5 5 5

[[6]]
[1] 1 1 1 5 5 7

[[7]]
[1] 1 1 1 5 7 7

[[8]]
[1] 1 1 5 5 5 5

[[9]]
[1] 1 1 5 5 5 7

[[10]]
[1] 1 1 5 5 7 7

[[11]]
[1] 1 1 5 7 7 7