高效匹配另一個向量中一個向量的所有值

Question

我正在尋找一種有效的方法來匹配向量y中向量x的所有值，而不是像match()返回的那樣僅匹配第一個 position。 我所追求的本質上是pmatch()的默認行為，但沒有部分匹配：

x <- c(3L, 1L, 2L, 3L, 3L, 2L)
y <- c(3L, 3L, 3L, 3L, 1L, 3L)

預計 output：

pmatch(x, y)  
[1]  1  5 NA  2  3 NA

一種方法是使用ave()但是隨着組數的增加，這會變得很慢並且效率非常低 memory ：

ave(x, x, FUN = \(v) which(y == v[1])[1:length(v)])
[1]  1  5 NA  2  3 NA

任何人都可以推薦一種有效的方法來實現這一點，最好是（但不是強制性的）base R？

用於基准測試的更大數據集：

set.seed(5)
x <- sample(5e3, 1e5, replace = TRUE)
y <- sample(x, replace = TRUE)

Answer 1

使用split base變體。
將兩個向量的索引按其值split 。 使用第一個列表的名稱對第二個列表進行子集化，這兩個列表具有相同的順序。 將NULL更改為NA並將第二個列表的長度與第一個列表的長度相加。 根據第一個列表的索引重新排序第二個列表的索引。

x <- c(3L, 1L, 2L, 3L, 3L, 2L)
y <- c(3L, 3L, 3L, 3L, 1L, 3L)

a <- split(seq_along(x), x)
b <- split(seq_along(y), y)[names(a)]
b[lengths(b)==0] <- NA
b <- unlist(Map(`length<-`, b, lengths(a)), FALSE, FALSE)
`[<-`(b, unlist(a, FALSE, FALSE), b)
#[1]  1  5 NA  2  3 NA

我試着交換零件

b <- split(seq_along(y), y)[names(a)]
b[lengths(b)==0] <- NA

和

b <- list2env(split(seq_along(y), y))
b <- mget(names(a), b, ifnotfound = NA)

但它並沒有更快。

RCPP版本。
將第二個向量的索引存儲在unordered_map中每個唯一值的queue中。 遍歷第一個向量的所有值並從queue中獲取索引。

Rcpp::sourceCpp(code=r"(
#include <Rcpp.h>
#include <unordered_map>
#include <queue>

using namespace Rcpp;
// [[Rcpp::export]]
IntegerVector pm(const std::vector<int>& a, const std::vector<int>& b) {
  IntegerVector idx(no_init(a.size()));
  std::unordered_map<int, std::queue<int> > lut;
  for(int i = 0; i < b.size(); ++i) lut[b[i]].push(i);
  for(int i = 0; i < idx.size(); ++i) {
    auto search = lut.find(a[i]);
    if(search != lut.end() && search->second.size() > 0) {
      idx[i] = search->second.front() + 1;
      search->second.pop();
    } else {idx[i] = NA_INTEGER;}
  }
  return idx;
}
)")
pm(x, y)
#[1]  1  5 NA  2  3 NA

針對這種情況的專門RCPP版本。
創建一個長度為第一個向量最大值的向量，並計算一個值出現的次數。 創建另一個相同長度的queue向量，並在那里存儲第二個向量值的索引，直到它達到第一個向量的數量。 遍歷第一個向量的所有值並從queue中獲取索引。

Rcpp::sourceCpp(code=r"(
#include <Rcpp.h>
#include <vector>
#include <array>
#include <queue>
#include <algorithm>

using namespace Rcpp;
// [[Rcpp::export]]
IntegerVector pm2(const std::vector<int>& a, const std::vector<int>& b) {
  IntegerVector idx(no_init(a.size()));
  int max = 1 + *std::max_element(a.begin(), a.end());
  std::vector<int> n(max);
  for(int i = 0; i < a.size(); ++i) ++n[a[i]];
  std::vector<std::queue<int> > lut(max);
  for(int i = 0; i < b.size(); ++i) {
    if(b[i] < max && n[b[i]] > 0) {
      --n[b[i]];
      lut[b[i]].push(i);
    }
  }
  for(int i = 0; i < idx.size(); ++i) {
    auto & P = lut[a[i]];
    if(P.size() > 0) {
      idx[i] = P.front() + 1;
      P.pop();
    } else {idx[i] = NA_INTEGER;}
  }
  return idx;
}
)")
pm2(x,y)
#[1]  1  5 NA  2  3 NA

---

基准

set.seed(5)
x <- sample(5e3, 1e5, replace = TRUE)
y <- sample(x, replace = TRUE)

library(data.table)

matchall <- function(x, y) {
  data.table(y, rowid(y))[
    data.table(x, rowid(x)), on = .(y = x, V2), which = TRUE
  ]
}

rmatch <- function(x, y) {
  xp <- cbind(seq_along(x), x)[order(x),]
  yp <- cbind(seq_along(y), y)[order(y),]
  result <- numeric(length(x))
  
  xi <- yi <- 1
  Nx <- length(x)
  Ny <- length(y)
  while (xi <= Nx) {
    if (yi > Ny) {
      result[xp[xi,1]] <- NA
      xi <- xi + 1
    } else if (xp[xi,2] == yp[yi,2]) {
      result[xp[xi,1]] = yp[yi,1]
      xi <- xi + 1
      yi <- yi + 1
    } else if (xp[xi,2] < yp[yi,2]) {
      result[xp[xi,1]] <- NA
      xi <- xi + 1
    } else if (xp[xi,2] > yp[yi,2]) {
      yi <- yi + 1
    }
  }
  result  
}

