6
$\begingroup$

I have a toy example "system" that is a DAG and has 16 vertices. Suppose I have a collection of vertices "collection". How can I find all paths that passes through at least all vertices present in "collection"? The functions available all seem to work with source and target vertices but not with a collection of vertices.

My only solution up to now is rather naïve and I need to know the source and target vertex. I would like to avoid that if possible.

g = Graph[{1 \[DirectedEdge] 2, 1 \[DirectedEdge] 3, 
     2 \[DirectedEdge] 6, 3 \[DirectedEdge] 7, 3 \[DirectedEdge] 8, 
     7 \[DirectedEdge] 9, 7 \[DirectedEdge] 10, 6 \[DirectedEdge] 11, 
     6 \[DirectedEdge] 12, 12 \[DirectedEdge] 13, 13 \[DirectedEdge] 14, 
     8 \[DirectedEdge] 10, 6 \[DirectedEdge] 10, 12 \[DirectedEdge] 15, 
     15 \[DirectedEdge] 16, 15 \[DirectedEdge] 17, 17 \[DirectedEdge] 14,
     2 \[DirectedEdge] 12, 11 \[DirectedEdge] 16, 10 \[DirectedEdge] 16,
     9 \[DirectedEdge] 16}, VertexLabels->Automatic];
collection = {1, 3, 10, 16};
HighlightGraph[g, collection, VertexLabels -> Automatic]

enter image description here

Now I search for all paths between the vertices 1 and 16

allpaths = FindPath[g, 1, 16, All, All]
HighlightGraph[g, allpaths, ImageSize -> 300]

enter image description here

Now I collect the possible candidates

