Match each primitive with relevant directives in GraphicsComplexBox

Question

I am struggling to write the correct pattern to match all ArrowBox objects with the relevant graphic directives in following snippet

{
    Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
    {
        Arrowheads[0.],
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299]
    },
    ArrowBox[BezierCurveBox[{1, {0.10576, 0.352183}, 3}], 0.0127299], 
    ArrowBox[BezierCurveBox[{2, {0.499413, 0.70158}, 3}], 0.0127299],
    {
        Arrowheads[0.],
        ArrowBox[BezierCurveBox[{2, {0.500581, 1.03046}, 3}], 0.0127299]
    }, 
    ArrowBox[BezierCurveBox[{2, {0.890575, 0.349397}, 1}], 0.0127299], 
    ArrowBox[BezierCurveBox[{3, {0.391162, 0.515612}, 1}], 0.0127299]
}

To generate the same code, use this snippet which extracts it from a GraphicsComplexBox:

g = Block[{Identity}, 
  Graph[{1 <-> 2, 2 <-> 3, 1 -> 3, 2 -> 1, 2 -> 3, 3 -> 1}, 
    EdgeWeight -> Identity /@ {{0, 0}, {0, 0}, {1, 0}, {0, 1}, {1, 0}, {0, 1}}]];
Cases[ToBoxes[g], _GraphicsComplexBox, Infinity][[1, 2, 1]]

I try to improve the answer https://mathematica.stackexchange.com/a/169265/13042 so it works with other graphs as well. The following part of the solution in the referenced answer does not work as intended for the above given graph:

Cases[ToBoxes[g], {dir___, ar : Longest[__ArrowBox], ___} :> 
(## & @@ Thread[{dir, {ar}}]), Infinity]

It returns

{
    {
        Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299]
    },
    {
        Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{2, {0.500581, 1.03046}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{1, {0.10576, 0.352183}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299], 
        ArrowBox[BezierCurveBox[{2, {0.499413, 0.70158}, 3}], 0.0127299]
    }
}

There are several issues

the last two ArrowBox objects are missing
contains a duplicate ArrowBox, and
graphic directives are not properly handled.

The output should look like

{
    {
        Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{1, {0.10576, 0.352183}, 3}], 0.0127299]},
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{2, {0.499413, 0.70158}, 3}], 0.0127299]
    },
    {
        Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{2, {0.500581, 1.03046}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{2, {0.890575, 0.349397}, 1}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{3, {0.391162, 0.515612}, 1}], 0.0127299]
    }
}

General scheme is

{
    directivesLevel1,
    RepeatedPattern[ primitive | {directivesLevel2, primitive}]
}

which should return with the replacement rule

{
    {directivesLevel1, primitive} OR
    {directiveslevel1, directivesLevel2, primitive},
    ...
}

Other graphs for more extensive testing

g2 = Block[{Identity}, 
  Graph[{1 <-> 2, 1 <-> 3, 2 <-> 3, 2 <-> 4, 2 <-> 5, 4 <-> 5, 5 <-> 6, 3 <-> 6, 3 <-> 7,
    6 <-> 7, 4 -> 3, 4 -> 1, 7 -> 2, 6 -> 4, 5 -> 1, 6 -> 1, 7 -> 1, 5 -> 7}, 
    EdgeWeight ->  Identity /@ Join[Table[{0, 0}, 10], {{1, 0}, {1, 0}, {0, 1}, {0, 1},
        {1, 1}, {1, 1}, {0, 1}, {1, 0}}]]]

g3 = Block[{Identity}, 
  Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 1 <-> 6, 2 <-> 3, 3 <-> 4, 4 <-> 5, 4 <-> 6, 5 <-> 6,
    1 -> 5, 2 -> 5, 2 -> 4, 5 -> 3, 6 -> 3, 6 -> 2}, 
    EdgeWeight -> Identity /@ Join[Table[{0, 0}, 9], Table[{0, 1}, 3], Table[{1, 0}, 3]]]]

To see all errors, run

