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

Question

我正在寻找一种有效的x方法来匹配向量中向量的所有值，y而不仅仅是第一个位置，如match(). 我本质上追求的是默认行为pmatch()，但没有部分匹配：

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

预期输出：

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

一种方法是使用ave()，但是随着组数量的增加，这会变得很慢并且内存效率很低：

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

任何人都可以推荐一种有效的方法来在优选（但不是强制）的基础 R 中实现这一目标吗？

用于基准测试的更大数据集：

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

Answer 1

使用.base的一个变体split。
\nsplit两个向量的索引（按其值）。将第二个列表的名称作为第一个列表的子集，两者的顺序相同。NULL将NA第二个列表的长度更改为第一个列表的长度。按第一个列表的索引重新排序第二个列表的索引。

\n

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

\n

我尝试更换零件

\n

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

\n

和

\n

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

\n

但速度并没有更快。

\n

RCPP版本。
\n将第二个向量 \xc3\xadn a 的queue每个唯一值的索引存储在unordered_map. 迭代第一个向量的所有值并从 中获取索引queue。

\n

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

\n

针对这种情况的专门RCPP版本。
\n创建第一个向量最大值长度的向量，并计算某个值出现的次数。创建另一个queue相同长度的向量，并计算第二个向量的值的索引，直到它达到第一个向量的编号。迭代第一个向量的所有值并从 中获取索引queue。

\n

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

\n\n

基准

\n

set.seed(5)\nx <- sample(5e3, 1e5, replace = TRUE)\ny <- sample(x, replace = TRUE)\n\nlibrary(data.table)\n\nmatchall <- function(x, y) {\n  data.table(y, rowid(y))[\n    data.table(x, rowid(x)), on = .(y = x, V2), which = TRUE\n  ]\n}\n\nrmatch <- function(x, y) {\n  xp <- cbind(seq_along(x), x)[order(x),]\n  yp <- cbind(seq_along(y), y)[order(y),]\n  result <- numeric(length(x))\n  \n  xi <- yi <- 1\n  Nx <- length(x)\n  Ny <- length(y)\n  while (xi <= Nx) {\n    if (yi > Ny) {\n      result[xp[xi,1]] <- NA\n      xi <- xi + 1\n    } else if (xp[xi,2] == yp[yi,2]) {\n      result[xp[xi,1]] = yp[yi,1]\n      xi <- xi + 1\n      yi <- yi + 1\n    } else if (xp[xi,2] < yp[yi,2]) {\n      result[xp[xi,1]] <- NA\n      xi <- xi + 1\n    } else if (xp[xi,2] > yp[yi,2]) {\n      yi <- yi + 1\n    }\n  }\n  result  \n}\n\nbench::mark(\nave = ave(x, x, FUN = \\(v) which(y == v[1])[1:length(v)]),\nrmatch = rmatch(x, y),\nmake.name = match(make.names(x, TRUE), make.names(y, TRUE)),\npaste = do.call(match, lapply(list(x, y), \\(v) paste(v, ave(v, v, FUN = seq_along)))),\nmake.unique = match(make.unique(as.character(x)), make.unique(as.character(y))),\nsplit = {a <- split(seq_along(x), x)\n  b <- split(seq_along(y), y)[names(a)]\n  b[lengths(b)==0] <- NA\n  b <- unlist(Map(`length<-`, b, lengths(a)), FALSE, FALSE)\n  `[<-`(b, unlist(a, FALSE, FALSE), b)},\ndata.table = matchall(x, y),\nRCPP = pm(x, y),\nRCPP2 = pm2(x, y)\n)\n

\n

结果

\n

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

\n

在这种情况下，C++ 版本是最快的并且分配的内存量最少。如果使用base， splitB 变体是最快的，而 rmatch 分配的内存量最少。

\n

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