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 with self-loops
HypergraphPlot with self-loops
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[]=
In[]:=
ClearAll[flatPolygonGraph];flatPolygonGraph[ns_List,opts___]:=With[{separateGraphs=If[#>2,Graph[UndirectedEdge@@@Flatten[List@@@MeshCells[triangulatedPolygon[#,opts],1],1]],If[#2,Graph[{13,34,45,56,67,78,89,910,102},DirectedEdgesFalse],Graph[{1},{}]]]&/@ns},Reap[FoldList[With[{indexGraph=Sow[VertexReplace[#2,n_n+#1-1]]},Max@VertexList[indexGraph]+1]&,1,separateGraphs]]〚2,1〛]
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[]:=
ClearAll[polygonFaces];polygonFaces[n_,opts___]/;n>2:=Flatten[List@@@MeshCells[triangulatedPolygon[n,opts],2],1]polygonFaces[1|2,opts___]:={}
In[]:=
HypergraphPlotSW[polygonFaces[3]]
Out[]=
In[]:=
?MeshConnectivityGraph
Out[]=
In[]:=
Graph[MeshConnectivityGraph[TriangulateMesh[RegularPolygon[3]],0],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic]
Out[]=
In[]:=
ClearAll[origamiCoordinates];origamiCoordinates[shapes:{{__}..},opts___]:=With[{graphs=flatPolygonGraph[Length/@shapes,opts]},With[{identifications=Catenate@MapIndexed[Sort[VertexList[graphs[[#2[[1]]]]]][[#2[[2]]]]With[{firstPosition=FirstPosition[shapes,#]},Sort[VertexList[graphs〚firstPosition〚1〛〛]]〚firstPosition〚2〛〛]&,shapes,{2}]},Join[#,identifications/.(a_b_)(a(b/.#))]&@Thread[VertexList[#]GraphEmbedding[#,"SpringElectricalEmbedding",3]&@VertexReplace[Graph[Catenate[EdgeList/@{##}]]&@@graphs,identifications]]]]
In[]:=
OrderedHypergraphPlot[{{1,2,3,4},{4,5,6,7},{7,8,9,1},{1,4,7}}]
Out[]=
In[]:=
relationGraphics[{{1,2,3,4},{4,5,6,7},{7,8,9,1},{1,4,7}}]
Out[]=
Examples
Examples