Vertex Names of Subgraph in Order of Connectivity

Question

I extract path subgraphs $P_4$ of an undirected graph $G$. And want to list the VertexNames of the subgraphs in the same order as they are connected.

Here is an example:

g = Graph[{6 <-> 7, 1 <-> 6, 3 <-> 1, 3 <-> 2, 5 <-> 4, 3 <-> 4}, 
VertexLabels -> "Name", ImagePadding -> 10];
h = Subgraph[g, {1, 3, 6, 7}, VertexLabels -> "Name", ImagePadding -> 10]
HighlightGraph[g, h]
VertexList[h]

VertexList[h] always gives the vertex names in the order specified in line 5. Is it possible to extract the vertex names in the order of connectivity? The given example should give {3,1,6,7} or the reverse instead of {1,3,6,7}.

Answer 1

The following will only work with Subgraph being a PathGraph.

g = Graph[{6 <-> 7, 1 <-> 6, 3 <-> 1, 3 <-> 2, 5 <-> 4, 3 <-> 4}];
h = Subgraph[g, {1, 3, 6, 7}];
SortBy[
  Thread[{VertexList@h, Chop@AbsoluteOptions[h, VertexCoordinates][[2]]}], 
  Last][[All, 1]]

{3,1,6,7}

Answer 2

Update:

sortedVF[g_?UndirectedGraphQ] := 
 Module[{c1 = First@GraphPeriphery[g], c2 = Last@GraphPeriphery[g]}, 
   SortBy[VertexList[g], {GraphDistance[g, c1, #] &, - GraphDistance[g, c2, #] &}]];

sortedVF[h]
(* {3, 1, 6, 7} *)

DeleteDuplicates[sortedVF /@ (Subgraph[g, #] & /@ Permutations[{1, 3, 6, 7}])]
(* {{3, 1, 6, 7}, {7, 6, 1, 3}} *)

Another example:

g2 = PetersenGraph[6, 2, VertexLabels -> "Name", ImagePadding -> 10];
h2 = Subgraph[g2, {1, 3, 5, 11, 7, 8}];
Row[{g2, HighlightGraph[g2, h2]}]

DeleteDuplicates[sortedVF /@ (Subgraph[g2, #] & /@ Permutations[{1, 3, 5, 11, 7, 8}])]
(* {{11, 5, 3, 1, 7, 8}, {8, 7, 1, 3, 5, 11}}  *)

---

Note: the original post below skips nodes that are not on the shortest-path.

The following function from the docs GraphDiameter>>Applications seems to do what is needed:

findDiameterPath[g_?UndirectedGraphQ] := Module[{d = GraphDistanceMatrix[g], u, v, pos}, 
   pos = First@Position[d, Max[d]];
   {u, v} = Part[VertexList[g], pos];
   PathGraph@FindShortestPath[g, u, v]];

g = Graph[{6 \[UndirectedEdge] 7, 1 \[UndirectedEdge] 6, 
    3 \[UndirectedEdge] 1, 3 \[UndirectedEdge] 2, 
    5 \[UndirectedEdge] 4, 3 \[UndirectedEdge] 4}, 
      VertexLabels -> "Name", ImagePadding -> 10];
h = Subgraph[g, {1, 3, 6, 7}, VertexLabels -> "Name", ImagePadding -> 10];

VertexList[findDiameterPath[Subgraph[g, h]]]
(* {3, 1, 6, 7} *)

DeleteDuplicates[VertexList[findDiameterPath[#]] & /@ (Subgraph[g, #] & /@ 
    Permutations[{1, 3, 6, 7}])] 
(*  {{3, 1, 6, 7}, {7, 6, 1, 3}} *)