Выберите строки матрицы, которые являются перестановками данного вектора

Ваша примерная матрица и целевой вектор:

X <- structure(c(1, 2, 3, 4, 4, 3, 0, 2, 9, 3, 2, 1, 1, 11, 2, 4, 5, 4, 19, 1),
               dim = 5:4)
v <- 1:4

Но давайте создадим более сложный вариант (спасибо пользователю Харре):

X <- rbind(X, 1, c(1, 2, 1, 2))

Полностью векторизованный подход (с использованием пакета matrixStats)

rk <- matrix(match(X, v, nomatch = 0L), nrow(X), ncol(X))
ct <- matrixStats::rowTabulates(rk, values = 1:length(v))
zo <- matrixStats::rowCounts(ct, value = 0L)

## all rows that are permutations of 'v'
X[zo == 0L, ]
#     [,1] [,2] [,3] [,4]
#[1,]    1    3    2    4
#[2,]    3    2    1    4
#[3,]    4    3    2    1

## remove rows that are permutations of 'v'
X[zo > 0L, ]

Другой полностью векторизованный метод (база R)

Это математическое решение. Для нелинейной и асимметричной весовой функции ш(х) следующая взвешенная сумма:

1 х ш(1) + 2 х ш(2) + 3 х ш(3) + 4 х ш(4)

является уникальной оценкой или идентификатором и не зависит от перестановок. Так, например, следующее дает одно и то же значение:

2 х ш(2) + 1 х ш(1) + 3 х ш(3) + 4 х ш(4)

Но все остальное даст разные значения, например:

1 х ш(1) + 3 х ш(1) + 3 х ш(3) + 4 х ш(4)

0 х ш(0) + 3 х ш(1) + 0 х ш(0) + 4 х ш(4)

Вот реализация с использованием косинусных весов. Это работает, даже если X и v являются числами или символами с плавающей запятой.

## method = "tab" for tabulation method
## method = "cos" for cosine weights method
FindPerm <- function (X, v, method) {
  ## number of elements
  n <- length(v)
  if (ncol(X) != n) stop("inconformable 'X' and 'v'!")
  if (anyDuplicated(v)) stop("'v' should not contain duplicated values!")
  ## convert everything to integers 0, 1, 2, ..., n
  Xi <- matrix(match(X, v, nomatch = 0L), nrow(X), ncol(X))
  vi <- 1:n
  ## branches
  if (method == "tab") {
    ## row-wise tabulating
    rtab <- matrixStats::rowTabulates(Xi, values = vi)
    ## the i-th value is TRUE if X[i, ] is a permutation of v
    matrixStats::rowCounts(rtab, value = 0L) == 0L
  } else if (method == "cos") {
    ## evaluate cosine weights for Xi and vi
    w <- pi / (n + 1)
    cos.Xi <- cos(w * Xi)
    cos.vi <- cos(w * vi)
    ## weighted sum for Xi
    wtsum.Xi <- rowSums(Xi * cos.Xi)
    ## weighted sum for vi
    wtsum.vi <- sum(vi * cos.vi)
    ## the i-th value is TRUE if X[i, ] is a permutation of v
    wtsum.Xi == wtsum.vi
  } else {
    stop("unknown method!")
  }
}

X[FindPerm(X, v, "cos"), ]
#     [,1] [,2] [,3] [,4]
#[1,]    1    3    2    4
#[2,]    3    2    1    4
#[3,]    4    3    2    1

Ориентир

Производительность зависит от количества значений в v. Метод табуляции будет замедляться, когда v станет длинным.

## a benchmark function, relying on package "microbenchmark"
## nr: number of matrix rows
## nc: number of elements in 'v'
bm <- function (nr, nc) {
  X <- matrix(sample.int(nc + 1L, nr * nc, replace = TRUE), nr)
  v <- 1:nc
  microbenchmark::microbenchmark("tab" = FindPerm(X, v, "tab"),
                                 "cos" = FindPerm(X, v, "cos"),
                                 check = "identical")
}

bm(2e+4, 4)
#Unit: milliseconds
# expr      min       lq     mean   median       uq      max
#  tab 4.302674 4.324236 4.536260 4.336955 4.359814 7.039699 
#  cos 4.846893 4.872361 5.163209 4.882942 4.901288 7.837580