paths = If[ContainsAll[#, collection], #, Nothing] & /@ allpaths
HighlightGraph[g, paths, ImageSize -> 300]

enter image description here

As asked above are there other ways to do this WITHOUT knowing that I need paths between vertex 1 and 16?

UPDATE 1

In fact the graph I'm investigating is a kind of product knowledge graph. A product can consist of many possible configurations and the software we're using is only checking with some complicated rule based system. I'm investigating doing the same thing based on graphs (combined with some other stuff). By building a graph I can get next to "this product combination will not work" possible options. Something like adding possible products (vertices) and then it works. I believe I should add 1 or more possible endstates. This is not attached to a product and so I know that all vertices in the collection should fit somewhere on the road between the root vertex and one of the possible end states. It might be that the graph becomes to large or to many paths etc but I'm not sure yet about this. I think it should be okay.

So when I add the states (and use vertex 1 as start state) and add some additional paths I get:

system = {1 \[DirectedEdge] 2, 1 \[DirectedEdge] 3, 
  2 \[DirectedEdge] 6, 3 \[DirectedEdge] 7, 3 \[DirectedEdge] 8, 
  7 \[DirectedEdge] 9, 7 \[DirectedEdge] 10, 6 \[DirectedEdge] 11, 
  6 \[DirectedEdge] 12, 12 \[DirectedEdge] 13, 13 \[DirectedEdge] 14, 
  8 \[DirectedEdge] 10, 6 \[DirectedEdge] 10, 12 \[DirectedEdge] 15, 
  15 \[DirectedEdge] 16, 15 \[DirectedEdge] 17, 17 \[DirectedEdge] 14,
   2 \[DirectedEdge] 12, 11 \[DirectedEdge] 16, 10 \[DirectedEdge] 16,
   9 \[DirectedEdge] 16, 7 \[DirectedEdge] 5, 5 \[DirectedEdge] 10, 
  5 \[DirectedEdge] 11, 11 \[DirectedEdge] 15, 1 \[DirectedEdge] 16, 
  16 \[DirectedEdge] "end state 1", 14 \[DirectedEdge] "end state 2", 
  3 \[DirectedEdge] 2, 16 \[DirectedEdge] 17}
collection = {1, 3, 10, 16}
endstates = {"end state 1", "end state 2"}
g = Graph[system, VertexLabels -> Placed[Automatic, {After, Below}], 
  GraphLayout -> {"LayeredDigraphEmbedding", "RootVertex" -> 1}]
allpaths = Flatten[FindPath[g, 1, #, All, All] & /@ endstates, 1]
paths = Select[allpaths, 
  ContainsAll[#, collection] &] (*thanks David G. Stork*)
HighlightGraph[g, DirectedEdge @@@ Partition[#, 2, 1] & /@ paths]

enter image description here

and the paths would be

enter image description here

or

thanks for you help!

HighlightGraph[g, DirectedEdge @@@ Partition[#, 2, 1]] & /@ 
  paths // Multicolumn

enter image description here

$\endgroup$
3
  • $\begingroup$ If your nodes are sorted as they appear, i.e in the order topo = TopologicalSort[g] couldn't you just look for paths between Min[collection] and Max[collection] ? $\endgroup$
    – flinty
    Aug 5 at 21:07
  • 1
    $\begingroup$ In addition to @flinty's comment, if you take a topologically sorted collection of vertices, you can then find all paths between each subsequent pair Partition[topo, 2, 1], then all the paths containing the given collection would be Tuples of these subpaths. $\endgroup$
    – swish
    Aug 5 at 23:32
  • $\begingroup$ Thanks for all you comments and @David G. Stork for getting me to think again. I updated my question. $\endgroup$
    – Lou
    Aug 6 at 8:21
3
$\begingroup$

Here's a general solution that identifies root vertices and the end states in your graph. We find all paths from the roots to the end states, and select the paths that include all the vertices that are members of a collection. You can investigate possible configurations for multiple end states.

Choose any set of vertices for the collection. You don't need to know the source or target vertices, and they aren't required in the collection.

First, find the vertices for the root and end states, and all the paths. Then we can find the paths that match collection = {1, 3, 10, 16}.

roots = Extract[VertexList[g], 
  Position[VertexInDegree[g], 0]];(* {1} *)
endStates = 
  Extract[VertexList[g], Position[VertexOutDegree[g], 0]];(* {14,16} *)
allPaths = Flatten[Table[
  FindPath[g, i, j, Infinity, All], {i, roots}, {j, endStates}], 2];

collection = {1, 3, 10, 16};
collectionPaths = Select[allPaths, ContainsAll[collection]];
GraphicsGrid[Partition[
  Table[HighlightGraph[g, 
    Flatten[{path, #1 \[DirectedEdge] #2 & @@@ 
       Transpose[{Most@path, Rest@path}]}]],
   {path, collectionPaths}], UpTo[4]]]

collection 1, 3, 10, 16

We can check another possible configuration by choosing a new collection.

collection = {1, 2, 6, 12};
collectionPaths = Select[allPaths, ContainsAll[collection]];
GraphicsGrid[Partition[
  Table[HighlightGraph[g, 
    Flatten[{path, #1 \[DirectedEdge] #2 & @@@ 
       Transpose[{Most@path, Rest@path}]}]],
   {path, collectionPaths}], UpTo[4]]]

collection 1, 2, 6, 12

$\endgroup$
1
  • $\begingroup$ Thx! Will have a closer look with different setups to check. Nice use of in and out degrees $\endgroup$
    – Lou
    Aug 6 at 15:13
7
$\begingroup$
myPaths = FindPath[g, First[collection], Last[collection], Infinity, All];

correctPaths = Select[myPaths, ContainsAll[collection]];

HighlightGraph[g, #] & /@ correctPaths

enter image description here

Or

HighlightGraph[g, #, EdgeStyle -> Red] & /@ 
 Table[Map[(#[[1]] -> #[[2]]) &, 
   Table[Map[(#[[1]] -> #[[2]]) &, (Partition[#, 2, 1] & /@ 
         correctPaths)[[i]]], {i, 2}][[i]]], {i, 2}]

enter image description here

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.