Does Column of Sentences Contain Word in Another Column of Sentences? - r

Question

I have two large tables each containing a "sentence" column with a string of words. I am curious which records (true/false output) have a word that is found in any of the sentences in either column. My tables are very large and the below code I have can take a very long time. Is there a faster way to go about doing this?
Thank you!
# Determine if any "words" in either column of sentences match.
# Packages
library(tidyverse)
# Help functions
helper_in_2 <- function(b, a){
return(any(b %in% a))
}
helper_in <- function(a, b){
return(lapply(b, helper_in_2, a))
}
# Sample columns
sentence_col_a <- c("This is an example sentence.", "Here is another sample sentence?", "One more sentence that is not complicated.", "Last sentence to show an example!")
sentence_col_b <- c("Short string A.", "Another longer string.", "Final string example!")
# Extract words from each column
list_col_a <- str_to_lower(sentence_col_a) %>%
str_extract_all("[:alpha:]+")
list_col_b <- str_to_lower(sentence_col_b) %>%
str_extract_all("[:alpha:]+")
# Check for matches.
# (Code after first line isn't actually used in my code - it's just to show matches)
sapply(lapply(list_col_a, helper_in, list_col_b), as.numeric) %>%
t() %>%
as.data.frame() %>%
rename_at(vars(names(.)), function(x) sentence_col_b) %>%
mutate(rownames = sentence_col_a) %>%
tibble::column_to_rownames(var = "rownames")
Output:
Sentences
Short string A.
Another longer string.
Final string example!
This is an example sentence.
0
0
1
Here is another sample sentence?
0
1
0
One more sentence that is not complicated.
0
0
0
Last sentence to show an example!
0
0
1
Update after Ronak's Answer
library(microbenchmark)
microbenchmark("Original method:" = sapply(lapply(list_col_a, helper_in, list_col_b), as.numeric),
"Ronak's method:" = sapply(list_col_a, function(x) as.integer(grepl(sprintf('\\b(%s)\\b', paste0(x, collapse = '|')), list_col_b))))
#Unit: microseconds
# expr min lq mean median uq max neval
#Original method: 72.9 76.65 88.082 82.35 86.1 173.9 100
# Ronak's method: 262.1 277.40 354.741 286.40 348.6 3724.3 100

Answer 1

