# Graph generation given number of edges and nodes

I was wondering if it is possible to have Mathematica generate all graphs with a given number of edges and nodes (and possibly restricting the adjacencies) and draw them

I know that there are some commands in Mathematica but I don't quite seem to find this particular one if it exists.

For the physicists among you: I'm basically looking for a way to generate all possible Feynman diagrams at 4 loops given only cubic interaction for 1 or 2 external particles excluding internal bubble graphs :)

-
Do you allow multiple edges and self loops? Are the nodes indistinguishable? –  Szabolcs Dec 6 '12 at 14:14
Multiple Edges: no. Self-loops: no. The nodes are indistinguishable. I am basically looking to generate 4-loop diagrams excluding everything but internalbox-topologies. –  A friendly helper Dec 6 '12 at 14:22
@Afriendlyhelper Can you add a comment on what you might have tried? –  tkott Dec 6 '12 at 16:56
Please see the update to my answer. –  Szabolcs Dec 7 '12 at 1:11

This is what I think you requested, but probably not quite what you want. It gives all graphs without regard to isomorphism, hence the number grows quickly.

toEdgePair[m_] :=
With[{j = Floor[(-1 + Sqrt[1/2 + 8*m])/2] + 1},
UndirectedEdge[m - (j^2 - j)/2, j + 1]]

allGraphs[v_, e_] := Module[
{edges = Subsets[Range[Binomial[v, 2]], {e}]},
edges = Map[toEdgePair[#] &, edges, {2}];
Map[Graph[#, VertexLabels -> "Name"] &, edges]
]


If you prefer long 1-liners...

allGraphs2[v_, e_] :=
Map[Graph[#, VertexLabels -> "Name"] &,
Map[toEdgePair[#] &, Subsets[Range[Binomial[v, 2]], {e}], {2}]]


Here is an example. It gives an idea of what I mean about getting large due to inability to weed out isomorphic "repeats". One could of course do that after the fact. I do not know offhand how to generate efficiently so that there are no such repeats. A somewhat inefficient method in terms of time, but reasonable in memory, would be to generate iteratively. Then check each new graph against all prior retained ones, and discard if it is isomorphic to any of those priors.

allGraphs[5, 6]


-
Thanks a lot! From this I can start :) –  A friendly helper Dec 6 '12 at 15:51
You can Union[..., SameTest -> IsomorphicGraphQ]. Of course it's slow, but for small ones it's okay. That's what I did in my (not yet posted) solution. –  Szabolcs Dec 6 '12 at 16:21
It turns out Combinatorica has a function for this: ListGraphs. –  Szabolcs Dec 7 '12 at 1:11
@Szabolcs Yes, that's probably a more efficient way to go about this. –  Daniel Lichtblau Dec 7 '12 at 2:27

This information is already available - why not just Import it? Brendan McCay lists all graphs up to order 10 (as well as special types of graph to higher order) here: http://cs.anu.edu.au/~bdm/data/graphs.html

Comparing the numbers against that page, we find that GraphData already lists all graphs up to order 7. Thus, for example, you can list all graphs of order 5 as follows:

graphNames = GraphData[5];
Grid[Partition[Table[
Labeled[GraphData[name], name],
{name, graphNames}], 5, 5, {1, 1}, ""],
ItemSize -> 10, Dividers -> All]


Beyond order 7, GraphData is incomplete. Brendand McCay's page lists all graphs up to and including order 10 in Graph 6 format, which Mathematica can import. For example, you can grab all four graphs of order 3 this easily:

Grid[Partition[
Import["http://cs.anu.edu.au/people/bdm/data/graph3.g6", "GraphList"], 2],
Dividers -> All, Spacings -> {3, 3}]


The files get very large, though, so it might make sense to import them as text and grab what you need. For example, here are the last 6 of the 12346 graphs of order 8.

strings = StringSplit[
Import["http://cs.anu.edu.au/people/bdm/data/graph8.g6", "Text"]];
strings // Length
Grid[Partition[
Table[ImportString[s, "Graph6"], {s, strings[[-6 ;;]]}],3],
Dividers -> All, Spacings -> {3, 3}]


Given that there are 12005168 graphs of order 10 and 1018997864 of order 11, I think you are unlikely to improve on this using IsomorphicGraphQ.

-

Update: It turns out Combinatorica has a function for this, called ListGraphs. You can enumerate all graphs with 6 edges and 5 vertices using

<<Combinatorica

ListGraphs[6, 5]

GraphPlot /@ %


This will return all possible non-isomorphic graphs, not only the connected ones. How the function works is described in detail in the book Computational Discrete Mathematics.

However, the book itself mentions that enumerating these graphs is a computationally difficult problem, and recommends using precomputed tables (see Mark McClure's answer).

Unfortunately loading Combinatorica issues a warning since version 8 of Mathematica but as of version 9 there are still lots of useful functions in Combinatorica that are missing from core Mathematics. Also, the book I mentioned is a nice guide to the implementation of the functions and the theory behind them.

Here's an alternative to Daniel's solution. The advantage is that it weeds out more equivalent graphs at the first step, so you should be able to go to higher numbers. Sorry about the messy code.

(* e edges, n vertices *)
gengraphs[e_, n_] /; e <= (n (n - 1))/2 :=
tri[n] /@ Permutations@PadRight[ConstantArray[1, e], (n (n - 1))/2]

(* this arranges elements of a list into an n by n symmetric matrix
hacked together from code by @Mr.Wizard *)
tri[n_][elems_] :=
With[{m =
Take[FoldList[RotateLeft, elems, Range[0, n - 2]], All, n]~ LowerTriangularize~ -1}, m + Transpose[m]]


Now we can weed out graphs that are not connected and those which are isomorphic with each other. For example, for 6 edges and 5 nodes,

Select[Union[AdjacencyGraph /@ gengraphs[6, 5], SameTest -> IsomorphicGraphQ], ConnectedGraphQ]
`

-
{"extraction_info": {"found_math": true, "script_math_tex": 0, "script_math_asciimath": 0, "math_annotations": 0, "math_alttext": 0, "mathml": 0, "mathjax_tag": 0, "mathjax_inline_tex": 0, "mathjax_display_tex": 0, "mathjax_asciimath": 1, "img_math": 0, "codecogs_latex": 0, "wp_latex": 0, "mimetex.cgi": 0, "/images/math/codecogs": 0, "mathtex.cgi": 0, "katex": 0, "math-container": 0, "wp-katex-eq": 0, "align": 0, "equation": 0, "x-ck12": 0, "texerror": 0, "math_score": 0.2230050414800644, "perplexity": 2044.6819768707014}, "config": {"markdown_headings": true, "markdown_code": true, "boilerplate_config": {"ratio_threshold": 0.18, "absolute_threshold": 20, "end_threshold": 15, "enable": true}, "remove_buttons": true, "remove_image_figures": true, "remove_link_clusters": true, "table_config": {"min_rows": 2, "min_cols": 3, "format": "plain"}, "remove_chinese": true, "remove_edit_buttons": true, "extract_latex": true}, "warc_path": "s3://commoncrawl/crawl-data/CC-MAIN-2013-48/segments/1386164026161/warc/CC-MAIN-20131204133346-00020-ip-10-33-133-15.ec2.internal.warc.gz"}