bench::mark(
ave = ave(x, x, FUN = \(v) which(y == v[1])[1:length(v)]),
rmatch = rmatch(x, y),
make.name = match(make.names(x, TRUE), make.names(y, TRUE)),
paste = do.call(match, lapply(list(x, y), \(v) paste(v, ave(v, v, FUN = seq_along)))),
make.unique = match(make.unique(as.character(x)), make.unique(as.character(y))),
split = {a <- split(seq_along(x), x)
  b <- split(seq_along(y), y)[names(a)]
  b[lengths(b)==0] <- NA
  b <- unlist(Map(`length<-`, b, lengths(a)), FALSE, FALSE)
  `[<-`(b, unlist(a, FALSE, FALSE), b)},
data.table = matchall(x, y),
RCPP = pm(x, y),
RCPP2 = pm2(x, y)
)

結果

  expression       min   median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc
  <bch:expr>  <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl> <int> <dbl>
1 ave            1.66s    1.66s     0.603    3.73GB    68.7      1   114
2 rmatch      258.29ms 259.35ms     3.86     5.34MB    30.8      2    16
3 make.name   155.69ms 156.82ms     6.37    14.06MB     1.59     4     1
4 paste         93.8ms 102.06ms     9.74    18.13MB     7.79     5     4
5 make.unique  81.67ms   92.8ms    10.4      9.49MB     5.22     6     3
6 split        12.66ms  13.16ms    65.8      7.18MB    16.0     33     8
7 data.table    6.22ms   6.89ms   114.       5.13MB    28.0     57    14
8 RCPP          3.06ms    3.2ms   301.     393.16KB     3.98   151     2
9 RCPP2         1.64ms   1.82ms   514.     393.16KB     8.00   257     4

在這種情況下，C++ 版本最快，分配的數量最少，為 memory。在使用base的情況下，splitB 變體最快，rmatch 分配的數量最少，為 memory。

Answer 2

只是要指出，您可以使用match + make.unique來完成相同的任務。 速度方面，它可能比 data.table 方法慢：

match(make.unique(as.character(x)), make.unique(as.character(y)))

[1]  1  5 NA  2  3 NA

---

match(make.names(x, TRUE), make.names(y, TRUE))
[1]  1  5 NA  2  3 NA

Answer 3

受此問答啟發，使用data.table加入。

library(data.table)

matchall <- function(x, y) {
  data.table(y, rowid(y))[
    data.table(x, rowid(x)), on = .(y = x, V2), which = TRUE
  ]
}

檢查行為

x <- c(3L, 1L, 2L, 3L, 3L, 2L)
y <- c(3L, 3L, 3L, 3L, 1L, 3L)

matchall(x, y)
#> [1]  1  5 NA  2  3 NA

大向量上的時間：

set.seed(5)
x <- sample(5e3, 1e5, replace = TRUE)
y <- sample(x, replace = TRUE)

system.time(z1 <- matchall(x, y))
#>    user  system elapsed 
#>    0.06    0.00    0.01

system.time(z2 <- ave(x, x, FUN = \(v) which(y == v[1])[1:length(v)]))
#>    user  system elapsed 
#>    0.88    0.43    1.31

identical(z1, z2)
#> [1] TRUE

Answer 4

如果您有一些額外的 memory 可用，您可以通過對值進行排序並基本上進行兩指針遍歷來匹配數據來加快該過程。 這就是它的樣子

rmatch <- function(x, y) {
  xp <- cbind(seq_along(x), x)[order(x),]
  yp <- cbind(seq_along(y), y)[order(y),]
  result <- numeric(length(x))
  
  xi <- yi <- 1
  Nx <- length(x)
  Ny <- length(y)
  while (xi <= Nx) {
    if (yi > Ny) {
      result[xp[xi,1]] <- NA
      xi <- xi + 1
    } else if (xp[xi,2] == yp[yi,2]) {
      result[xp[xi,1]] = yp[yi,1]
      xi <- xi + 1
      yi <- yi + 1
    } else if (xp[xi,2] < yp[yi,2]) {
      result[xp[xi,1]] <- NA
      xi <- xi + 1
    } else if (xp[xi,2] > yp[yi,2]) {
      yi <- yi + 1
    }
  }
  result  
}

我測試了這里發布的其他一些基本 R 選項

mbm <- microbenchmark::microbenchmark(
  ave = ave(x, x, FUN = \(v) which(y == v[1])[1:length(v)]),
  rmatch = rmatch(x, y),
  pmatch = pmatch(x, y),
  times = 20
)

並且看到它似乎表現不錯

Unit: milliseconds
   expr        min         lq       mean     median         uq        max neval
    ave  1227.6743  1247.6980  1283.1024  1264.1485  1324.1569  1349.3276    20
 rmatch   198.1744   201.1058   208.3158   204.5933   209.4863   247.7279    20
 pmatch 39514.4227 39595.9720 39717.5887 39628.0892 39805.2405 40105.4337    20

這些都返回相同的值向量。

Answer 5

您可以簡單地運行match + paste + ave

> do.call(match, lapply(list(x, y), \(v) paste(v, ave(v, v, FUN = seq_along))))
[1]  1  5 NA  2  3 NA