2
$\begingroup$

Suppose I have a graph:

RandomSeed[1000];
g = RandomGraph[{20, 50},
   VertexLabels -> "Name"];

which has been laid out or embedded by some automatic specification (i.e., I did not place the vertexes explicitly). Suppose I'm interested in a spatial region of this graph, for instance as outlined in red here:

Show[g, 
   Graphics[{EdgeForm[Red], FaceForm[None], 
   Rectangle[{1.2, 0.2}, {2.2, 1.2}]}]]

enter image description here

I'd like to "zoom in" and extract the subgraph defined by the vertexes within the defined bounding box and the edges, some of which extend outside the region.

enter image description here

I can select the vertex coordinates within the bounding box, for instance:

Select[(VertexCoordinates /. AbsoluteOptions[g, VertexCoordinates]), 
 1.2 < #[[1]] < 2.2 && 0.2 < #[[2]] < 1.2 &]

but I do not see how to extract the vertex identities and the edges (and partial edges) within the bounding box.

I would like to extract this information in Graph form so I can re-render the portion of the graph, possibly re-label or re-color vertexes, and such. A pure "image based" solution (extracting the image region) is not acceptable for my application. Moreover, I need to retain the spatial locations of the enclosed vertexes so I can scale and replot such that the layout is the same (only larger). In short, cannot merely extract the vertexes and link identities and re-layout the subgraph information with a different embedding.

I don't mind having a list of the full edges that traverse the region; I can plot the resulting graph and then spatially truncate it by Show[ mySubGraphInformation, {{xL, xH},{yL, yH}}].

How can I do this?

$\endgroup$
2
$\begingroup$

Update 3: For an arbitrary cropping region, for example

rp = RandomPoint[Rectangle @@ transpose[MinMax /@ Transpose[GraphEmbedding[g]]], 4];
region = BoundingRegion[rp, "FastEllipse"];

it is slow, but we get

enter image description here

Update 2: Rolling all steps into a function that returns a list of edges and vertices that intersect the input rectangle and a list of graphics primitives (points and portions of edges that lie in the input rectangle):

ClearAll[cropG]
cropG[g_, region_] := Module[{cTov = Thread[GraphEmbedding[g] -> VertexList[g]], 
 prims = Cases[Normal[Show[g][[1]]], _Arrow | _Disk, {0, ∞}] /. 
     {Disk[a_, _] :> Point[a],
      Arrow[BezierCurve[b_, ___], _] :> Line[BezierFunction[b] /@ Subdivide[0, 1, 100]],
      Arrow[c_, _] :> Line[c]}, 
 primsToParts = {Line[a_] :> (UndirectedEdge @@ a[[{1, -1}]]), Point[b_] :> b}}, 
 Transpose @ DeleteCases[{Replace[#, Join[cTov, primsToParts ], {0, ∞}], 
       RegionIntersection[region, #]} & /@ prims, {_, _EmptyRegion}]]

Examples:

cropG[g, rect][[1]]

{1 <-> 5, 2 <-> 5, 3 <-> 5, 4 <-> 5, 4 <-> 9, 4 <-> 12, 4 <-> 15, 4 <-> 16, 4 <-> 19, 5 <-> 11, 5 <-> 19, 5 <-> 20, 11 <-> 20, 12 <-> 20, 15 <-> 20, 4, 5}

cropG[g2, rect2][[1]]

{1 <-> 15, 1 <-> 19, 1 <-> 20, 2 <-> 15, 2 <-> 19, 3 <-> 17, 3 <-> 19, 3 <-> 20, 4 <-> 15, 4 <-> 19, 5 <-> 11, 5 <-> 19, 5 <-> 20, 6 <-> 17, 7 <-> 17, 8 <-> 20, 10 <-> 14, 10 <-> 19, 11 <-> 12, 11 <-> 13, 11 <-> 20, 12 <-> 20, 13 <-> 20, 14 <-> 15, 14 <-> 20, 15 <-> 20, 16 <-> 19, 17 <-> 20, 11, 15, 17, 19, 20}

Update: Getting all edges, edge portions and vertices that intersect the rectangle. (Borrowing/stealing the BezierFunction idea from @Carl's answer to convert BezierCurves to Lines)

SeedRandom[1];
g = RandomGraph[{20, 50}, VertexLabels->"Name"];
rect = Rectangle[{1.2, 0.2}, {2.2, 1.2}];
Show[g, Graphics[{EdgeForm[Red], FaceForm[None],    rect}]]

enter image description here

vcToVertex = PropertyValue[{g, #}, VertexCoordinates] -> # & /@VertexList[g];

primitives = Cases[Normal[Show[g]], _Arrow|_Disk,{0, Infinity}] /.
   {Disk[a_, _] :> Point[a], 
   Arrow[BezierCurve[x_,___],_] :> Line[BezierFunction[x]/@Subdivide[0, 1, 100]], 
   Arrow[y_,_]:>Line[y]};

primitivesInRectangle = DeleteCases[{Replace[#, Join[vcToVertex, 
 {Line[z_] :> (UndirectedEdge @@ z[[{1,-1}]]), Point[p_]:>p}], {0, ∞}], 
  RegionIntersection[rect, #]}& /@ primitives, {_,_EmptyRegion}];

portionsInRectangle = primitivesInRectangle[[All, 2]];
edgesAndVertices = primitivesInRectangle[[All, 1]]

{1 <-> 5, 2 <-> 5, 3 <-> 5, 4 <-> 5, 4 <-> 9, 4 <-> 12, 4 <-> 15,
4 <-> 16, 4 <-> 19, 5 <-> 11, 5 <-> 19, 5 <-> 20, 11 <-> 20, 12 <-> 20, 15 <-> 20,
4, 5}

Show[g, Graphics[{EdgeForm[Red], FaceForm[None],  rect, Thick, 
   PointSize[.03], Blue, primitivesInRectangle[[All, 2]]}]]

enter image description here

Show[HighlightGraph[g, Style[#, Thick,Orange]& /@ edgesAndVertices], 
  Graphics[{EdgeForm[Red], FaceForm[], rect}]]

enter image description here

An example with curved edges:

SeedRandom[1];
g2 = RandomGraph[{20, 50}, VertexLabels->"Name", GraphLayout->"LayeredDigraphEmbedding"];
rect2 = Rectangle[{-5,-.5}, {.5, 2.5}];
Show[g2, Graphics[{EdgeForm[Red], FaceForm[None],  rect2}]]

enter image description here

edgesAndVertices:

{1 <-> 15, 1 <-> 19, 1 <-> 20, 2 <-> 15, 2 <-> 19, 3 <-> 17, 3 <-> 19,
3 <-> 20, 4 <-> 15, 4 <-> 19, 5 <-> 11, 5 <-> 19, 5 <-> 20,
6 <-> 17, 7 <-> 17, 8 <-> 20, 10 <-> 14, 10 <-> 19, 11 <-> 12,
11 <-> 13, 11 <-> 20, 12 <-> 20, 13 <-> 20, 14 <-> 15, 14 <-> 20,
15 <-> 20, 16 <-> 19, 17 <-> 20,
11, 15, 17, 19, 20}

Show[g2, Graphics[{EdgeForm[Red], FaceForm[None],  rect2, Thick, 
   PointSize[.02], Blue, primitivesInRectangle[[All, 2]]}], ImageSize -> 500]

enter image description here

Show[HighlightGraph[g2, Style[#, Orange, Thick]& /@ edgesAndVertices], 
 Graphics[{EdgeForm[Red], FaceForm[None],  rect2}], ImageSize -> 500]

enter image description here

Original answer:

A partial answer for the easier part of the requirements:

rect = Rectangle[{1.2, 0.2}, {2.2, 1.2}];
verticeInRect = Select[VertexList[g], 
   RegionMember[rect, PropertyValue[{g, #}, VertexCoordinates]] &];

g2 = Show[HighlightGraph[g, verticeInRect], 
  Graphics[{EdgeForm[Red], FaceForm[None], rect}]]

enter image description here

Show[g2, PlotRange->(Transpose[{##}]&@@rect), ImageSize->300]

enter image description here

Note: Show produces a Graphics object. To zoom on part of g without turning g into Graphics, you can use

SetProperty[g, {PlotRange -> (Transpose[{##}] & @@ rect),  ImageSize -> 300}]

enter image description here

$\endgroup$
  • $\begingroup$ Very nice (+1). This may be enough for an accept... let me play around with it for a while first. Wait... how did your RegionMember extract the portion of the edge linking two vertices both outside the bounding box? $\endgroup$ – David G. Stork Oct 12 '17 at 1:23
  • $\begingroup$ @David, RegionMember checks just the vertex coordinates. Capturing edges requires more effort ,that is, this is a partial answer:) $\endgroup$ – kglr Oct 12 '17 at 2:25
  • $\begingroup$ @David, hope the updated version is complete. $\endgroup$ – kglr Oct 12 '17 at 7:13
  • $\begingroup$ kglr: Bravo! A tour de force. Thanks so much. $\endgroup$ – David G. Stork Oct 12 '17 at 16:26
  • $\begingroup$ David, my pleasure. Thank you for the accept. $\endgroup$ – kglr Oct 12 '17 at 16:44
1
$\begingroup$

It's a very good idea to choose a random seed so that others can generate the same random graph, but you should be using SeedRandom (instead of RandomSeed)!

At any rate, one idea is to annotate the Graph with tooltips, and then look at the rendered graphics to see whether the vertices and labels intersect the rectangle of interest. The following code executes this idea:

extractParts[g_, rectangle_] := Cases[
    Show @ Graph[
        g,
        VertexLabels->Placed["Name",{Automatic,Tooltip}],
        EdgeLabels->Placed["Name",Tooltip]
    ],
    Tooltip[a_,label_] /; regionQ[a,rectangle] :> label,
    Infinity
]

regionQ[t_,rectangle_] := !MatchQ[
    RegionIntersection[rectangle, toRegion[t]],
    EmptyRegion[2]
]

toRegion[t_] := First@Cases[t, p_Disk|p_Arrow :> iRegion[p], Infinity]

iRegion[Disk[a__]] := Disk[a]
iRegion[Arrow[BezierCurve[a_], _]] := Line[BezierFunction[a]/@Subdivide[0, 1, 100]]
iRegion[Arrow[a_, _]] := Line[a]

Here I apply extractParts to a random graph (using SeedRandom so you can also generate the same graph):

SeedRandom[8];
g = RandomGraph[{20,50}, VertexLabels->"Name"]

enter image description here

{1 <-> 4, 1 <-> 7, 1 <-> 9, 1 <-> 10, 1 <-> 15, 2 <-> 8, 3 <-> 8, 6 <-> 8, 7 <-> 8, 8 <-> 11, 10 <-> 17, 1, 8}

Update

(I incorporated @kglr's idea of using Show[g] to convert a Graph object to a Graphics object. I also added support for BezierCurve arrows)

extractParts[g_, rectangle_] := Cases[
    Show @ Graph[
        g,
        VertexLabels->Placed["Name",{Automatic,Tooltip}],
        EdgeLabels->Placed["Name",Tooltip]
    ],
    Tooltip[a_,label_] /; regionQ[a,rectangle] :> label,
    Infinity
]

regionQ[t_,rectangle_] := !MatchQ[
    RegionIntersection[rectangle, toRegion[t]],
    EmptyRegion[2]
]

toRegion[t_] := First@Cases[t, p_Disk|p_Arrow :> iRegion[p], Infinity]

iRegion[Disk[a__]] := Disk[a]
iRegion[Arrow[BezierCurve[a_], _]] := Line[BezierFunction[a]/@Subdivide[0, 1, 100]]
iRegion[Arrow[a_, _]] := Line[a]

Here is a graph with curved edges:

SeedRandom[1];
g = RandomGraph[
    {20,50},
    VertexLabels->"Name",
    GraphLayout->"LayeredDigraphEmbedding"
];
rectangle = Rectangle[{1.2,0.2},{2.2,1.2}];
Show[g, Graphics[{Opacity[.4], rectangle}]]

enter image description here

And here is the result of using extractParts:

extractParts[g, rectangle]

{1 <-> 20, 3 <-> 20}

And, here is a different rectangle:

rectangle = Rectangle[{-4, 1}, {-3, 2}];
Show[g, Graphics[{Opacity[.4], rectangle}]]

extractParts[g, rectangle]

enter image description here

{1 <-> 19, 2 <-> 19, 3 <-> 17, 3 <-> 19, 4 <-> 15, 4 <-> 19, 5 <-> 19, 10 <-> 19, 11 <-> 12, 11 <-> 13, 16 <-> 19, 11, 19}

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.