Speed up loops used for finding match between dataframes

user_10049211 0
Viewed 109

I am trying to find potential matches between two data frames, based 3 criteria. I have setup a nested for loop, which for each row of DF1 to checks every row of DF2 using 3 IF statements as the checking criteria. If there is a match, the results (name from DF1 and ID for DF2) are captured in DF3. Due to the criteria it is possible to match some row multiple times. The code develop works and provides the output I am chasing, but it is too slow for the real datasets which are much larger. I have tried to vectorize the approach, but have failed (apply, lapply etc). Any advice on how to speed up this code would be greatly appreciated.

#create an empty dataframe to capture the matches
DF3 <- data.frame(name=integer(0), ID=integer(0)) 

set.seed(123)
DF1 <- data.frame(
  sort = rep(c("car", "tree", "bus", "house"), 3),
  Date1 = as.Date(c("01/02/15", "04/02/15", "04/03/15", "05/09/16", "01/04/15", "04/02/15", "04/06/15", "05/09/16",
                        "04/08/15", "05/10/16", "01/04/15", "04/02/15" ), format = "%d/%m/%y"), 
  Date2 = as.Date(c("07/02/15", "12/02/15", "14/03/15", "10/10/16", "02/04/15", "06/02/15", "04/06/15", "05/09/16",
                        "05/08/15", "07/10/16", "02/04/15", "05/02/15"), format = "%d/%m/%y"),
  word1 = c(1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 1, 0), 
  word2 = c(1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0), 
  name = sample.int(10000,12, replace = F)
)

DF2 <- data.frame(
  location = rep(c("car1", "tree2",  "business", "fox"), 3),
  start = as.Date(c("05/02/15", "06/02/15", "10/03/15", "10/01/17", "05/02/15", "05/02/15", "10/03/15", "10/01/17",
                        "05/02/15", "06/10/15", "10/03/15", "10/01/17"), format = "%d/%m/%y"),
  word1 = rep(c(1, 0), 6),
  word2 = rep(c(1, 0), 6),
  ID = sample.int(10000,12, replace = F)
)

i <- 0
j <- 0

for(j in 1:nrow(DF1)){ 
  for (i in 1:nrow(DF2)){ 
    if(grepl(DF1$sort[j], DF2$location[i])){ #check if the sort word appears with the location string
      if(between(DF2$start[i], DF1$Date1[j], DF1$Date2[j])){  #check if the start date is between Date1 and Date 2
        if(DF1$word1[j] + DF2$word1[i] == 2 | DF1$word2[j] + DF2$word2[i] == 2){ #check if there is 1 in both the word1 or word2 column
          temp <- data.frame(name=DF1$name[j], ID=DF2$ID[i]) 
          DF3 <- rbind(DF3, temp) 
        }
      }
    }
  }
}

Expected Output

  name   ID
1 2463 9145
2 2463 2567
3 2463 1614
4 8718 2888
5 8718 9982
6 8718 4469
nested-loops r pattern-matching performance
3 Answers

Here are two solutions that will be faster (in particular for larger datasets).

Option 1 - Non-equi join

library(tidyverse)
library(fuzzyjoin)
DF3 <- DF2 %>%
    fuzzy_inner_join(
        DF1,
        match_fun = list(str_detect, `>=`, `<=`),
        by = c("location" = "sort", "start" = "Date1", "start" = "Date2")) %>%
    filter(word1.x + word1.y == 2, word2.x + word2.y == 2) %>%
    select(name, ID)

Option 2 - Using crossing

library(tidyverse)
crossing(
    DF1 %>% rename(word1_DF1 = word1, word2_DF1 = word2), 
    DF2 %>% rename(word1_DF2 = word1, word2_DF2 = word2), 
    .name_repair = "unique") %>%
    filter(
        str_detect(location, sort),
        start >= Date1, start <= Date2,
        word1_DF1 + word1_DF2 == 2,
        word2_DF1 + word2_DF2 == 2) %>%
    select(name, ID)

I did some quick testing using microbenchmark and for 1000 row datasets, option 2 is 30 times faster than the nested for loop. Option 1 is around 4 times faster than the nested for loop. So it seems crossing is the way to go.

user_65309700

Here is a data.table solution that is much faster on larger data sets. The idea is to do the grep matching in a grouping operation on sort, then filter on the word and date conditions.

library(data.table)

