To get both the edge directions (that is, all edges on a path pointing in the right direction) and styles right, we need to construct the EdgeShapeFunction
taking into account somewhat peculiar treatment of the second argument (#2
) when used inside HighlightGraph
.
ClearAll[styledPaths];
Options[styledPaths] = Join[Options[Graph], {"arrowSize" -> .05, "setback" -> .1}];
styledPaths[grp_Graph, pathsandstyles : {{{__}, {__}} ..}, opts : OptionsPattern[styledPaths]] := Module[{check, pathverts = pathsandstyles[[All, 1]],
pathedges = Flatten@(EdgeList[#] & /@ (PathGraph[First@#] & /@
pathsandstyles)), grpedges = EdgeList[grp], pathgraphs},
(* Check that paths are paths: no gaps and no edges that do not belong to parent graph *)
check = Apply[And,
Join[MemberQ[EdgeList[grp], # | Reverse[#]] & /@
Flatten[UndirectedEdge[First@#, Last@#] & /@
Transpose@{Most@#, Most@RotateLeft[#]} & /@ pathverts, 1],
(PathGraphQ[Graph[#]] & /@ (UndirectedEdge[First@#, Last@#] & /@
Transpose@{Most@#, Most@RotateLeft[#]} & /@ pathverts))], {0}];
Switch[check, False, "FAILED", _,
(* proceed to construct styled path graphs *)
pathgraphs = Style[PathGraph[First@#], Last@#] & /@ pathsandstyles;
(* find the correct orientation of highlighted edges by reversing #1 if necessary (that is, if #2 is not a member of the parent graph's EdgeList) *)
edgeShapesF[edges_, gg_] := (If[ MemberQ[edges, #2 | Reverse[#2]],
{Arrowheads[{{OptionValue["arrowSize"], 1}}],
Arrow[If[MemberQ[EdgeList[gg], #2], #1, Reverse[#1]],
OptionValue["setback"]]}, {Arrowheads[{{.0, 1}}], Arrow[#1, .1]}] &);
(* put all together *)
HighlightGraph[grp, pathgraphs, EdgeShapeFunction -> edgeShapesF[pathedges, grp],
FilterRules[{opts}, Options[Graph]]]]]
Examples:
g1 = CompleteGraph[5, VertexSize -> Small, VertexLabels -> Placed["Name", Center], ImageSize -> 300];
g2 = PetersenGraph[5, 2, VertexSize -> Medium, VertexLabels -> Placed["Name", Center], GraphLayout -> Automatic, ImageSize -> 300];
g3 = CycleGraph[20, GraphLayout -> "SpiralEmbedding", VertexSize -> 1, VertexLabels -> Placed["Name", Center], GraphLayout -> "SpiralEmbedding", ImageSize -> 300];
g4 = PolyhedronData["Football", "SkeletonGraph"];
sp1 = {{{1, 3, 5, 2, 4, 1}, {Thick, Orange}}};
sp2 = {{{1, 6, 7, 2, 4, 9, 10, 5, 3, 8}, {Thick, Orange}}};
sp3 = {{{6, 7, 8, 9, 10, 11, 12}, {Thick, Green}}};
sp4 = {{{6, 31, 21, 33, 45, 46, 55}, {Thick, Red}}, {{3, 43, 25, 13, 14, 26, 44}, {Thick, Green}}};
Grid[{{styledPaths[g1, sp1, ImageSize -> 400], styledPaths[g2, sp2, DirectedEdges -> True, ImageSize -> 400]},
{styledPaths[g3, sp3, ImageSize -> 400], styledPaths[g4, sp4, "arrowSize" -> .02, "setback" -> .05, ImageSize -> 400, VertexSize -> .5]}}]
Output:

Multiple paths:
testdata = {{{{5, 1, 4}, {Thick, Red}}, {{2, 3}, {Dashed, Thick, Orange}}},
{{{5, 4, 1}, {Thick, Red}}, {{3, 2}, {Dashed, Thick, Orange}}},
{{{1, 3, 2}, {Thick, Red}}, {{4, 2, 5}, {Dashed, Thick, Orange}}},
{{{1, 3, 2}, {Thick, Red}}, {{4, 3, 5, 1}, {Dashed, Thick, Orange}}},
{{{1, 3}, {Thick, Red}}, {{4, 3, 5}, {Dashed, Thick, Orange}},
{{5,1, 2}, {Dotted, Thick, Purple}}},
{{{3, 4}, {Thick, Red}}, {{4, 1, 5}, {Dashed, Thick, Orange}},
{{1, 3, 5, 2}, {Dotted, Thick, Purple}}}};
Grid[{Row[{"paths = ", #[[All, 1]]}] & /@ testdata[[;; 3]],
styledPaths[g1, #] & /@ testdata[[;; 3]],
Row[{"paths = ", #[[All, 1]]}] & /@ testdata[[4 ;;]],
styledPaths[g1, #] & /@ testdata[[4 ;;]]},
Dividers -> {All, {{True, False}}}, Spacings -> {3, 3}]
Output:
