# Deleting vertices from a Graph and preserving structure

My goal is to remove vertices from graphs (and the edges from them) and then take GraphComplement to find out cut sets in graphs with sink and source such as here. So

How can I delete vertices from a graph and preserve the earlier structure?

Trials

Trial 1. Failures in trying to remove vertices fom HararyGraph.

The structure is not preserved for which SetProperty (?) and the repetitive assignment after each removal failing -- the table below removes the other vertex from new graph not from the one where one vertex was already removed. Trial 2. Failure in trying to remove vertices repetively from GridGraph, based on the case where only one removal. Trial 3. Question here to be more clear.

SeedRandom;
dimension = 5;
coDimension = 10;
percProbability = 0.7;
deleteMe =
Pick[Table[i, {i, 1, 30}], Table[RandomReal[] > 0.5, {i, 30}]]

g = GridGraph[{dimension, coDimension}, VertexLabels -> "Name",
H = SetProperty[VertexDelete[g, #],
VertexCoordinates -> Delete[GraphEmbedding[g], #]] & @@ deleteMe

H = SetProperty[VertexDelete[g, deleteMe],
VertexCoordinates -> Delete[GraphEmbedding[g], deleteMe]] We are searching for perhaps relevant questions below.

Ps. For the mincut goal, Alert! Alert about bug in at least 10.1 Mathematica in using Mathematica's own cut command: Finding the minimum vertex cut of a graph. Also notice that VertexConnectivity command bugging, Is there something wrong with VertexConnectivity.

You can use vertexDeleteKeepEmbedding which is a side effect of Clickable graph answer:

gr = CompleteGraph[17, PlotRange -> 2]

FoldList[
vertexDeleteKeepEmbedding,
gr,
RandomSample @ Most @ VertexList @ gr
] // ListAnimate


## vertexDeleteKeepEmbedding[graph_, vertex_] := Module[{
coords, vertices = VertexList[graph]
}
,
coords = DeleteCases[vertices, vertex] /. Thread[
vertices -> GraphEmbedding[graph]
];

Graph[VertexDelete[graph, vertex], VertexCoordinates -> coords]
];

• I added the Trial 3 with GridGraph: Can you demonstrate it with this method? SeedRandom; dimension = 5; coDimension = 10; percProbability = 0.7; deleteMe = Pick[Table[i, {i, 1, 30}], Table[RandomReal[] > 0.5, {i, 30}]] gr = GridGraph[{dimension, coDimension}, VertexLabels -> "Name", ImagePadding -> 30] H = SetProperty[VertexDelete[g, #], VertexCoordinates -> Delete[GraphEmbedding[g], #]] & @@ deleteMe FoldList[vertexDeleteKeepEmbedding, gr, RandomSample@Most@deleteMe@gr], something like this?
– hhh
Jul 9 '16 at 20:10

The solution for the GridGraph here. You need to fix the VertexCoordinates before deletions.

G = SetProperty[G, VertexCoordinates -> GraphEmbedding[G]];
VertexDelete[G, deleteMe]