Here I can provide several options, but the nested for-loop method might be the most efficient one so far:
outer
TIC1 <- function() {
+outer(list_col_a, list_col_b, FUN = Vectorize(function(x, y) any(x %in% y)))
}
nested sapply
TIC2 <- function() {
sapply(
list_col_b,
function(x) {
sapply(
list_col_a,
function(y) sum(y %in% x)
)
}
)
}
nested for loops
TIC3 <- function() {
res <- matrix(nrow = length(list_col_a), ncol = length(list_col_b))
for (a in seq_along(list_col_a)) {
for (b in seq_along(list_col_b)) {
res[a, b] <- any(list_col_a[[a]] %in% list_col_b[[b]])
}
}
+res
}
Benchmarking
# Original solution
original <- function() {
sapply(lapply(list_col_a, helper_in, list_col_b), as.numeric) %>%
t() %>%
as.data.frame() %>%
rename_at(vars(names(.)), function(x) sentence_col_b) %>%
mutate(rownames = sentence_col_a) %>%
tibble::column_to_rownames(var = "rownames")
}
# Waldi's data.table solution
Waldi <- function() {
la <- data.table(id = 1:length(list_col_a), list_col_a)
lb <- data.table(id = 1:length(list_col_b), list_col_b)
la_long <- la[, .(words = unlist(list_col_a)), by = id]
lb_long <- lb[, .(words = unlist(list_col_b)), by = id]
unique(la_long[lb_long, on = .(words = words)][!is.na(id), .(idxa = id, idxb = i.id)])
}
mustafaakben1 <- function(rows = list_col_a, cols = list_col_b) {
to_matrix <- function(X_t) {
matrix(unlist(X_t),
nrow = length(list_col_a),
ncol = length(list_col_b),
byrow = T
)
}
to_matrix(lapply(
1:length(cols),
FUN = function(X) {
lapply(
X = 1:length(rows),
FUN = function(Y) {
sum(rows[[Y]] %in% cols[[X]])
}
)
}
))
}
library(fastmatch)
mustafaakben2 <- function() {
search_keywords <- unlist(list_col_b)[unlist(list_col_b) %in% unlist(list_col_a)]
b_col_filter <- which(unlist(lapply(list_col_b, function(X) any(X %in% search_keywords))))
a_row_filter <- which(unlist(lapply(list_col_a, function(X) any(X %in% search_keywords))))
res <- matrix(0,
nrow = length(list_col_a),
ncol = length(list_col_b)
)
for (a in a_row_filter) {
for (b in b_col_filter) {
res[a, b] <- any(list_col_a[[a]] %fin% list_col_b[[b]])
}
}
+res
}
# ThomasIsCoding's outer solution
TIC1 <- function() {
+outer(list_col_a, list_col_b, FUN = Vectorize(function(x, y) any(x %in% y)))
}
TIC2 <- function() {
sapply(
list_col_b,
function(x) {
sapply(
list_col_a,
function(y) sum(y %in% x)
)
}
)
}
TIC3 <- function() {
res <- matrix(nrow = length(list_col_a), ncol = length(list_col_b))
for (a in seq_along(list_col_a)) {
for (b in seq_along(list_col_b)) {
res[a, b] <- any(list_col_a[[a]] %in% list_col_b[[b]])
}
}
+res
}
microbenchmark::microbenchmark(
original(),
Waldi(),
mustafaakben1(),
mustafaakben2(),
TIC1(),
TIC2(),
TIC3(),
unit = "relative"
)
and you will see
Unit: relative
expr min lq mean median uq max
original() 172.895884 149.346066 49.841448 142.676077 134.111459 3.130206
Waldi() 107.441122 92.004380 30.290680 88.474026 83.690267 1.971249
mustafaakben1() 1.596981 1.551978 1.646884 1.610160 1.553021 1.683034
mustafaakben2() 1.635812 1.731991 2.186106 1.912535 1.831179 2.332797
TIC1() 3.854043 3.845866 1.977066 3.943445 3.707308 1.041416
TIC2() 2.888118 2.627955 1.607401 2.719427 2.538536 1.142211
TIC3() 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000
neval
100
100
100
100
100
100
100

Answer 2

