4
$\begingroup$

I have an adjacency matrix

c={{0, 0, 1, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1}, {0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 1, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}

I am making a Hasse diagram from this

am = c; 
labels = Table[i, {i, n}];
g = FromAdjacencyMatrix[am, Type -> Directed];
h = HasseDiagram[SetVertexLabels[g, labels]]
ShowGraph[h, BaseStyle -> {FontSize -> 18}]

enter image description here

this image has the advantage of displaying the nodes as layers {1,2,4}, {3,5,6,7} etc. The question is whether I can extract this information from the diagram? or better yet can I get this information directly from c without having to make the diagram at all? I am trying to find the nodes which make up the longest such layer. In mathematical jargon this would be called the maximal antichain. Also, any tips on efficiency are welcome.

The typical matrix sizes that I have to handle are above 500x500 so visual inspection is not feasible.

Edit: I'm adding in an example here which doesn't give the right layers using Halmir's method

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

enter image description here

The output I'm getting is {{1, 2}, {3, 4, 5, 6}, {7, 8}, {9, 10}}

here is another one

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

enter image description here

the output is {{1, 2, 3}, {4, 5, 8}, {6, 7, 9}}

Edit 2: counterexample to Haldir's edited method

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

enter image description here

the output is <|0 -> {1}, 1 -> {2, 3, 4, 5}, 2 -> {6, 7, 8, 9}, 3 -> {10, 11}|>

$\endgroup$
2
  • 1
    $\begingroup$ You seem to be using the obsolete Combinatorica package. What version of Mathematica are you using? $\endgroup$
    – m_goldberg
    Sep 15, 2017 at 0:37
  • 1
    $\begingroup$ I have recently started using 11.1 but I haven't really tried modifying this part of the code, does it make a difference to what I'm asking? $\endgroup$
    – user51833
    Sep 15, 2017 at 0:48

2 Answers 2

5
$\begingroup$

Version using adjacency matrix:

FindLayers[c_?MatrixQ]:=
    Block[{trg, m, start},
        trg=TransitiveReductionGraph[AdjacencyGraph[c]];
        m = AdjacencyMatrix[trg];
        start={};
        FixedPointList[
            (If[#=!={},m[[#,All]]=0];
            Complement[Pick[VertexList[trg],Total[m],0],start=Join[start,#],#])&,{}][[2;;-3]]
    ]

You can use TransitiveReductionGraph and then compute layers:

SetAttributes[updateChild,HoldFirst];
SetAttributes[updateIndex,HoldFirst];

updateChild[childfunc_,child_,parent_]/; (child=!=parent):=
   If[FreeQ[childfunc[parent],child],childfunc[parent]=Append[childfunc[parent],child]];

updateIndex[childfunc_,levelfunc_,v_]:=
    Block[{d, children},
        d = levelfunc[v];
        children= childfunc[v];
        If[Length[children]>0,
        (levelfunc[#]=d + 1)&/@children;
        updateIndex[childfunc,levelfunc,#] & /@children]
    ]

FindLayers[graph_?AcyclicGraphQ] :=
  Block[{vlist,level, child},
     vlist = VertexList[graph];
     level[_]:=0;
     child[_]:={};       
     BreadthFirstScan[graph, 
        {"DiscoverVertex"->((updateChild[child,#1,#2];level[#1]=Max[#3,level[#1],level[#2]+1])&),
         "UnvisitedVertex"->((updateChild[child,#1,#2];level[#1]=Max[level[#1],level[#2]+1])&),
         "VisitedVertex"->((level[#1]=Max[level[#1],level[#2]+1];updateIndex[child,level,#1])&)}];         
     SortBy[GroupBy[vlist,level], First]
  ]

tg = TransitiveReductionGraph[AdjacencyGraph[c]];
FindLayers[tg]

<|0 -> {1, 2, 4}, 1 -> {3, 5, 6, 7}, 2 -> {8, 11}, 3 -> {9, 10}, 4 -> {12, 13, 14, 15}|>

Extra edges created in TransitiveReductionGraph here doesn't really matter for computing layers, but for visualization, if your graphs are acyclic, we could define the following:

iTransitiveReductionGraph[g_?AcyclicGraphQ, opt:OptionsPattern[]] :=

  Block[{adjA, adjB, vlist, tg},
    vlist = VertexList[g];
    tg = TransitiveClosureGraph[g];
    adjA = AdjacencyMatrix[g];
    adjB = AdjacencyMatrix[tg];
    adjA = 
    adjA SparseArray[
      ConstantArray[1, Dimensions[adjA]] - Unitize[adjA.adjB]];
    AdjacencyGraph[vlist, adjA, opt]
   ];
iTransitiveReductionGraph[g_, opt:OptionsPattern[]] := TransitiveReductionGraph[g, opt]

If you want to create hasse diagram like Combinatorica package:

xPosition[max_,m_] := Range[m]+(max-m)/2

iHasseGraph[graph_?DirectedGraphQ, opts:OptionsPattern[]]:=
    Block[{layer, l, max, vcoord, tg},
        tg = iTransitiveReductionGraph[graph];
        layer = Values[FindLayers[tg]];
        l = Length/@layer;
        max=Max[Length/@layer];
        vcoord = Flatten[Table[{#,i}&/@xPosition[max,l[[i]]], {i, 1, Length[layer]}],1];
        vcoord = vcoord[[Ordering[VertexIndex[tg,#]&/@Flatten[layer,1]]]];
        Graph[tg, VertexCoordinates -> vcoord, opts]
    ]

For example:

iHasseGraph[AdjacencyGraph[c], GraphStyle -> "BasicBlue", 
 VertexSize -> .2, VertexLabels -> Placed["Name", Center], 
 VertexLabelStyle -> Directive[12, White] ]

enter image description here

Here's the brute force approach using output of combinatorica:

res = ShowGraph[h];
text = Cases[res, Text[na_, Scaled[_, {_, y_}], ___] :> {na, y}, 
   Infinity];
Values[SortBy[GroupBy[text, Extract[2] -> First], First]]
$\endgroup$
10
  • $\begingroup$ he first part of your answer doesn't always give the right layers, I can't put an example in the comments but can you check with some other matrices to start and confirm that it does indeed give the layers correctly? $\endgroup$
    – user51833
    Sep 15, 2017 at 12:00
  • $\begingroup$ It's better you put the example that doesn't work (maybe in op) $\endgroup$
    – halmir
    Sep 15, 2017 at 12:54
  • $\begingroup$ okay, I've put in examples in the OP $\endgroup$
    – user51833
    Sep 15, 2017 at 13:09
  • 1
    $\begingroup$ I modified FindLayer code. I was assuming wrong conditions when I initially wrote layer code.. $\endgroup$
    – halmir
    Sep 15, 2017 at 14:45
  • 1
    $\begingroup$ @nomaan I added more check for those cases. Code get bigger though. There should be simpler code to do this... $\endgroup$
    – halmir
    Sep 15, 2017 at 17:04
1
$\begingroup$

Update: Although the function layersF in the original answer computes the desired result without the need for TransitiveReductionGraph, it may be of independent interest to construct the transitive reduction graph from an adjacency matrix. As noted by Szabolcs, the built-in TransitiveReductionGraph has some "known issues" that are yet to be fixed as of version 11.2.0 (see this.)

An alternative approach is to construct the Hasse diagram from scratch. In the following, we do this using the function trF from this answer which is an alternative implementation of the function Combinatorica`TR from the package Combinatorica used to find the transitive reduction of a matrix representing a binary relation.

ClearAll[trF]
trF = Module[{r = # , m = Length@#}, Table[r[[i, k]] = r[[i, k]] 
  (1 - Times @@ Unitize[{r[[i, j]], r[[j, k]], r[[i, k]], i - j, j - k, i - k}]), 
  {i, m}, {j, m}, {k, m}]; r] &;

An adjacency matrix mat and its transtive reduction trF@mat have the same layers:

And @@ (layersF @ # == layersF @ trF @ # & /@ {c1, c2, c3, c4})

True

For a given adjacency matrix (mat), we can use AdjacencyGraph[trF @ mat] to get the transitive reduction graph of AdjacencyGraph[mat]. The function call agF[f, options][mat] constructs the AdjacencyGraph of f[mat]. Using agF with trF as the first argument, and adding appropriate options, gives the transitive reduction graph we need.

agF[f_ : Identity, o : OptionsPattern[]] := AdjacencyGraph[Join @@ layersF[#], f@#, 
   GraphLayout -> {"MultipartiteEmbedding",  "VertexPartition" -> ( Length /@ layersF[#])},
   o, DirectedEdges -> False, ImageSize -> 200, VertexLabels -> Placed["Name", Center], 
   VertexShapeFunction -> None, VertexLabelStyle -> Directive[18, Bold]] &

The following function rotates and reflects the VertexCoordinates of a graph. We will need it to get a look similar to the one produced by Combinatorica.

rotateF = SetProperty[#, VertexCoordinates -> 
  ReflectionTransform[{-1, 0}] @ RotationTransform[Pi/2] @ GraphEmbedding @ #] &;

The function gridF below is just for organizing the results when the functions a trF and agF are applied to an input matrix:

gridF = Grid[{{"c", "trF@c"}, {Grid@#, Grid@trF@#}, 
 {"AdjacencyGraph@c", "AdjacencyGraph@trF@c"}, {rotateF@agF[]@#, rotateF@agF[trF]@#}}, 
 Dividers -> All] &;

Examples:

gridF @ c1

enter image description here

gridF @ c2

enter image description here

gridF @ c3

enter image description here

gridF @ c4

enter image description here

An example with non-default options:

rotateF@agF[trF, VertexShapeFunction->"Capsule", 
 GraphStyle->"DiagramGold", ImageSize -> 300] @ c2

enter image description here

Original answer: Find and remove source vertices using GraphComputation`SourceVertexList recursively starting with AdjacencyGraph@c:

ClearAll[layersF, svL]
svL = GraphComputation`SourceVertexList;
layersF = Module[{ag = AdjacencyGraph @ #},   svL /@ 
   FixedPointList[Subgraph[#, Complement[VertexList @ #,  svL @ #]]&, ag]][[;;-3]]&;

Examples: For the four arrays {c1, c2, c3, c4} in OP:

layers = layersF/@{c1, c2, c3, c4};
Transpose[{{"c1","c2","c3","c4"}, Column/@layers}]// 
   Grid[#, Dividers->All, Alignment->Left]&

enter image description here

$\endgroup$
2
  • $\begingroup$ this works, thanks! $\endgroup$
    – user51833
    Sep 16, 2017 at 15:46
  • $\begingroup$ @nomaanx, my pleasure. Welcome to mma.se. Please remember to upvote (using the up triangles on the left) when you consider an answer useful :) $\endgroup$
    – kglr
    Sep 16, 2017 at 23:39

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.