Wolfram Cloud Document

WOLFRAM NOTEBOOK

In[]:=

interpolatingCurve[pts_]:=Module[{dist,k,coeff,diff,a1,a2,bezier},dist=Norm/@Differences[pts];k=0.5;coeff=Rest[dist]/(Most[dist]+Rest[dist]);diff=Differences[pts,1,2];a1=pts-Join[{{0,0}},k(1-coeff)diff,{{0,0}}];a2=pts+Join[{{0,0}},kcoeffdiff,{{0,0}}];bezier=Arrow@BezierCurve@Flatten[{a1,pts,a2},{{2,1}}][[2;;-2]]]

In[]:=

ClearAll[hypergraphPlot]hypergraphPlot[edges_,opts___]:=Module[{graph,graphPlot,embedding,singleVertexEdges,multiVertexEdges,edgeGraphics,closedVertices,openVertices,vertexGraphics,singleVertexEdgesGraphics,vertexSize,arrowheadSize,expandedEdges,duplicateEdges,intermediateVertices},multiVertexEdges=Select[Length[#]>1&][edges];graph=Graph[DirectedEdge@@@Catenate[Partition[#,2,1]&/@multiVertexEdges]];graphPlot=GraphPlot[graph];vertexSize=Cases[graphPlot,Disk[c_,size_]size,All]〚1〛;arrowheadSize=Cases[graphPlot,Arrowheads[size_]size,All]〚1〛;embedding=Thread[VertexList[graph]GraphEmbedding[graph,"SpringElectricalEmbedding"]];duplicateEdges=KeySelect[#〚1〛=!=#〚2〛&]@Select[#>1&]@Counts[Sort/@EdgeList[graph]];intermediateVertices=Module[{new=Table[Unique[],#〚2〛],direction,newCoords},direction=(#〚1,2〛/.embedding)-(#〚1,1〛/.embedding);newCoords=Function[{displacement},(#〚1,1〛/.embedding)+0.5direction+displacement]/@Table[0.2kRotationMatrix[π/2].direction,{k,Range[-#〚2〛+1,#〚2〛-1]〚1;;-1;;2〛}];embedding=Join[embedding,Thread[newnewCoords]];{#〚1,1〛,#〚1,2〛,new}]&/@Normal@duplicateEdges;expandedEdges=FixedPoint[Replace[#,{l___,v_,v_,r___}Module[{i1=Unique[],i2=Unique[],i3=Unique[],inDirection,outDirection,meanDirection},inDirection=If[Length[{l}]>0,(v/.embedding)-(Last[{l}]/.embedding),Nothing];outDirection=If[Length[{r}]>0,(First[{r}]/.embedding)-(v/.embedding),Nothing];meanDirection=Normalize[Mean[{inDirection,outDirection}]/.Mean[{}]|{0.,0.}{1,0}];embedding=Join[embedding,{i1(v/.embedding)+1.50.15RotationMatrix[0.85π/3].meanDirection,i2(v/.embedding)+1.50.20RotationMatrix[1.5π/3].meanDirection,i3(v/.embedding)+1.50.15RotationMatrix[2.15π/3].meanDirection}];{l,v,i1,i2,i3,v,r}],{1}]&,multiVertexEdges];expandedEdges=Fold[Function[{updatedEdges,allIntermediates},Fold[Replace[#1,{{ll___,{l___,allIntermediates〚1〛,allIntermediates〚2〛,r___},rr___}{ll,{l,allIntermediates〚1〛,#2,allIntermediates〚2〛,r},rr},{ll___,{l___,allIntermediates〚2〛,allIntermediates〚1〛,r___},rr___}{ll,{l,allIntermediates〚2〛,#2,allIntermediates〚1〛,r},rr}}]&,updatedEdges,allIntermediates〚3〛]],expandedEdges,intermediateVertices];edgeGraphics={Arrowheads[arrowheadSize],Directive[Opacity[0.7`],Hue[0.6`,0.7`,0.5`]],interpolatingCurve/@(expandedEdges/.embedding)};closedVertices=Union@Flatten@multiVertexEdges〚All,{1,-1}〛;openVertices=Complement[Union@Flatten@multiVertexEdges,closedVertices];vertexGraphics={{Directive[Hue[0.6`,0.2`,0.8`],EdgeForm[Directive[GrayLevel[0],Opacity[0.7`]]]],Disk[#,vertexSize]&/@(closedVertices/.embedding)},{Directive[White,EdgeForm[Directive[GrayLevel[0],Opacity[0.7`]]]],Disk[#,vertexSize]&/@(openVertices/.embedding)}};singleVertexEdges=Counts[Flatten[Select[Length[#]1&][edges]]];singleVertexEdgesGraphics={Directive[Opacity[0.7`],Hue[0.6`,0.7`,0.5`]],Catenate[Table[Circle[#〚1〛/.embedding,(k+1)vertexSize],{k,#〚2〛}]&/@Normal[singleVertexEdges]]};Graphics[{edgeGraphics,vertexGraphics,singleVertexEdgesGraphics},opts]]

In[]:=