Extracting subgraph and edge portions based on spatial coordinates

Question

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}]}]]

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.

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?

Answer 1

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

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}]]

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]]}]]

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

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}]]

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]

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

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}]]

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

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}]

Answer 2

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"]

{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}]]

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]

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