HighlightGraph Problem

Question

Bug introduced in 9.0 or earlier and fixed in 11.3

---

HighlightGraph does not work.

HighlightGraph[Graph[{{0, 0}, {0, 1}, {1, 0}, {1, 1}}, {{0, 0} \[UndirectedEdge] {0, 1}}], {{0, 0}, {0, 1}}]

In Mathematica 9 I see:

Answer 1

We can reproduce the problem in a simpler example:

g = Graph[{{1}, {2}}, {{1} <-> {2}}]

HighlightGraph[g, {{1}, {2}}]

HighlightGraph invokes the function GraphComputation`GraphHighlightDump`vertexEdgeExtract to get the list of vertices and edges to be highlighted. For the example above, this function returns {1,2} as the list of vertices to be highlighted,

GraphComputation`GraphHighlightDump`vertexEdgeExtract[{{1}, {2}}, g]

{{1, 2}, {}}

not {{1},{2}}. Since 1 and 2 are not in VertexList[g] nothing is highlighted.

The culprit lies deeper in a function called by GraphComputation`GraphHighlightDump`vertexEdgeExtract, namely, in the function GraphComputation`GraphHighlightDump`veExtract. The code for this function is

GraphComputation`GraphHighlightDump`veExtract[
   GraphComputation`GraphHighlightDump`set_, 
   GraphComputation`GraphHighlightDump`g_, 
   GraphComputation`GraphHighlightDump`vbag_, 
   GraphComputation`GraphHighlightDump`ebag_] /; 
  VertexQ[GraphComputation`GraphHighlightDump`g, 
   GraphComputation`GraphHighlightDump`set] := 
 Internal`StuffBag[GraphComputation`GraphHighlightDump`vbag, 
  GraphComputation`GraphHighlightDump`set, 1]

If we remove the 1 in the last line, i.e., change the definition of veExtract to

GraphComputation`GraphHighlightDump`veExtract[
   GraphComputation`GraphHighlightDump`set_, 
   GraphComputation`GraphHighlightDump`g_, 
   GraphComputation`GraphHighlightDump`vbag_, 
   GraphComputation`GraphHighlightDump`ebag_] /; 
  VertexQ[GraphComputation`GraphHighlightDump`g, 
   GraphComputation`GraphHighlightDump`set] := 
 Internal`StuffBag[GraphComputation`GraphHighlightDump`vbag, 
  GraphComputation`GraphHighlightDump`set]

then we get the correct vertex list to be highlighted:

GraphComputation`GraphHighlightDump`vertexEdgeExtract[{{1}, {2}}, g]

{{{1}, {2}}, {}}

TO DO: I couldn't figure out how/where to make the appropriate changes to get HighlightGraph working as expected.