bm(2e+4, 20)
#Unit: milliseconds
# expr      min       lq     mean   median       uq       max
#  tab 30.63438 30.70217 32.73508 30.77588 33.08046 135.64322
#  cos 21.16669 21.26161 22.28298 21.37563 23.60574  26.31775 

mat <- rbind(
    c(1, 3, 2, 4),
    c(2, 0, 1, 5),
    c(3, 2, 1, 4)
)

ok <- apply(mat, 1L, function(x) setequal(x, c(1, 2, 3, 4)))
mat[ok, ]

Другой вариант — использовать функцию Filter.

t(Filter(\(x) all((x %in% 1:4) & length(unique(x)) == 4) ,
data.frame(t(X))))

Просто для удовольствия

Кто может дать мне 4 различных цифры, сумма которых равна 6?

• есть только {0,1,2,3}

тогда мы можем использовать модуль 4, используя %%

X[apply(X , 1 , \(x) sum(unique(x %% 4)) == 6 & length(unique(x)) == 4) , ]

ИЛИ ЖЕ

с использованием чистого for loop

ans <- data.frame(matrix(NA , ncol = ncol(X)))
r <- 1
for(i in 1:nrow(X)){
    if (all((X[i,] %in% 1:4) & length(unique(X[i,])) == 4)){
        ans[r,] <- X[i,]
        r <- r + 1
    }
}

ans <- as.matrix(ans)

• выход

  X1 X2 X3 X4
1  1  3  2  4
2  3  2  1  4
3  4  3  2  1

• данные

X <- matrix(c(1, 2, 3, 4, 4, 3, 0, 2, 9, 3, 2, 1, 1, 11, 2, 4, 
              5, 4, 19, 1) , ncol = 4)

Для удовольствия от tidyverse-решений, даже если я думаю, что мы предпочли бы работать с матрицами напрямую. Однако мы могли бы использовать rowwise() и c_across():

С операциями над множествами (вдохновленными @Stéphane Laurent):

library(dplyr)

mat %>% 
  as_tibble() |>
  rowwise() |>
    filter(setequal(c_across(), c(1, 2, 3, 4))) |>
  ungroup() |>
  as.matrix()

Или без операций множества:

library(dplyr)

mat %>% 
  as_tibble() |>
  rowwise() |>
  filter(1 %in% c_across(everything()) &
         2 %in% c_across(everything()) &
         3 %in% c_across(everything()) &
         4 %in% c_across(everything())
         ) |>
  ungroup() |>
  as.matrix()

Или вдохновленный @Mohamed Desouky:

mat %>% 
    as_tibble() |>
    rowwise() |>
      filter(all(c_across() %in% 1:4) & n_distinct(c_across()) == 4) |>
    ungroup() |>
    as.matrix()

И так далее..

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

Идея состоит в том, чтобы индексировать length(v)-мерный массив для маленьких v или индексировать v*sin(w*v), используя результаты match вместо вычисления X*sin(W*X), когда v велико:

library(RcppAlgos)

# simplified version of Zheyuan Li's function
f1 <- function(X, v) {
  n <- length(v)
  Xi <- matrix(match(X, v, nomatch = 0L), nrow(X), ncol(X))
  vi <- 1:n
  w <- pi/(n + 1)
  rowSums(Xi*sin(Xi*w)) == sum(vi*sin(vi*w))
}

f2 <- function(X, v) {
  n <- length(v)
  
  if (n < 6) {
    # index an n-dimensional array
    m <- array(FALSE, rep(n + 1L, n))
    m[permuteGeneral(n)] <- TRUE
    X[] <- match(X, v, nomatch = length(v) + 1L)
    m[X]
  } else {
    nn <- 1:n
    u <- c(nn*sin(pi*nn/(n + 1L)), 0)
    X[] <- u[match(X, v, nomatch = n + 1L)]
    rowSums(X) == sum(u)
  }
}

set.seed(123)
# using Zheyuan Li's test dataset
nr <- 2000; nc <- 4
X <- matrix(sample.int(nc + 1L, nr * nc, replace = TRUE), nr)
v <- 1:nc

microbenchmark::microbenchmark(f1 = f1(X, v),
                               f2 = f2(X, v),
                               check = "identical")
#> Unit: microseconds
#>  expr   min     lq    mean median     uq    max neval
#>    f1 344.4 367.25 438.932 374.05 386.75 5960.6   100
#>    f2  81.9  85.00 163.332  88.90  98.50 6924.4   100