ClearAll[displayWeightedMultiGraph]
displayWeightedMultiGraph = Module[{i = 1, j, g = #, bcurves,
  labels = PropertyValue[#, EdgeWeight], 
  gccoords = Cases[ToBoxes[#], GraphicsComplexBox[x_, y_, z___] :> x, Infinity][[1]]}, 
  bcurves = Cases[ToBoxes[g], {dir___, ar : Longest[__ArrowBox], ___} :> 
    (## & @@ Thread[{dir, {ar}}]), Infinity] /. 
  {ArrowBox[BezierCurveBox[x_, y___], z___] :> 
     Arrow[BezierCurve[x /. k_Integer :> gccoords[[k]], y], z], 
   ArrowBox[x : {__}, y_] :> Arrow[gccoords[[x]], y]}; 
   SetProperty[g, EdgeShapeFunction -> ({j = i++; Text[labels[[j]], 
     BezierFunction[#, SplineDegree -> 7][0.5]], bcurves[[j]]} &)]] &;

displayWeightedMultiGraph/@{g, g2, g3}

Am I correct in saying that you are trying to "unravel" the directive dependencies and get a list in which a directive is assigned explicitly to each ArrowBox? — MarcoB, Apr 16 '18 at 21:09
Possible duplicate of FilledCurve inside GraphicsComplex doesn't interpret the integers as points — Carl Woll, Apr 17 '18 at 06:04
@CarlWoll: Can you explain why do you think this is a duplicate and a (possible) bug in Mathematica and if and how the given workaround could help me? I am not too experienced with Mathematica and it is not obvious how to apply the given workaround. Therefore I think my question could get its own answer with a link to the other one. — Hotschke, Apr 17 '18 at 08:15
@CarlWoll: The mentioned workaround moves manually the problematic primitive outside of the GraphicsComplex. I am interested in doing it automatically for different graphs. Editing manually the low-level box representation is not an answer to this question. — Hotschke, Apr 17 '18 at 08:36
For a graph g, it is much simpler to use Show to convert it to a Graphics object. Then, the function Normal is documented to convert a Graphics object with a GraphicsComplex to one without any GraphicsComplex objects. The fact that Normal fails is a bug and has already been covered in questions (105184) and (104818). — Carl Woll, Apr 17 '18 at 15:18

score 2 · Accepted Answer · answered Apr 19 '18 at 07:33

As I said in my comment, I think it's much more straightforward to use Show to create the equivalent Graphics object. Then, you can use Normal to convert the GraphicsComplex into normal primitives. However, there is an issue with Normal and BezierCurve objects that are nested inside of other primitives, partly discussed in (104818). For example:

Normal @ GraphicsComplex[
    {{1,1}, {1.25,1.75}, {2,2}},
    Arrow[BezierCurve[{1, 2, 3}], .1]
]

{Arrow[BezierCurve[{1, 2, 3}], 0.1]}

The integer indices of the BezierCurve have not been replaced with the coordinates from the first argument of the GraphicsComplex. On the other hand, when the primitives are not nested, Normal works:

Normal @ GraphicsComplex[{{1,1}, {1.25,1.75}, {2,2}}, BezierCurve[{1, 2, 3}]]
Normal @ GraphicsComplex[{{1,1}, {1.25,1.75}, {2,2}}, Arrow[{1, 2, 3}, .1]]

{BezierCurve[{{1, 1}, {1.25, 1.75}, {2, 2}}]}

{Arrow[{{1, 1}, {1.25, 1.75}, {2, 2}}, 0.1]}

Here is a patch the fixes the nested BezierCurve issue:

Unprotect[Normal];
Normal[g_] /; !TrueQ@$BZFix := Block[{$BZFix=True},
    Normal[g /. gc_GraphicsComplex :> fixGC[gc]]
]

fixGC[GraphicsComplex[pts_, prim_, rest___]] := GraphicsComplex[
    pts,
    prim /. BezierCurve[p_, r___] :> BezierCurve[p /. i_Integer :> pts[[i]], r],
    rest
]

Check:

Normal @ GraphicsComplex[{{1,1}, {1.25,1.75}, {2,2}}, Arrow[BezierCurve[{1, 2, 3}], .1]]

{Arrow[BezierCurve[{{1, 1}, {1.25, 1.75}, {2, 2}}], 0.1]}

For your first example graph:

g = Block[{Identity}, 
    Graph[
        {1 <-> 2, 2 <-> 3, 1 -> 3, 2 -> 1, 2 -> 3, 3 -> 1}, 
        EdgeWeight -> Identity /@ {{0, 0}, {0, 0}, {1, 0}, {0, 1}, {1, 0}, {0, 1}}
    ]
];

We get:

Normal @ Show @ g //InputForm

Graphics[{{Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], {Arrowheads[0.], Arrow[BezierCurve[{{0.49692221124371655, 0.}, {0.6063408473035717, 0.5148479095999602}, {0.9999936484762257, 0.8642449331499502}}], 0.012729919145102353]}, Arrow[BezierCurve[{{0.49692221124371655, 0.}, {0.1057602447225488, 0.3521832484933547}, {0., 0.8677950164043108}}], 0.012729919145102353], Arrow[BezierCurve[{{0.9999936484762257, 0.8642449331499502}, {0.49941304589520347, 0.7015802720433176}, {0., 0.8677950164043108}}], 0.012729919145102353], {Arrowheads[0.], Arrow[BezierCurve[{{0.9999936484762257, 0.8642449331499502}, {0.5005806025810231, 1.0304596775108001}, {0., 0.8677950164043108}}], 0.012729919145102353]}, Arrow[BezierCurve[{{0.9999936484762257, 0.8642449331499502}, {0.8905750124163706, 0.3493970235499975}, {0.49692221124371655, 0.}}], 0.012729919145102353], Arrow[BezierCurve[{{0., 0.8677950164043108}, {0.3911619665211691, 0.5156117679108979}, {0.49692221124371655, 0.}}], 0.012729919145102353]}, {Directive[Hue[0.6, 0.2, 0.8], EdgeForm[Directive[GrayLevel[0], Opacity[0.7]]]], Disk[{0.49692221124371655, 0.}, 0.012729919145102353], Disk[{0.9999936484762257, 0.8642449331499502}, 0.012729919145102353], Disk[{0., 0.8677950164043108}, 0.012729919145102353]}}, {FormatType -> TraditionalForm, FrameTicks -> None}]

You'll notice that all of the BezierCurve objects have actual coordinates, available to be extracted by your displayWeightedMultiGraph function.

Hotschke · Answer 2 · 2018-04-19T13:13:07.647

I have figured out a possible solution

primitiveQ[p_] := Head[p] === ArrowBox;
directiveQ[d_] := Head[d] === Arrowheads || Head[d] === Directive;
list = Cases[ToBoxes[g], _GraphicsComplexBox, Infinity][[1, 2, 1]];
dirlevel1 = Cases[list, _?directiveQ];
Cases[list, ar_?primitiveQ|{dir___,ar_?primitiveQ} :> Flatten[{dirlevel1, dir, ar}]]

This returns

{
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.],
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
        ArrowBox[BezierCurveBox[{1, {0.10576, 0.352183}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
        ArrowBox[BezierCurveBox[{2, {0.499413, 0.70158}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.],
        ArrowBox[BezierCurveBox[{2, {0.500581, 1.03046}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
        ArrowBox[BezierCurveBox[{2, {0.890575, 0.349397}, 1}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
        ArrowBox[BezierCurveBox[{3, {0.391162, 0.515612}, 1}], 0.0127299]
    }
}

Remaining improvements

remove duplicate directives keeping the last (here Arrowheads)
better predicates primitiveQ and directiveQ

I am not too experienced: maybe this code contains unnecessary copies of lists.

Match each primitive with relevant directives in GraphicsComplexBox

2 Answers2