Skip to main content

How can I preserve the properties of edges of the original graph $g$ in a subgraph that doesn't include every edge of $g$?


The closest question to the following I could find was Preserving labels when using graph functions, but it doesn't seem to cover this.


Consider a graph g where every edge is associated with an EdgeStyle.



g = CompleteGraph[3, VertexLabels -> "Name", ImagePadding -> 10];
PropertyValue[{g, 1 \[UndirectedEdge] 2}, EdgeStyle] = Red;
PropertyValue[{g, 1 \[UndirectedEdge] 3}, EdgeStyle] = Green;
PropertyValue[{g, 2 \[UndirectedEdge] 3}, EdgeStyle] = Blue;

enter image description here


I have a method that returns interesting subgraphs of g. Suppose $\{ (1,2),(2,3) \}$ is one such subgraph. How can I create a subgraph that preserves the colors associated with the edges?


I can do


Graph[EdgeList[g], Options[g]]


which gives me the original graph, with the colors preserved. I can also simply do


Graph[EdgeList[g], Options[g, {EdgeStyle}]]

which also works as expected. However, this seems to be so because there's an EdgeStyle for precisely every edge in the options. If there is even one edge in options that is not included in the graph, this won't work. (By not working, I mean something like "the command is not recognized". I don't exactly know how to describe what happens since I'm new to Mathematica.) An example of this unwanted behaviour is


enter image description here


Is there a way I can tell Mathematica "give me the options of the original graph, but only include a setting for each edge that is present in the new graph"? I really only care about EdgeStyle.



Answer



When you have the edges you would like to keep in your sub-graph, then you can select exactly the EdgeStyle's for those. In the following I use Select and MemberQ to select only the style for the edges which are in the sub-graph too. Additionally, I include all other options which were set in the original g.


A function which creates a sub-graph by using a notation equivalent to Part could look like this


GraphPart[g_Graph, edges_List] := 

With[{newEdges = EdgeList[g][[edges]]},
Graph[newEdges,
Sequence @@ DeleteCases[Options[g], EdgeStyle -> _],
EdgeStyle ->
Select[EdgeStyle /. Options[g, EdgeStyle],
MemberQ[newEdges, First[#]] &]
]
]

Test with your example



g = CompleteGraph[3, VertexLabels -> "Name", ImagePadding -> 10];
PropertyValue[{g, 1 \[UndirectedEdge] 2}, EdgeStyle] = Red;
PropertyValue[{g, 1 \[UndirectedEdge] 3}, EdgeStyle] = Green;
PropertyValue[{g, 2 \[UndirectedEdge] 3}, EdgeStyle] = Blue;

GraphPart[g, {1, 3}]

enter image description here


If you want to be able to call your function in the following way {{2,1},{2,3}} with the meaning include the edge connecting vertices 1 and 2 and vertices 2 and 3 you can change the above implementation:


GraphPart[g_Graph, edges_List] := With[{newEdges =

Select[EdgeList[g], MemberQ[Join[edges, Reverse /@ edges], List @@ #] &]},
Graph[newEdges,
Sequence @@ DeleteCases[Options[g], EdgeStyle -> _],
EdgeStyle ->
Select[EdgeStyle /. Options[g, EdgeStyle], MemberQ[newEdges, First[#]] &]]
]

And now you can call GraphPart[g, {{2, 1}, {3, 2}}] without paying attention to the order. The most important part is the 2nd line in the above code. This extracts all matching edges even if the are reversed.


Comments

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]

plotting - Adding a thick curve to a regionplot

Suppose we have the following simple RegionPlot: f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}] Now I'm trying to change the curve defined by $y=g[x]$ into a thick black curve, while leaving all other boundaries in the plot unchanged. I've tried adding the region $y=g[x]$ and playing with the plotstyle, which didn't work, and I've tried BoundaryStyle, which changed all the boundaries in the plot. Now I'm kinda out of ideas... Any help would be appreciated! Answer With f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 You can use Epilog to add the thick line: RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}, PlotPoints -> 50, Epilog -> (Plot[g[x], {x, 0, 2}, PlotStyle -> {Black, Thick}][[1]]), PlotStyle -> {Directive[Yellow, Opacity[0.4]], Directive[Pink, Opacity[0.4]],