The matchName1 and parMatchName1 functions below are non-parallel and parallel solutions that avoid the cartesian join in langtang's answer and improve on its performance (both time and memory) by about an order of magnitude on very large data.tables.
The idea is to "collapse" then join the data.tables by last name, which avoids going cartesian (inspect the output of the collapseName function to see what I mean). data.table does this so efficiently that the vast majority of time is spent in grepl. There are certainly faster algorithms to perform the needed comparisons being performed by grepl, but I'm not aware of any package that offers essentially a vectorized outer version of grepl. If one exists, I wouldn't be surprised if it could speed up processing by another order of magnitude.
First, the functions:
library(data.table)
library(stringi)
library(parallel)
vgrepi <- function(str, pattern) {
# Searches for each value in "pattern" in each value in "str".
# Returns a list of two equal-length vectors of (str, pattern) indices where
# "pattern" is found in "str".
# Accepts vectors for both "str" and "pattern".
lall <- vector("list", length(pattern))
for (i in seq_along(pattern)) lall[[i]] <- grep(pattern[i], str)
list(rep.int(seq_along(pattern), lengths(lall)), unlist(lall))
}
collapseName <- function(dt1, dt2) {
# collapse "dt1" and "dt2" by "lname1" and "lname2" then join on "lname1 =
# lname2"
dt1[
, .(id1 = .(id1), fnreg1 = .(fnreg1)), lname1
][
dt2[, .(id2 = .(id2), fname2 = .(fname2)), lname2],
`:=`(id2 = i.id2, fname2 = i.fname2),
on = .(lname1 = lname2)
]
}
getMatches <- function(dt) {
# returns a data.table of full-name matches
dt[
, {
idx <- vgrepi(fname2[[1]], fnreg1[[1]])
if (length(idx[[1]])) {
data.table(
id1 = id1[[1]][idx[[1]]],
fnreg1 = fnreg1[[1]][idx[[1]]],
id2 = id2[[1]][idx[[2]]],
fname2 = fname2[[1]][idx[[2]]]
)
} else NULL
},
lname1
]
}
matchName1 <- function(dt1, dt2) {
setorder(getMatches(collapseName(dt1, dt2)), id1, id2)
}
parMatchName1 <- function(dt1, dt2, ncl = detectCores() - 1L) {
# parallel version of matchName1
cl <- makeCluster(ncl)
on.exit(stopCluster(cl))
dt3 <- collapseName(dt1, dt2)[
# assign each row a node; attempt to balance by number of grepl comparisons
, node := rep(c(1:ncl, ncl:1), ceiling(.N/ncl/2))[1:.N][rank(-lengths(fnreg1)*lengths(fname2), ties.method = "first")]
]
clusterEvalQ(cl, {library(data.table); library(stringi)})
idx <- 1:(ncol(dt3) - 1L)
for (i in seq_along(cl)) {
# pass only the needed portion of "dt3" to each node
dt4 <- dt3[node == i, ..idx]
clusterExport(cl[i], "dt4", environment())
}
rm("dt3", "dt4")
clusterExport(cl, c("getMatches", "vgrepi"))
# don't use parLapply as below--it is really slow for some reason
# setorder(rbindlist(parLapply(cl, seq_along(cl), function(i) getMatches(dt4))), id1, id2)
setorder(rbindlist(clusterEvalQ(cl, getMatches(dt4))), id1, id2)
}
matchName2 <- function(dt1, dt2) {
# langtang's cartesian join solution (with sorting and column re-ordering to
# match the output of "matchName1")
setorder(dt1[dt2, on = .(lname1 = lname2), allow.cartesian = TRUE][, .SD[grepl(.BY, fname2)], fnreg1][, c(3:1, 4:5)], id1, id2)
}
Now the smaller example data:
# OP example data set
set.seed(1)
n1 <- 1e4
n2 <- 1e5
dt1 <- data.table(id1 = sprintf("A%s", 1:n1),
fnreg1 = paste0("^(", stringi::stri_rand_strings(n = n1, length = 2, pattern = "[a-z]"), ")$"),
lname1 = stringi::stri_rand_strings(n = n1, length = 2, pattern = "[a-z]"))
dt2 <- data.table(id2 = sprintf("B%s", 1:n2),
fname2 = stringi::stri_rand_strings(n = n2, length = 2, pattern = "[a-z]"),
lname2 = stringi::stri_rand_strings(n = n2, length = 2, pattern = "[a-z]"))
And benchmarking:
microbenchmark::microbenchmark(matchName1 = matchName1(dt1, dt2),
parMatchName1 = parMatchName1(dt1, dt2),
matchName2 = matchName2(dt1, dt2),
check = "equal",
times = 10L)
#> Unit: milliseconds
#> expr min lq mean median uq max neval
#> matchName1 202.9344 208.0844 237.0543 236.0003 265.3224 270.3858 10
#> parMatchName1 756.9239 780.6850 859.9187 843.9129 887.5163 1103.2233 10
#> matchName2 383.2535 417.7220 442.6772 435.9115 471.2729 537.4580 10
For the smaller data sets, the overhead involved in setting up parallel processing dominates the timings, but for much larger data sets, the parallel option gives a considerable speed boost.
# much larger test data set with 3-character names
set.seed(1)
n1 <- 5e5
n2 <- 18e6
dt1 <- data.table(id1 = sprintf("A%s", 1:n1),
fnreg1 = paste0("^(", stringi::stri_rand_strings(n = n1, length = 3, pattern = "[a-z]"), ")$"),
lname1 = stringi::stri_rand_strings(n = n1, length = 3, pattern = "[a-z]"))
dt2 <- data.table(id2 = sprintf("B%s", 1:n2),
fname2 = stringi::stri_rand_strings(n = n2, length = 3, pattern = "[a-z]"),
lname2 = stringi::stri_rand_strings(n = n2, length = 3, pattern = "[a-z]"))
Timings:
# set up matrix to store memory usage
memUsage <- matrix(nrow = 2, ncol = 3, dimnames = list(c("Ncels", "Vcells"), c("matchName1", "parMatchName1", "matchName2")))
invisible(gc(reset = TRUE))
system.time(matchName1(dt1, dt2))
#> user system elapsed
#> 48.61 0.44 48.90
memUsage[, 1] <- gc()[,6]
invisible(gc(reset = TRUE))
system.time(parMatchName1(dt1, dt2))
#> user system elapsed
#> 7.69 1.69 26.67
memUsage[, 2] <- gc()[,6]
invisible(gc(reset = TRUE))
system.time(matchName2(dt1, dt2))
#> user system elapsed
#> 205.13 51.36 255.99
memUsage[, 3] <- gc()[,6]
Memory usage (in MBs):
memUsage
#> matchName1 parMatchName1 matchName2
#> Ncels 1311.8 1100.5 1846.9
#> Vcells 1792.3 1325.9 26659.9
