Matrix which gives the existence in a graph of a path of length $k$

Question

In a graph $G$, for some $k$, I am looking to get a 0-1 matrix whose $ij^{\text{th}}$ entry is 1 whenever vertex $i$ has a path of length $k$ to vertex $j$ in $G$, and is otherwise zero.

I have been doing this with FindPath[graph,i,j,{k}], and entering all vertex pairs $ij$, then using Length to obtain a zero or one. But this takes a long time in large graphs, particularly when $k$ is large.

Considering a 1d random geometric graph, define the functions for building the graph:

edges6 = Function[{subsets, b}, 
   Pick[subsets, 
    UnitStep[
     RandomReal[{0, 1}, Length@subsets] - 
      Exp[-b (subsets[[All, 1]] - subsets[[All, 2]])^2]], 0]];
gr6[vert_, r0_] := 
  Graph[vert, UndirectedEdge @@@ edges6[Subsets[vert, {2}], 1/r0^2]];
makegraph2[nv_, coord_, width_, height_, r0_] := 
  Module[{pts, newvertices, newedges, edges, alledges, allpts, e1, e2,
     ew}, allpts = 
    Table[RandomReal[{-width/2, width/2}], {i, 1, nv}];
   allpts = Join[allpts, coord];
   (****Add edge weights****)
   pdg1 = gr6[allpts, r0]
   ];

and then run

gr = makegraph2[100, {0}, 10, 0.01, 0.5];
Length[FindPath[gr, #, Last@VertexList[gr], {6}]] & /@ VertexList[gr] // AbsoluteTiming

which gives

{0.657717, {1, 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0, 0, 1, 1, 0, 1, 1, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0}}

which is a list of 0's and 1's which determines the existence of a six-hop path from each node, to the node at $0$. I can try and speed it up with IGDistanceCounts, but this only gives shortest paths. Is there way to do it quicker than with FindPath?

Answer 1

Why not work with AdjacencyMatrix instead? For example:

KPaths[g_, k_] := Module[{a, m},
    a = AdjacencyMatrix[g];
    m = 1 - IdentityMatrix[Length[a]];
    Nest[Unitize[(a . #) m]&, a, k-1]
]       

Comparison:

SeedRandom[1];
gr=makegraph2[100,{0},10,0.01,0.5];
last = Length[FindPath[gr,#,Last@VertexList[gr],{6}]]&/@VertexList[gr]; //AbsoluteTiming
last

{0.104942, Null}

{0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, 1, 0, 1, 1, 1,
0, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0,
1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 0, 0}

r = KPaths[gr, 6]; //AbsoluteTiming
r[[-1]] //Normal

last == r[[-1]]

{0.002574, Null}

{0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, 1, 0, 1, 1, 1,
0, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0,
1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 0, 0}

True

Note that KPaths does all of the vertices instead of just the last vertex.

Answer 2

A method using SparseArray`SparseArrayRemoveDiagonal to remove the diagonal:

ClearAll[urd, kPaths1, kPaths2]

urd = Unitize @* SparseArray`SparseArrayRemoveDiagonal;

kPaths1[g_, k_] := Module[{a = AdjacencyMatrix @ g}, Nest[urd[a.#] &, a, k - 1]]

Example:

SeedRandom[1];

gr = makegraph2[100, {0}, 10, 0.01, 0.5];

r1 = kPaths1[gr, 6]; // RepeatedTiming // First

0.00078

In comparison, Carl's KPaths we get

r = KPaths[gr, 6]; // RepeatedTiming // First

0.0017

All three methods give the same result:

r == r1

True