22
$\begingroup$

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).

Improve this question
$\endgroup$
6
  • $\begingroup$ I asked this some time ago on MathGroup, but no luck there. $\endgroup$ Commented Mar 2, 2012 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$ Commented Mar 2, 2012 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$ Commented Mar 2, 2012 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$ Commented Mar 2, 2012 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$ Commented Mar 2, 2012 at 14:11

2 Answers 2

Reset to default
11
$\begingroup$

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:

GraphicsRow[
 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
$\endgroup$
2
  • $\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$ Commented Mar 2, 2012 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$ Commented Mar 2, 2012 at 14:13
10
$\begingroup$

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. 

GraphicsGrid[
  Partition[
    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
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.