英文:
Efficiently match all values of a vector in another vector
问题
我正在寻找一种高效的方法,可以匹配向量x
中的所有值,而不仅仅是第一个位置,就像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)
英文:
I'm looking to find an efficient method of matching all values of vector x
in vector y
rather than just the first position, as is returned by match()
. What I'm after essentially is the default behavior of pmatch()
but without partial matching:
x <- c(3L, 1L, 2L, 3L, 3L, 2L)
y <- c(3L, 3L, 3L, 3L, 1L, 3L)
Expected output:
pmatch(x, y)
[1] 1 5 NA 2 3 NA
One way is to use ave()
however this becomes slow and very memory inefficient as the number of groups increases:
ave(x, x, FUN = \(v) which(y == v[1])[1:length(v)])
[1] 1 5 NA 2 3 NA
Can anyone recommend an efficient way to achieve this in preferably (but not mandatory) base R?
Larger dataset for benchmarking:
set.seed(5)
x <- sample(5e3, 1e5, replace = TRUE)
y <- sample(x, replace = TRUE)
答案1
得分: 9
在这个代码部分中,你尝试了不同的方法来处理两个向量的匹配和索引问题。以下是你提到的几个部分的翻译:
- 在 base 中使用
split
进行变体。
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
- 你尝试用 RCPP 版本来优化匹配。
Rcpp::sourceCpp(code="
#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 版本。
Rcpp::sourceCpp(code="
#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
请注意,这些代码段都是用于优化匹配的不同方法,包括使用了 base,RCPP 和优化的 RCPP 版本。如果你需要更多的翻译或解释,请随时提出。
英文:
A variant in base using split
.
split
the indices of both vectors by its value. Subset the second list with the names of the first, that both have the same order. Change NULL
to NA
and bring the lengths of the second list to those from the first. Reorder the indices of the second list by those of the first.
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
I tried to exchange the part
b <- split(seq_along(y), y)[names(a)]
b[lengths(b)==0] <- NA
with
b <- list2env(split(seq_along(y), y))
b <- mget(names(a), b, ifnotfound = NA)
But it was not faster.
An RCPP version.
Store the indices of the second vector ín a queue
for each unique value in an unordered_map
. Iterate over all values of the first vector and take the indices from the 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
A for this case specialized RCPP version.
Create a vector of the length of the maximum value of the first vector and count how many times a value is present. Create another queue
vector of the same length and sore there the indices of the values of the second vector until it has reached the number of the first. Iterate over all values of the first vector and take the indices from the 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
Benchmark
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)
)
Result
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
In this case the C++ version is the fastest and allocates the lowest amount of memory. In case using base the splitB variant is the fastest and rmatch allocates the lowest amount of memory.
答案2
得分: 7
只是指出,您可以使用 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
英文:
Just to point out, you can use match + make.unique
to accomplish the same. Speedwise, it might be slower than the data.table approach:
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
答案3
得分: 6
使用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
英文:
Using a data.table
join, inspired by this Q&A.
library(data.table)
matchall <- function(x, y) {
data.table(y, rowid(y))[
data.table(x, rowid(x)), on = .(y = x, V2), which = TRUE
]
}
Check behavior
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
Timing on larger vectors:
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
答案4
得分: 4
如果您有额外的内存可用,可以通过对值进行排序并基本上进行两个指针的遍历来加速该过程,以匹配数据。以下是示例代码:
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
这些都返回相同的值向量。
英文:
If you have some extra memory to spare, you can speed up the process by sorting the values and basically doing a two-pointer walk through to match up the data. Here's what what would look like
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
}
I tested with some of the other base R options posted here
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
)
And saw that it seemed to perform well
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
These all return the same vector of values.
答案5
得分: 2
你可以简单地运行 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
英文:
You can simply run 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
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论