You are using a browser not supported by the Wolfram Cloud
Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.
I understand and wish to continue anyway »
WOLFRAM NOTEBOOK
HypergraphPlot: Nontrivial relation shapes
HypergraphPlot: Nontrivial relation shapes
HypergraphPlotSW
HypergraphPlotSW
In[]:=
HypergraphPlotSW[list_,opts___]:=Module[{wtfun=(1/Length[#]&),rules=Flatten[Function[e,Annotation[#,EdgeWeight(wtfun[e])]&/@(If[Length[e]>2,Append[#,Style[Last[e]First[e],Opacity[0]]],#]&@(Rule@@@Partition[e,2,1]))]/@list],g,rep},g=Graph[rules,opts];rep=Thread[VertexList[g]->GraphEmbedding[g]];GraphPlot[g,Prolog{Style[If[Length[#]>2,Polygon[#/.rep],{}],Opacity[.3],Lighter[Blue,.7]]&/@list},opts]]
New code
New code
We still assume each relation is a polygon, however, we now simulate this polygon with a triangulated region, which we embed with SpringElectricalEmbedding after identifying some corner vertices.
We thus get effects similar to “bending paper”.
In[]:=
?TriangulateMesh
Out[]=
In[]:=
triangulatedPolygon[n_,opts___]:=TriangulateMesh[RegularPolygon[n],opts]
In[]:=
triangulatedPolygon/@{3,4,8}
Out[]=
flatPolygonGraph[n_,opts___]:=Graph[UndirectedEdge@@@Flatten[List@@@MeshCells[triangulatedPolygon[n,opts],1],1]]
In[]:=
flatPolygonGraph$new[n_,opts___]:=Graph[MeshConnectivityGraph[TriangulateMesh[RegularPolygon[n]],0],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic,opts]
In[]:=
RepeatedTiming[flatPolygonGraph$old[4]]
Out[]=
In[]:=
RepeatedTiming[flatPolygonGraph$new[4]]
Out[]=
In[]:=
flatPolygonGraph/@{3,4,8}
Out[]=
The faces can be extracted which we will use for visualizing the polygon:
In[]:=
polygonFaces[n_,opts___]:=Flatten[List@@@MeshCells[triangulatedPolygon[n,opts],2],1]
In[]:=
HypergraphPlotSW[polygonFaces[3]]
Out[]=
In[]:=
?MeshConnectivityGraph
Out[]=
In[]:=
Graph[MeshConnectivityGraph[TriangulateMesh[RegularPolygon[3]],0],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic]
Out[]=
In[]:=
origamiCoordinates[shape:{__Integer},opts___]:=With[{identifications=MapIndexed[#2〚1〛FirstPosition[shape,#]〚1〛&,shape]},Join[#,identifications/.(a_b_)(a(b/.#))]&@Thread[VertexList[#]GraphEmbedding[#]&@VertexReplace[flatPolygonGraph[Length[shape],opts],identifications]]]
In[]:=
polygonGraphics[shape:{__Integer},opts___]:=Graphics[Style[Polygon[#],Opacity[.3],Lighter[Blue,.7]]&/@(polygonFaces[Length[shape],opts]/.origamiCoordinates[shape,opts])]
Cache FindShortestPath, and other things.
In[]:=
edgeGraphics[shape:{__Integer},opts___]:=With[{graph=flatPolygonGraph[Length[shape],opts]},With[{coordinateRules=origamiCoordinates[shape,opts],vertexSequences=FindShortestPath[graph,##]&@@@Partition[Range[Length[shape]],2,1]},Graphics[Style[Arrow[#],Hue[0.6,0.7,0.5],Opacity[0.7]]&/@(vertexSequences/.coordinateRules)]]]
In[]:=
vertexGraphics[shape:{__Integer},opts___]:=With[{coordinateRules=origamiCoordinates[shape,opts]},Graphics[Style[Disk[#/.coordinateRules,0.2],Hue[0.6`,0.2`,0.8`],EdgeForm[{GrayLevel[0],Opacity[0.7`]}]]&/@Range[Length[shape]]]]
In[]:=
relationGraphics[shape:{__Integer},opts___]:=Show[polygonGraphics[shape,opts],edgeGraphics[shape,opts],vertexGraphics[shape,opts]]
Examples
Examples
In[]:=
relationGraphics[{1,2,3}]
Out[]=