# Zheyuan Li's larger test dataset
set.seed(123)
nr <- 2000; nc <- 20
X <- matrix(sample.int(nc + 1L, nr * nc, replace = TRUE), nr)
v <- 1:nc

microbenchmark::microbenchmark(f1 = f1(X, v),
                               f2 = f2(X, v),
                               check = "identical")
#> Unit: microseconds
#>  expr    min      lq     mean  median     uq    max neval
#>    f1 1569.2 1575.45 1653.510 1601.30 1683.6 3972.6   100
#>    f2  355.2  359.90  431.705  366.85  408.6 2253.8   100

Оригинальный ответ отредактирован для использования X + exp(1/X) (см. комментарии).

Это должно работать с положительными целыми числами:

Y <- X[rowSums(X + exp(1/X)) == sum(1:4 + exp(1/(1:4))),]

Сравнение с решением apply:

f1 <- function(x) x[apply(x, 1L, function(x) setequal(x, 1:4)),]
f2 <- function(x) x[rowSums(x + exp(1/x)) == sum(1:4 + exp(1/(1:4))),]

X <- matrix(sample(10, 4e5, TRUE), 1e5)
microbenchmark::microbenchmark(f1 = f1(X),
                               f2 = f2(X),
                               times = 10,
                               check = "equal")
#> Unit: milliseconds
#>  expr      min       lq      mean    median       uq      max neval
#>    f1 448.2680 450.8778 468.55179 461.62620 472.0022 542.0455    10
#>    f2  28.5362  28.6889  31.50941  29.44845  30.2693  50.4402    10

Мы можем попробовать это

> mat[colSums(mapply(`%in%`, list(1:4), asplit(mat, 1))) == ncol(mat), ]
     [,1] [,2] [,3] [,4]
[1,]    1    3    2    4
[2,]    3    2    1    4
[3,]    4    3    2    1

Этот вопрос ГОРЯЧИЙ. Я учусь, поэтому я воспринимаю это как хорошую возможность учиться. Мне действительно сложно придумывать новые решения, но я обнаружил, что здесь не хватает двух вещей:

1. нет серьезной проверки этих ответов;
2. нет эталона для всех из них.

Я хотел бы преобразовать каждый ответ в функцию, которая возвращает вектор TRUE/FALSE для пометки строк. Я также хочу, чтобы эта функция работала с любой матрицей и любым вектором.

• Ответ Стефана Лорана, Ответ Чжэюань Ли и Ответ ThomasIsCoding требуют минимальной адаптации.

• Ответ Мохамеда Десуки также легко адаптировать, вынеся функцию, примененную в Filter(), и apply() по строкам матрицы.

• ответ jblood94 является сложной задачей. Было отмечено, что для других матриц и векторов необходимо преобразование с использованием match. Я не знаю, как правильно, но я увидел match в ответе Чжэюань Ли, поэтому позаимствовал эту часть.

• Ответ ТарДжея ужасен (извините, не воспринимайте это как оскорбление). Кажется, ни один из них не работает. Я не вижу никакого сравнения между строками матрицы и векторами в базовом решении R. Для других кодов tidyverse я не знаю, что такое df_matrix. Я попросил TarJae пересмотреть ответ.

• ответ Харре использует tidyverse и не возвращает TRUE/FALSE. Поэтому я должен исключить его из теста (извините).

Вот функции для теста.

S.Laurent <- function (X, v) apply(X, 1L, function(x) setequal(x, v))

Z.Li <- function (X, v, method) {
  ## number of elements
  n <- length(v)
  if (ncol(X) != n) stop("inconformable 'X' and 'v'!")
  if (anyDuplicated(v)) stop("'v' should not contain duplicated values!")
  ## convert everything to integers 0, 1, 2, ..., n
  Xi <- matrix(match(X, v, nomatch = 0L), nrow(X), ncol(X))
  vi <- 1:n
  ## branches
  if (method == "tab") {
    ## row-wise tabulating
    rtab <- matrixStats::rowTabulates(Xi, values = vi)
    ## the i-th value is TRUE if X[i, ] is a permutation of v
    matrixStats::rowCounts(rtab, value = 0L) == 0L
  } else if (method == "cos") {
    ## evaluate cosine weights for Xi and vi
    w <- pi / (n + 1)
    cos.Xi <- cos(w * Xi)
    cos.vi <- cos(w * vi)
    ## weighted sum for Xi
    wtsum.Xi <- rowSums(Xi * cos.Xi)
    ## weighted sum for vi
    wtsum.vi <- sum(vi * cos.vi)
    ## the i-th value is TRUE if X[i, ] is a permutation of v
    wtsum.Xi == wtsum.vi
  } else {
    stop("unknown method!")
  }
}