set.seed(123)
# OP data
DF1 <- data.frame(
  sort = rep(c("car", "tree", "bus", "house"), 3),
  Date1 = as.Date(c("01/02/15", "04/02/15", "04/03/15", "05/09/16", "01/04/15", "04/02/15", "04/06/15", "05/09/16",
                    "04/08/15", "05/10/16", "01/04/15", "04/02/15" ), format = "%d/%m/%y"), 
  Date2 = as.Date(c("07/02/15", "12/02/15", "14/03/15", "10/10/16", "02/04/15", "06/02/15", "04/06/15", "05/09/16",
                    "05/08/15", "07/10/16", "02/04/15", "05/02/15"), format = "%d/%m/%y"),
  word1 = c(1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 1, 0), 
  word2 = c(1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0), 
  name = sample.int(10000,12, replace = F)
)

DF2 <- data.frame(
  location = rep(c("car1", "tree2",  "business", "fox"), 3),
  start = as.Date(c("05/02/15", "06/02/15", "10/03/15", "10/01/17", "05/02/15", "05/02/15", "10/03/15", "10/01/17",
                    "05/02/15", "06/10/15", "10/03/15", "10/01/17"), format = "%d/%m/%y"),
  word1 = rep(c(1, 0), 6),
  word2 = rep(c(1, 0), 6),
  ID = sample.int(10000,12, replace = F)
)

# OP `for` loop solution
f1 <- function(DF1, DF3) {
  #create an empty dataframe to capture the matches
  DF3 <- data.table(name=integer(0), ID=integer(0))
  
  for(j in 1:nrow(DF1)){ 
    for (i in 1:nrow(DF2)){ 
      if(grepl(DF1$sort[j], DF2$location[i])){ #check if the sort word appears with the location string
        if(between(DF2$start[i], DF1$Date1[j], DF1$Date2[j])){  #check if the start date is between Date1 and Date 2
          if(DF1$word1[j] + DF2$word1[i] == 2 | DF1$word2[j] + DF2$word2[i] == 2){ #check if there is 1 in both the word1 or word2 column
            DF3 <- rbind(DF3, data.table(name=DF1$name[j], ID=DF2$ID[i]) ) 
          }
        }
      }
    }
  }
  DF3
}

# proposed solution
f2 <- function(DF1, DF2) {
  setDT(DF1)[
    , {
      idx <- grep(.BY, DF2$location)
      
      if (length(idx)) {
        cbind(
          .SD[rep(1:.N, each = length(idx))],
          setnames(
            DF2[rep.int(idx, .N), -1],
            c("word1", "word2"),
            c("word21", "word22")
          )
        )
      }
    },
    sort
  ][
    (word1 + word21 == 2 | word2 + word22 == 2) & between(start, Date1, Date2),
    c("name", "ID")
  ]
}

Benchmarking on the small dataset isn't very meaningful.

microbenchmark::microbenchmark(f1 = f1(DF1, DF2),
                               f2 = f2(DF1, DF2),
                               check = "identical")
#> Unit: milliseconds
#>  expr    min      lq    mean  median      uq    max neval
#>    f1 1.9614 2.09825 2.31616 2.23715 2.32665 4.1783   100
#>    f2 2.1224 2.25095 2.43435 2.32065 2.39875 4.6707   100

Benchmarking on a somewhat larger dataset:

n <- 1e3L
Date1 <- sample(seq(as.Date("2022/07/01"), as.Date("2022/07/31"), by = "day"), n, TRUE)

DF1 <- data.frame(
  sort = stringi::stri_rand_strings(n, 2L, pattern = "[a-z]"),
  Date1 = Date1, 
  Date2 = Date1 + sample.int(10, n, TRUE),
  word1 = sample(0:1, n, TRUE), 
  word2 = sample(0:1, n, TRUE), 
  name = sample.int(1e4, n)
)

DF2 <- data.frame(
  location = paste0("^(", stringi::stri_rand_strings(n, 2L, pattern = "[a-z]"), ")$"),
  start = sample(seq(as.Date("2022/07/01"), as.Date("2022/07/31"), by = "day"), n, TRUE),
  word1 = sample(0:1, n, TRUE), 
  word2 = sample(0:1, n, TRUE), 
  ID = sample.int(1e4, n)
)

microbenchmark::microbenchmark(f1 = setorder(f1(DF1, DF2)),
                               f2 = setorder(f2(DF1, DF2)),
                               times = 1L,
                               check = "identical")
#> Unit: milliseconds
#>  expr       min        lq      mean    median        uq       max neval
#>    f1 3939.8929 3939.8929 3939.8929 3939.8929 3939.8929 3939.8929     1
#>    f2  239.5953  239.5953  239.5953  239.5953  239.5953  239.5953     1
user_94634890

I found the following to be very quick and simple to follow

DF3 <- DF2 %>% 
  regex_inner_join(DF1, by=c("location" = "sort"), ignore_case=TRUE) %>%
  filter(word1.x & word1.y | word2.x & word2.y) %>%
  filter(between(start, Date1, Date2)) %>%  #1334
  select(name, ID)
user_100492110
Related