Keep which(..., arr.ind = TRUE) results that connect

This is a perfect problem for Rcpp. Observe:

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
IntegerMatrix findConnections(IntegerMatrix m) {
    int i = 0, j = 0, k = 1, n = m.nrow();

    // initialize matrix with same dimensions as m
    IntegerMatrix myConnections(n, 2);

    while (i < n) {
        // Populate with "connected" row
        myConnections(j,_) = m(i,_);

        // Search for next connection
        while (k < n && m(i, 1) != m(k, 0)) {k++;}
        i = k;
        j++;
    }

    // Subset matrix and output result
    IntegerMatrix subMatrix(j, 2);
    for (i = 0; i < j; i++) {subMatrix(i,_) = myConnections(i,_);}

    return subMatrix;
}


findConnections(as.matrix(example3))
     [,1] [,2]
[1,]    1    3
[2,]    3    5
[3,]    5    6
[4,]    6    8

Here are the benchmarks on example3 provided by the OP:

microbenchmark(get_path(example3),
               foo(example3),
               f(example3),
               findConnections(as.matrix(example3)))
Unit: microseconds
                                expr      min        lq       mean   median        uq        max neval cld
                  get_path(example3) 3345.999 3519.0255 6361.76978 3714.014 3892.9930 202511.942   100   b
                       foo(example3)  215.514  239.3230  360.81086  257.180  278.3200  10256.384   100  a 
                         f(example3)  936.355 1034.4645 1175.60323 1073.668 1142.4270   9676.755   100  a 
findConnections(as.matrix(example3))   52.135   60.3445   71.62075   67.528   80.4585    103.858   100  a 

Here are some benchmarks on a larger example (didn't include get_graph as it was taking a very long time):

set.seed(6221)
x <- as.matrix(cbind(x = rnorm(1000, 10, 3), y =  rnorm(1000, 10, 3)))
value = 5
d <- as.matrix(dist(x[,c("x","y")]))
d[lower.tri(d)] <- 0
mtxLarge <- which(d > value, arr.ind = T)
mtxLargeFoo <- data.frame(mtxLarge, row.names = NULL) ## this is for the function foo
                                            ## as we don't want to include
                                            ## the time it takes to create
                                            ## a data.frame every time.

microbenchmark(foo(mtxLargeFoo),
               f(mtxLarge),
               findConnections(as.matrix(mtxLarge)), times = 10, unit = "relative")
Unit: relative
                                expr      min       lq     mean   median       uq      max neval cld
                    foo(mtxLargeFoo) 3168.479 3376.909 2660.377 3424.276 2319.434 1960.161    10  b 
                         f(mtxLarge) 8307.009 8436.569 6420.919 8319.151 5184.557 4610.922    10   c
findConnections(as.matrix(mtxLarge))    1.000    1.000    1.000    1.000    1.000    1.000    10 a  

Test for equality:

a <- findConnections(as.matrix(mtxLarge))
b <- foo(mtxLargeFoo)
c <- f(mtxLarge)
sapply(1:2, function(x) identical(a[,x], b[,x], c[, x]))
[1] TRUE TRUE


UPDATE
If Rcpp isn't your flavor, here is a Base R translation of the above code that is still faster than the other solutions:

findConnectionsBase <- function(m) {
    n <- nrow(m)
    myConnections <- matrix(integer(0), nrow = n, ncol = 2)
    i <- j <- 1L
    k <- 2L
    while (i <= n) {
        myConnections[j, ] <- m[i, ]
        while (k <= n && m[i, 2] != m[k, 1]) {k <- k + 1L}
        i <- k
        j <- j + 1L
    }
    myConnections[!is.na(myConnections[,1]), ]
}

microbenchmark(get_path(example3),
           foo(example3),
           f(example3),
           BaseR = findConnectionsBase(as.matrix(example3)),
           Rcpp = findConnections(as.matrix(example3)))
Unit: microseconds
              expr      min        lq       mean   median       uq        max neval cld
get_path(example3) 3128.844 3204.3765 6057.18995 3406.137 3849.274 188685.016   100   b
     foo(example3)  239.734  251.4325  399.71418  267.648  301.309  12455.441   100  a 
       f(example3)  899.409  961.3950 1145.72695 1014.555 1127.237   9583.982   100  a 
             BaseR   79.638   89.2850  103.63571   97.905  111.657    212.230   100  a 
              Rcpp   48.850   55.8290   64.24807   61.781   69.170    123.151   100  a 

And for the larger example:

microbenchmark(foo(mtxLargeFoo),
               f(mtxLarge),
               BaseR = findConnectionsBase(as.matrix(mtxLarge)),
               Rcpp = findConnections(as.matrix(mtxLarge)), times = 10, unit = "relative")
               Unit: relative
            expr       min        lq      mean    median        uq       max neval  cld
foo(mtxLargeFoo) 2651.9626 2555.0515 1606.2785 1703.0256 1711.4850  671.9115    10   c 
     f(mtxLarge) 6812.7195 6433.2009 3976.6135 4218.1703 4105.1138 1642.2768    10    d
           BaseR  787.9947  733.4528  440.2043  478.9412  435.4744  167.7491    10  b  
            Rcpp    1.0000    1.0000    1.0000    1.0000    1.0000    1.0000    10 a   

Here is an idea using igraph package along with zoo,

get_path <- function(df){
  g1 <- graph_from_data_frame(df)
  l1 <- all_simple_paths(g1, 1)
  ind1 <- as.numeric(names(l1[[which.max(lengths(l1))]]))
  final_df <- setNames(as.data.frame(rollapply(ind1, 2, c)), 
                       c('row', 'col'))
  return(final_df)
}

which gives the following,

library(igraph)
library(zoo)
 get_path(example1)
 row col
1   1   4
2   4   5

get_path(example2)
  row col
1   2   3
2   3   5
3   5   7

get_path(example3)
  row col
1   1   3
2   3   5
3   5   6
4   6   8

FUNCTION

foo = function(df){
    #Initiate with a value of 1 (first row)
    inds = 1
    while(TRUE){
        # Look for the first index where the 'row' is equal to the value
        # in 'col' at the index specified by the last value of 'inds'
        temp = tail(inds, 1)
        ind = temp + which(df[["row"]][(temp+1):NROW(df)] == df[["col"]][temp])[1]

        #Append 'ind' to 'inds'
        inds = c(inds, ind)

        #Iterate until the end of the rows or when NA is encountered
        if (ind == NROW(df) | is.na(ind)){
            #Return the subset of the df with appropirate rows
            return(df[inds[!is.na(inds)],])
        }
    }
}

USAGE

foo(example1)
#  row col
#1   1   4
#3   4   5

foo(example2)
#  row col
#1   2   3
#3   3   5
#7   5   7

foo(example3)
#  row col
#1   1   3
#3   3   5
#5   5   6
#6   6   8

foo(data.frame(mtx, row.names = NULL))
#   row col
#1    1   3
#5    3   4
#11   4   7 

Tags:

R