Try nested lappy
to_matrix <- function(X_t){
matrix(unlist(X_t),
nrow = length(list_col_a),
ncol = length(list_col_b)),
byrow = T)
}
nested_lappy <- function(rows=list_col_a, cols=list_col_b) {
to_matrix(lapply(
1:length(cols),
FUN = function (X)
lapply(
X = 1:length(rows),
FUN = function(Y)
sum(rows[[Y]] %in% cols[[X]])
)
))
}
> nested_lappy()
[,1] [,2] [,3]
[1,] 0 0 1
[2,] 0 1 0
[3,] 0 0 0
[4,] 0 0 1
Probably your matrix will be huge too. It would be better to use a sparse matrix. You can try to use the Matrix package. It may help you to carry out your analysis in a more memory-efficient way.
Here is the benchmark
microbenchmark::microbenchmark(
original(),
Waldi(),
TIC(),
nested_lappy(),
unit = "relative"
)
Unit: relative
expr min lq mean median uq max neval
original() 99.97881 89.869163 83.011249 67.88434 69.883301 260.704657 100
Waldi() 56.55076 51.185905 45.436361 39.35327 42.730942 46.438114 100
TIC() 2.27000 2.249311 1.986625 1.84108 1.837013 3.974149 100
nested_lappy() 1.00000 1.000000 1.000000 1.00000 1.000000 1.000000 100
Edits
I will cheat here a little bit because #ThomasIsCoding is an amazing coder. I need to cheat :)
So, because you have a huge table, you need to focus on an efficient way to search your keyword space. As you may notice that not all keywords have an intersection and shared uniformly in the sentences. So, even before starting to search, you can eliminate those sentences in the search space. By doing so, we can focus only on the words shared by both column and row dimensions.
search_keywords<- unlist(list_col_b)[unlist(list_col_b) %in% unlist(list_col_a)]
b_col_filter <- which(unlist(lapply(list_col_b, function(X) any(X %in% search_keywords))))
a_row_filter <- which(unlist(lapply(list_col_a, function(X) any(X %in% search_keywords))))
Then, use the fastmatch package to make the %in% faster.
library(fastmatch)
mustafaakben2 <- function() {
res <- matrix(0,
nrow = length(list_col_a),
ncol = length(list_col_b))
for (a in a_row_filter) {
for (b in b_col_filter) {
res[a, b] <- any(list_col_a[[a]] %fin% list_col_b[[b]])
}
}
+res
}
> mustafaakben2()
[,1] [,2] [,3]
[1,] 0 0 1
[2,] 0 1 0
[3,] 0 0 0
[4,] 0 0 1
Benchmark results
microbenchmark::microbenchmark(
original(),
Waldi(),
TIC1(),
TIC2(),
TIC3(),
mustafaakben(),
mustafaakben2(),
unit = "relative"
)
Unit: relative
expr min lq mean median uq max neval cld
original() 288.620155 254.429012 193.446439 190.457965 171.914286 115.0415822 100 c
Waldi() 182.751938 153.864198 115.182908 115.778761 103.518095 36.9411765 100 b
TIC1() 6.581395 6.277778 5.074523 5.066372 4.685714 2.3732252 100 a
TIC2() 4.705426 4.385802 3.503269 3.466814 3.281905 1.5811359 100 a
TIC3() 1.767442 1.685185 1.360847 1.338496 1.249524 0.7728195 100 a
mustafaakben() 2.589147 2.330247 1.944260 2.017699 1.864762 0.7322515 100 a
mustafaakben2() 1.000000 1.000000 1.000000 1.000000 1.000000 1.0000000 100 a

Answer 3

You could use a data.table join to get the id of the matching sentences.
library(data.table)
# Original solution
original <- function(){
sapply(lapply(list_col_a, helper_in, list_col_b), as.numeric) %>%
t() %>%
as.data.frame() %>%
rename_at(vars(names(.)), function(x) sentence_col_b) %>%
mutate(rownames = sentence_col_a) %>%
tibble::column_to_rownames(var = "rownames")
}
# data.table solution
new <- function(){
la <- data.table(id = 1:length(list_col_a),list_col_a)
lb <- data.table(id = 1:length(list_col_b),list_col_b)
la_long <- la[,.(words=unlist(list_col_a)),by= id]
lb_long <- lb[,.(words=unlist(list_col_b)),by= id]
unique(la_long[lb_long, on=.(words=words)][!is.na(id),.(idxa=id, idxb = i.id)])
}
new()
idxa idxb
1: 2 2
2: 1 3
3: 4 3
microbenchmark::microbenchmark(original(),new())
Unit: milliseconds
expr min lq mean median uq max neval cld
original() 4.1623 5.1190 5.857155 5.5528 6.18345 23.5442 100 b
new() 2.2492 2.7993 3.255741 3.1298 3.68645 5.1872 100 a
As data.table allows indexing, this could be much more efficient on a higher number of sentences / words : to be tested on a bigger dataset.

Answer 4

With the help of regular expressions, you can do this with one sapply call. We create a pattern with each value in list_col_a and check if any of it exists in list_col_b.
sapply(list_col_a, function(x) as.integer(grepl(sprintf('\\b(%s)\\b',
paste0(x, collapse = '|')), list_col_b)))
# [,1] [,2] [,3] [,4]
#[1,] 0 0 0 0
#[2,] 0 1 0 0
#[3,] 1 0 0 1
You can include your remaining code as it is to get the matches.