Notes: An example to see how the third argument of Internal`StuffBag is working:

bag1 = Internal`Bag[];
bag2 = Internal`Bag[];
Internal`StuffBag[bag1, #, 1] & /@ {{1}, {2}};
Internal`StuffBag[bag2, #] & /@ {{1}, {2}};

Internal`BagPart[bag1, All]

{1, 2}

Internal`BagPart[bag2, All]

{{1}, {2}}

Answer 2

This is clearly a bug, which appears when the the vertex names are lists. You should report it to Wolfram Support: http://support.wolfram.com/

I can reproduce it with version 10.4.1.

Proof that lists as vertex names are reasonable: some functions return such graphs. Example:

pts = RandomInteger[{1, 5}, {10, 2}];
g = NearestNeighborGraph[pts]

VertexList[g]
(* {{2, 5}, {5, 2}, {5, 5}, {4, 5}, {3, 3}, {5, 1}, {1, 3}} *)

HighlightGraph[g, Take[pts, 2]] (* Doesn't highlight *)

HighlightGraph[g, {Take[pts, 2]}] (* Also doesn't highlight, even though this syntax is unambiguous *)

Answer 3

Okay, forget what I wrote in the other post. It took quite a while but I think I finally found the bug. That would not have been possible without the great spelunking tool PrintDefinition. The issue is within the function GraphComputation`GraphHighlightDump`setHighlight:

Needs["GeneralUtilities`"]
HighlightGraph;
PrintDefinitions[GraphComputation`GraphHighlightDump`setHighlight];

setHighlight[g_, i_] /; VertexQ[g, i] := 
  (PropertyValue[{g, i}, GraphHighlight] = True;);

setHighlight[g_, i_List] := Scan[setHighlight[g, #1] &, i];

setHighlight[g_, i_] /; EdgeQ[g, i] := 
  (PropertyValue[{g, i}, GraphHighlight] = True;);

Attributes[setHighlightProperties] := {HoldAll};

Let's consider kglr's toy model:

g = Graph[{{1}, {2}}, {{1} <-> {2}}];
data = {{1}, {2}};
HighlightGraph[g, data]

After calling HighlightMesh[g,data] (after traveling through a maze of calls to many other functions), we arrive at the call setHighlight[g_, {{{1},{2}},{}}] (here, {} represents the empty set of edges to be highlighted). This activates the second SetDelayed for setHighlight and so we start to scan through the set {{{1},{2}},{}}.

At some instance, we arrive at the call

PropertyValue[{g, {1}}, GraphHighlight] = True

and although there is no error message, it fails. We also cannot retrieve any property values with PropertyValue[{g, {1}}, <prop>], even if we try to set them beforehand (e.g. with the VertexLabel option). So, this is pretty broken. Note that PropertyValue is a kernel function and we can do nothing about it. However, we can prevent that these calls are made by making the following redefinition which has essentially the same effect (modulo a deep copy of the graph). So, this is my proposition for a fix:

Unprotect[HighlightGraph];

HighlightGraph =.

HighlightGraph := (
   System`Dump`AutoLoad[
     Hold[HighlightGraph], 
     Hold[HighlightGraph], 
     "Network`GraphHighlight`"
     ] /; System`Dump`TestLoad;

   GraphComputation`GraphHighlightDump`setHighlight[g_, i_] /;
   VertexQ[g, i] := Block[{gh},
     gh = GraphHighlight /. Options[g];
     If[Length[gh] == 0, gh = {}];
     (*This is a very slow workaround, only meant as fallback. 
     Should be avoided at all cost!*)
     g = Graph[g, GraphHighlight -> Join[gh, {i}]];
     ];

   GraphComputation`GraphHighlightDump`setHighlight[g_, i_List] := 
    Block[{gh},
     With[{vlist = Select[i, VertexQ[g, #] &]},
      gh = GraphHighlight /. Options[g];
      If[Length[gh] == 0, gh = {}];
      (*This enforces a deep copy (?) of the graph but does it only once for all vertices detected.*)

      g = Graph[g, GraphHighlight -> Join[gh, vlist]];
      (*Proceed as usual for all remaining data.*)
      Scan[
       GraphComputation`GraphHighlightDump`setHighlight[g, #] &, 
       Complement[i, vlist]
       ];
      ]
     ];

   GraphComputation`GraphHighlightDump`setHighlight[
    g_, 
    GraphComputation`GraphHighlightDump`iSubgraph[v_, e_]
    ] := (
     (*Parse vertex and edge list; do not use Scan in order to avoid the call to setHighlight[g, i]/;VertexQ[g,i]:=...*)
     GraphComputation`GraphHighlightDump`setHighlight[g, Join[v, e]]
     );

   GraphComputation`GraphHighlightDump`setGroupProperty[g_, i_, color_] /; VertexQ[g, i] := Block[{gh, style},
     {gh, style} = {GraphHighlight, GraphHighlightStyle} /. Options[g];
     If[Length[gh] == 0, gh = {}];
     If[Length[style] == 0, style = {}];
     (*This is a very slow workaround, only meant as fallback. Should be  avoided at all cost!*)
     g = Graph[g,
       GraphHighlight -> Join[gh, {i}],
       GraphHighlightStyle -> 
         Join[style, {i -> {VertexStyle -> color}}];
       ];];

   GraphComputation`GraphHighlightDump`setGroupProperty[g_, i_List, color_] := Block[{gh, style},
     With[{vlist = Select[i, VertexQ[g, #] &]},
      {gh, style} = {GraphHighlight, GraphHighlightStyle} /. Options[g];
      If[Length[gh] == 0, gh = {}];
      If[Length[style] == 0, style = {}];
      (*This enforces a deep copy (?) of the graph but does it only once for all vertices detected.*)
      g = Graph[g,
        GraphHighlight -> Join[gh, vlist],
        GraphHighlightStyle -> 
         Join[style, Table[j -> {VertexStyle -> color}, {j, vlist}]]
        ];
      (*Proceed as usual for all remaining data.*)
      Scan[
       GraphComputation`GraphHighlightDump`setGroupProperty[g, #, color] &, 
       Complement[i, vlist]
       ];
      ]
     ];

   GraphComputation`GraphHighlightDump`setGroupProperty[
    g_, 
    GraphComputation`GraphHighlightDump`iSubgraph[v_, e_], 
    color_
    ] := (
     (*Parse vertex and edge list; do not use Scan in order to avoid the call to setGroupProperty[g,i]/;VertexQ[g,i]:=...*)
     GraphComputation`GraphHighlightDump`setGroupProperty[g, Join[v, e], color]
     );

   (*Making sure that kglr's bugfix is available in older versions, too.*)
   GraphComputation`GraphHighlightDump`veExtract[set_, g_, vbag_, ebag_] /; VertexQ[g, set] := (
    Internal`StuffBag[vbag, set]
    );

   (*Not sure wether this is set correctly in older version.*)
   GraphComputation`GraphHighlightDump`veExtract[
    GraphComputation`GraphHighlightDump`iSubgraph[v_, e_], g_, vbag_, ebag_] := (
    Internal`StuffBag[ebag, e, 1];
    Internal`StuffBag[vbag, v, 1]
    );

   HighlightGraph
   );

Protect[HighlightGraph];

This seems to work, at least for the examples from the other post. Note that I am using version MMA 11.0.1 and that this version does not contain the bug in veExtract that kglr found.

Of course, one can enforce to break it by introducing ambiguities like these:

g = Graph[{1, 2, {1, 2}, {{1, 2}}}, {UndirectedEdge[1, 2], 
    UndirectedEdge[1, {1, 2}]}, VertexLabels -> "Name"];
HighlightGraph[g, {{{1, 2}}, 1, 2, UndirectedEdge[1, 2]}] 

So, introducing a Vertex primitive might still be a good idea.

Improvements and suggestions are welcome!

Update

1. Added a fix for a case that {1} and not 1 is the only vertex to be highlighted.
2. Reformulated the fix such that it gets applied automatically after autoload.
3. Fixed the issue for Subgraph.
4. Defined new rules for setGroupProperty in order to fix the issue for lists of list.

Here is a demonstration of the newest changes:

n = 24;
m = Floor[n/3];
SeedRandom[123];
H = RandomGraph[{n, 2 n}, VertexLabels -> "Name"];
rules = Normal@AssociationThread[Transpose[{Range[n]}], Range[n]];
G = VertexReplace[H, Reverse /@ rules]; // AbsoluteTiming
v1 = DeleteDuplicates@RandomChoice[VertexList[G], m];
v2 = Complement[DeleteDuplicates@RandomChoice[VertexList[G], m], v1];
HighlightGraph[G, {Subgraph[G, v1], Subgraph[G, v2]}]

The original version leads to:

And the fixed version from above produces:

Answer 4

I am afraid, the only unambiguous solution would be to introduce a keyword for vertices, e.g. Vertex. Compare that to the need for Key when addressing associations whose keys contain integers. Let's see what we can do.

Fortunately, HighlightGraph is Protected and ReadProtected but not Locked, so we can mess around with it. We can see the code with

Needs["GeneralUtilities`"]
PrintDefinitions[HighlightGraph];

Warning

People who have the tendency to get nervous when unprotecting symbols: Stop. Reading. Now.

The code

For some weird reason I had to Clear HighlightGraph first, in order to overwrite its definitions. Here is what I do:

Vertex::usage = 
  "\!\(Vertex[\*
    StyleBox[\"vertex\", \"TI\"]]\) represents a \
vertex used to access vertices in a graph.";
Protect[Vertex];

HighlightGraph;
Unprotect[HighlightGraph];
ClearAttributes[HighlightGraph, ReadProtected];
Clear[HighlightGraph];

Begin["GraphComputation`GraphHighlightDump`"];

HighlightGraph[graph_, None, opts : OptionsPattern[]] := 
  HighlightGraph[graph, {}, opts];

HighlightGraph[graph_?GraphQ, {}, opts : OptionsPattern[]] := 
  Block[{res}, res = Flatten[{opts}];
   GraphComputation`CloneGraph[GraphComputation`GraphHighlightDump`graph, res]
   ];

HighlightGraph[e_List, {}, opts : OptionsPattern[]] := 
  Block[{res, graph},
   graph = Graph[e];
   (
     res = Flatten[{opts}]; 
     GraphComputation`CloneGraph[graph, res]
     ) /; GraphQ[graph]];

HighlightGraph[graph_?GraphQ, data_, opts : OptionsPattern[]] := 
  Block[{res, nopts, dopts, n, vertexlookup, vertexreverselookup, 
    edgelookup, edgereverselookup, g, h, gdata}, 
   nopts = FilterRules[Flatten[{opts}], Options[HighlightGraph]];
   dopts = Complement[Options[HighlightGraph], Options[Graph]];
   If[dopts =!= {}, nopts = Join[nopts, dopts]];
   res = If[FirstPosition[data, Vertex] === Missing["NotFound"],
     GraphComputation`GraphHighlightDump`highlightGraph[graph, data, nopts]
     ,
     n = VertexCount[graph];
     vertexlookup = AssociationThread[VertexList[graph], Range[n]];
     vertexreverselookup = 
      AssociationThread[Range[n], VertexList[graph]];
     With[{edges = EdgeList[graph] /. vertexlookup}, 
      edgelookup = AssociationThread[EdgeList[graph], edges];
      edgereverselookup =  AssociationThread[edges, EdgeList[graph]];
      ];
     g = AdjacencyGraph[AdjacencyMatrix[graph]];
     gdata = data /. KeyMap[Vertex, vertexlookup] /. edgelookup;
     h = GraphComputation`GraphHighlightDump`highlightGraph[g, gdata, nopts];
     Graph[graph, 
      Join[{GraphHighlight -> (GraphHighlight /. Options[h] /. vertexreverselookup)}, 
      FilterRules[Options[h], Except[GraphHighlight]]]]
     ];
   res /; res =!= $Failed];

HighlightGraph[e_List, data_, opts : OptionsPattern[]] := 
 Block[{res, h, nopts, dopts, vlist, elist, graph}, 
  graph = Graph[e];
  (
    res = HighlightGraph[graph, data, opts];
    res /; res =!= $Failed
    ) /; GraphQ[graph]]

HighlightGraph[expr___] := (messageHighlightGraph[expr]; Null /; False);

End[];
Protect[HighlightGraph];

The main SetDelayed is the one which is defined for the pattern HighlightGraph[graph_?GraphQ, data_, opts : OptionsPattern[]]. This is where we try to slip in. What I do is the following: The original HighlightMesh has no problems with integer vertices. So, I merely replace all the vertices by integers (that's where we need the wrapper Vertex around vertices appearing in data. Afterwards I run the usual backend of HighlightGraph, grab the options of its output, transform that back to the original vertices and append it to the original graph. That's it.

Some examples

A usage example for the OP's example:

graph = Graph[{{0, 0}, {0, 1}, {1, 0}, {1, 1}}, {{0, 0} <-> {0, 1}}, 
   VertexLabels -> "Name"];
HighlightGraph[graph, {Vertex /@ {{0, 0}, {0, 1}}}]

And for kglr's example:

g = Graph[{{1}, {2}}, {{1} <-> {2}}];
HighlightGraph[g, Vertex /@ {{1}, {2}}]

Apart from that, I haven't tested it too thoroughly. Maybe this won't work in all cases or break something else. So, better not run any nukular power plant with it. And maybe this is not very performant (quite many replacements that have to be made).

Edit

Added detection for occurence of the symbol Vertex. If not found, the standard implementation is used.

Answer 5

Faced the same issue on Mathematica 11.0

Workaround started with @ZYX's comment extended to PathGraph too for DirectedEdges. However this can be further extended for Optional Parameters

HighlightGraphR[g_, vertices_] := Block[{vt, gt},
    vt = ToString /@ vertices;
    gt = VertexReplace[g, Thread[VertexList[g] -> ToString /@ VertexList[g]]];
    HighlightGraph[gt, PathGraph[vt, DirectedEdges->True]]
]

HighlightGraphR[g, v];