Graph or GraphPlot produce square layouts for disconnected graphs:

Graph[Table[i -> Mod[i^3, 100], {i, 1, 100}]]

Mathematica graphics

I´d like to get a rectangular layout with e.g. aspect ratio 1/2, preferably in combination with the PackingMethod -> "ClosestPackingCenter" option. Setting AspectRatio does not do what I want, because the graph is only rescaled/distorted and not redrawn on a rectanglular grid with said AspectRatio.

Mathematica graphics

Is there a way to achieve something like this (emulated by a gridded copy of the first graph)?

Mathematica graphics

Addition: Because of the added interactive graph functionality in newer versions, a solution leaving this functionality intact would be preferrable (and probably more compatible with future developments).

  • $\begingroup$ I asked this some time ago on MathGroup, but no luck there. $\endgroup$ – Yves Klett Mar 2 '12 at 12:58
  • 1
    $\begingroup$ In the very worst case, you can implement your own packing method. That's a lot of work, but Heike has implemented a pretty good packing algorithm here that can do non isotropic shapes. I'd probably still take at least 30 minutes to understand the algorithm and adapt it to graphs. Another idea is using nested boxes to pack them, but again---a lot of work. $\endgroup$ – Szabolcs Mar 2 '12 at 13:06
  • $\begingroup$ I am rather hoping that I am not the only one with this desire and that someone will flourish an undocumented option to spare me the pain. $\endgroup$ – Yves Klett Mar 2 '12 at 13:14
  • $\begingroup$ How did you work around it in the past? Did you break the graph into two and showed them side by side? That'd be a workable---if not pretty---solution. (Yes, this is a very good question and there should be an option.) $\endgroup$ – Szabolcs Mar 2 '12 at 13:19
  • 1
    $\begingroup$ Well, this technical question would profit too from the collision-detection required for this artistic problem. It's a pity one cannot access the internal algorithm used by Method -> "ClosestPackingCenter"... $\endgroup$ – István Zachar Mar 2 '12 at 14:11

Well, this is just a workaround. Let's make a graph:

g = Graph@Table[i -> Mod[i^3, 300], {i, 1, 300}];

It looks like this:

GraphPlot[g, PackingMethod -> "ClosestPackingCenter"]

Mathematica graphics

Let's break it into two components, distributing connected components of similar sizes equally between the two:

cc = SortBy[ConnectedComponents@UndirectedGraph[g], Length];

c1 = Flatten[cc[[1 ;; ;; 2]]];
c2 = Flatten[cc[[2 ;; ;; 2]]];

Now let's show them size by side:

 GraphPlot[Subgraph[g, #], PackingMethod -> "ClosestPackingCenter", 
    PlotRangePadding -> 0] & /@ {c1, c2},
 Spacings -> 0

Mathematica graphics

Not perfect, but might be good enough for a paper or presentation. This will only look good with the ClosestPackingCenter option but that is what you were asking for specifically.

Alternatively, you can use Heike's packing algorithm. I used the simplest version because it was faster, but you should use the updated version which produces vector images (it'll be a bit more work though).

images = ImageCrop@
     Rasterize[#, "Image", ImageSize -> 50, 
      ImageResolution -> 4 72] & /@ (GraphPlot[Subgraph[g, #], 
       PlotRangePadding -> 0] &) /@ Reverse[cc];

padimg = ImagePad[#, 5, White] & /@ images;

iteration[img1_, w_, fun_: (Norm[#1 - #2] &)] := 
 Module[{imdil, centre, diff, dimw, padding, padded1, minpos},
  dimw = ImageDimensions[w];
  padded1 = ImagePad[img1, {dimw[[1]] {1, 1}, dimw[[2]] {1, 1}}, 1];

  imdil = MaxFilter[Binarize[ColorNegate[padded1], 0.01], 
    Reverse@Floor[dimw/2 + 2]];
  centre = ImageDimensions[padded1]/2;

  minpos = Reverse@Nearest[Position[Reverse[ImageData[imdil]], 0], 
      Reverse[centre], DistanceFunction -> fun][[1]];
  diff = ImageDimensions[imdil] - dimw;
  padding[pos_] := Transpose[{#, diff - #} &@Round[pos - dimw/2]];

  ImagePad[#, (-Min[#] {1, 1 }) & /@ BorderDimensions[#]] &@
   ImageMultiply[padded1, ImagePad[w, padding[minpos], 1]]]

fun = Norm[{1, 1/2} (#2 - #1)] &;

Fold[iteration[##,fun]&, padimg[[1]], Rest[padimg]]

Mathematica graphics

Most of the code here is directly copied from her post.

If we make some effort to preserve sizes as well, we get this:

Mathematica graphics

I used this code to generate the images for this (with some manual tweaking):

plots = GraphPlot[Subgraph[g, #]] & /@ Reverse[cc];

images = ImageCrop@
     Image@Show[#, PlotRange -> 2.5 {{-0.1, 1}, {-0.1, 1}}, 
       ImageSize -> 100] & /@ plots;

padimg = ImagePad[#, 5, White] & /@ images;
| improve this answer | |
  • $\begingroup$ It is especially for the papers that I tend to spend insane amounts of time with twiddling to make it look really good - in blatant violaton of the pareto principle. Good idea to sort interleaving. $\endgroup$ – Yves Klett Mar 2 '12 at 13:50
  • $\begingroup$ @Yves Here's and edit proving that Heike's packing code is applicable, but I didn't knead it into a reusable shape. I just rasterized everything and slapped her method on it. $\endgroup$ – Szabolcs Mar 2 '12 at 14:13

You could start by getting a handle on the weakly connected graph components.

g = Graph[Table[i -> Mod[i^3, 100], {i, 1, 100}], 
          VertexLabels -> "Name", ImagePadding -> 15]

weaklyConnected = ConnectedComponents[UndirectedGraph[g]]

GraphicsGrid can arrange the components in a table. Spacings allows allows you to set the approximate aspect ratio. The following results in 8 graph components per row.

    Subgraph[g, #, 
      EdgeShapeFunction -> GraphElementData[{"CarvedArrow", "ArrowSize" -> .1}], 
      DirectedEdges -> True] & /@ weaklyConnected, 8], ImageSize -> 450,
      Spacings -> {Automatic, 150}]

Graph components

Below are 6 components per row, with Spacings -> {150, 0}:

six components per row

| improve this answer | |

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.