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
RulePlot for WolframModel
RulePlot for WolframModel
In[]:=
HypergraphPlot[#,VertexLabelsAutomatic]&/@({{1,1},{1,2}}{{1,3},{2,1},{2,2}})
Out[]=
In[]:=
HypergraphPlot[#,VertexLabelsAutomatic]&/@({{v1,p1r,p1y,p1g},{v2,p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{v3,p1g,p3y,p3g},{v4,p1y,p4y,p4g},{v5,p2g,p5y,p5g},{v6,p2y,p6y,p6g},{p3y,p5y},{p3g,p4g},{p4y,p6y},{p4g,p3g},{p5y,p3y},{p5g,p6g},{p6y,p4y},{p6g,p5g}})
Out[]=
Note: we are dealing with node-ordered hypergraphs (i.e. collections of overlapping ordered relations)
In[]:=
InputForm
Hypergraph Updates
Hypergraph Updates
In[]:=
Options[HypergraphPlotX]=Join[Options[Graph],{PlotStyle->ColorData[97]}];
In[]:=
HypergraphPlotX[edges:{___List},o:OptionsPattern[]]:=Module[ normalEdges,vertices,edgeColors,shapeHashes,hashesToColors, graphEdges,graphOptions,graphBoxes,arrowheads,arrowheadOffset, vertexColors, normalEdges=Partition[#,2,1]&/@edges; vertices=Union@Flatten@edges; vertexColors=(#->ColorData[97,Count[edges,{#}]+1]&/@vertices); edgeColors=Sort@Flatten@MapIndexed[ Thread[DirectedEdge@@@#1->OptionValue[PlotStyle][#2[[1]]]]&,normalEdges]; graphEdges=DirectedEdge@@@Flatten[normalEdges,1]; graphOptions=FilterRules[{o},Options[Graph]]; shapeHashes=Sort@(If[#=={},{},#[[1]]]&)@Last@Reap@Rasterize@ GraphPlot[Graph[vertices,graphEdges,Join[ EdgeShapeFunction->(Sow[#2->Hash[#1]]&), graphOptions]]]; graphBoxes=ToBoxes[Graph[graphEdges,DirectedEdges->True]]; arrowheads= If[Length[#]==0,{},#[[1]]]&@Cases[graphBoxes,_Arrowheads,All]; arrowheadOffset=If[Length[#]==0,0,#[[1]]]&@ Cases[graphBoxes,ArrowBox[x_,offset_]:>offset,All]; hashesToColors= Association@Thread[shapeHashes[[All,2]]->edgeColors[[All,2]]]; GraphPlot[Graph[vertices,graphEdges,Join[ graphOptions, EdgeShapeFunction-> arrowheads, hashesToColors[Hash[#1]], Arrow[#1,arrowheadOffset]&, VertexStyle->vertexColors]]]]
In[]:=
HypergraphPlotX[#,VertexLabelsAutomatic]&/@({{v1,p1r,p1y,p1g},{v2,p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{v3,p1g,p3y,p3g},{v4,p1y,p4y,p4g},{v5,p2g,p5y,p5g},{v6,p2y,p6y,p6g},{p3y,p5y},{p3g,p4g},{p4y,p6y},{p4g,p3g},{p5y,p3y},{p5g,p6g},{p6y,p4y},{p6g,p5g}})
Out[]=
In[]:=
HypergraphPlot[#,VertexLabelsAutomatic]&/@({{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p4r,p4y,p1y},{p2g,p5y,p5g},{p6r,p6y,p2y},{p3y,p6y},{p3g,p4r},{p4r,p3g},{p4y,p5y},{p5y,p4y},{p5g,p6r},{p6r,p5g},{p6y,p3y}})
Out[]=
In[]:=
HypergraphPlotX[#,VertexLabelsAutomatic]&/@({{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p4r,p4y,p1y},{p2g,p5y,p5g},{p6r,p6y,p2y},{p3y,p6y},{p3g,p4r},{p4r,p3g},{p4y,p5y},{p5y,p4y},{p5g,p6r},{p6r,p5g},{p6y,p3y}})
Out[]=
In[]:=
NewHypergraphPlot[#,VertexLabelsAutomatic]&/@({{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p4r,p4y,p1y},{p2g,p5y,p5g},{p6r,p6y,p2y},{p3y,p6y},{p3g,p4r},{p4r,p3g},{p4y,p5y},{p5y,p4y},{p5g,p6r},{p6r,p5g},{p6y,p3y}})
Out[]=
In[]:=
NewHypergraphPlot2[#,VertexLabelsAutomatic]&/@({{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p4r,p4y,p1y},{p2g,p5y,p5g},{p6r,p6y,p2y},{p3y,p6y},{p3g,p4r},{p4r,p3g},{p4y,p5y},{p5y,p4y},{p5g,p6r},{p6r,p5g},{p6y,p3y}})
Out[]=
Alternative Versions
Alternative Versions
In[]:=
NewHypergraphPlot[list_,opts___]:=Module[{rules=Flatten[Rule@@@Partition[#,2,1]&/@list],g,rep},g=Graph[rules];rep=Thread[VertexList[g]->GraphEmbedding[g]];Show[Graphics[Style[If[Length[#]>2,Polygon[#/.rep],{}],Opacity[.3]]&/@list],GraphPlot[g,opts]]]
In[]:=
NewHypergraphPlot[#,VertexLabelsAutomatic]&/@(({{v1,p1r,p1y,p1g},{v2,p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{v3,p1g,p3y,p3g},{v4,p1y,p4y,p4g},{v5,p2g,p5y,p5g},{v6,p2y,p6y,p6g},{p3y,p5y},{p3g,p4g},{p4y,p6y},{p4g,p3g},{p5y,p3y},{p5g,p6g},{p6y,p4y},{p6g,p5g}}))
Out[]=