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

user_9995643 0
Viewed 179

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
r string performance
4 Answers

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
user_121587570

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
user_126219430

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.

user_135133280

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.

user_39629140
Related