Thomas <- function (X, v) colSums(mapply(`%in%`, list(v), asplit(X, 1))) == ncol(X)

M.Desouky <- function (X, v) apply(X, 1, function (x) all((x %in% v) & length(unique(x)) == length(v)))

jblood94 <- function (X, v) {
  Xi <- matrix(match(X, v, nomatch = 0L), nrow(X), ncol(X))
  vi <- 1:length(v)
  rowSums(Xi + exp(1/Xi)) == sum(vi + exp(1/vi))
}

Для эталона я следил за настройкой в ​​​​ответе Чжэюань Ли.

library(matrixStats)
library(microbenchmark); library(ggplot2)

nr <- 2000; nc <- 4
X <- matrix(sample.int(nc + 1L, nr * nc, replace = TRUE), nr)
v <- 1:nc
microbenchmark("S.Laurent" = S.Laurent(X, v),
               "Z.Li.tab" = Z.Li(X, v, "tab"),
               "Z.Li.cos" = Z.Li(X, v, "cos"),
               "Thomas" = Thomas(X, v),
               "M.Desouky" = M.Desouky(X, v),
               "jblood94" = jblood94(X, v),
               check = "identical") -> bm1
autoplot(bm1)

nr <- 2000; nc <- 20
X <- matrix(sample.int(nc + 1L, nr * nc, replace = TRUE), nr)
v <- 1:nc
microbenchmark("S.Laurent" = S.Laurent(X, v),
               "Z.Li.tab" = Z.Li(X, v, "tab"),
               "Z.Li.cos" = Z.Li(X, v, "cos"),
               "Thomas" = Thomas(X, v),
               "M.Desouky" = M.Desouky(X, v),
               "jblood94" = jblood94(X, v),
               check = "identical") -> bm2
autoplot(bm2)

Не знаю, как трансформируется время для сюжета, но явно не в обычном масштабе. Те, что слева, намного быстрее, чем это следует из сюжета!

Вывод: Метод "cos" Чжэюань Ли является победителем.

Библиотека algorithm в C++ предлагает функцию под названием std::is_permutation, которая делает свое дело.

Функция рабочей лошадки ниже использует Rcpp и довольно проста.

#include <Rcpp.h>

// [[Rcpp::export]]
SEXP perm_idx_cpp(Rcpp::IntegerMatrix mat, const std::vector<int> &v) {
  
    const int nRows = mat.nrow();
    const int nCols = mat.ncol();
    
    std::vector<int> test(nCols);
    Rcpp::LogicalVector res(nRows);
    
    for (int i = 0; i < nRows; ++i) {
        for (int j = 0; j < nCols; ++j) {
            test[j] = mat(i, j);
        }
        
        res[i] = std::is_permutation(
            test.begin(), test.end(), v.begin()
        );
    }
    
    return res;
}

И, назвав это R, мы имеем (примечание. Мы используем match для получения целочисленных индексов, как в ответе @Zheyuan Li, что, кстати, абсолютно блестяще!):

get_perm_idx <- function(X, v) {
    Xi <- matrix(match(X, v, nomatch = 0L), ncol = ncol(X))
    perm_idx_cpp(Xi, seq_along(v))
}

Это также очень эффективно. Вот простой бенчмарк:

nr <- 2e4
nc <- 20
X <- matrix(sample.int(nc + 1L, nr * nc, replace = TRUE), nr)
v <- 1:nc
microbenchmark("tab" = FindPerm(X, v, "tab"),
               "cos" = FindPerm(X, v, "cos"),
               "is_perm_cpp" = get_perm_idx(X, v),
               check = "identical")
Unit: milliseconds
        expr       min        lq     mean    median        uq       max neval
         tab 33.641345 36.479660 39.00994 37.402306 39.560015  54.88057   100
         cos  9.496309 12.887493 15.30122 13.306302 14.053643 132.24079   100
 is_perm_cpp  3.232093  4.819553  6.08687  4.993367  5.248818  19.56919   100

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