Weighted graphs with sum of weights determining vertex placement?

[Luci Ellis]

Dear all,
Suppose I have a weighted adjacency matrix like this:

rawnums={{0, 43, 25, 70, 92, 75, 83, 69}, {0, 0, 0, 0, 0, 0, 0, 2}, {6,
28, 0, 1, 0,
3, 0, 3}, {26, 1, 2, 0, 4, 1, 7, 14}, {0, 2, 1, 0, 0, 1, 0, 0}, {7, 18, 60,
0, 1, 0, 2, 10}, {49, 2, 2, 6, 3, 7, 0, 1}, {12, 5, 10, 23, 0, 13, 7, 0}}

Some vertex labels:
names = ToString /@ Range[8]

And some code to create a graph with edge thickness based on the
weights, like this:

GraphPlot[Sign[rawnums], DirectedEdges -> True, MultiedgeStyle -> True,
VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .04], Black,
Text[names[[#2]], #1]} &),
EdgeRenderingFunction -> (With[{relexp = (rawnums[[#2[[1]], #2[[2]]]])/
100}, {AbsoluteThickness[relexp*20.],
RGBColor[relexp*0.8, relexp*0.8, relexp*0.8],
Arrowheads[0.06 relexp + 0.008], Arrow[#1, 0.05]}] &),
VertexLabeling -> True, ImageSize -> 500,
ImagePadding -> 0, PlotRange -> All, PlotRangePadding -> 0.02]

How do I get the vertices with the highest total weights (in this case
the sum of each row, since all the columns sum to 100), to sit in the
centre of the graph, with the less connected / lower-weighted vertices
at the periphery? I have tried all the alternatives in the Method
option. VertexCoordinateRules should do the trick, but I have no idea
how to specify those rules according to the weights.
Any suggestions? I am not a graph theorist so this is new to me.

Best regards,
Luci

[Sjoerd C. de Vries]

With the total weigths in the list sums (sums = Total /@ rawnums) I
suppose various constructions like

VertexCoordinateRules -> ((Max[sums] - sums) ({Cos[#], Sin[#]} & /@
Table[i, {i, 0, 2 \[Pi] - 2 \[Pi]/8, 2 \[Pi]/8}]))

or

VertexCoordinateRules -> ((8 -
Ordering[Ordering[sums]]) ({Cos[#], Sin[#]} & /@
Table[i, {i, 0, 2 \[Pi] - 2 \[Pi]/8, 2 \[Pi]/8}]))

may meet your needs.

Cheers -- Sjoerd

On Aug 31, 10:17 am, Luci Ellis <l...@verbeia.com> wrote:
> Dear all,
> Suppose I have a weighted adjacency matrix like this:
>
> rawnums={{0, 43, 25, 70, 92, 75, 83, 69}, {0, 0, 0, 0, 0, 0, 0, 2}, {6,
> 28, 0, 1, 0,

> 3, 0, 3}, {26, 1, 2, 0, 4, 1, 7, 14}, {0, 2, 1, 0, 0, 1, 0, 0}, {7, 1=
8, 60,
> 0, 1, 0, 2, 10}, {49, 2, 2, 6, 3, 7, 0, 1}, {12, 5, 10, 23, 0, 13, 7,=

0}}
>
> Some vertex labels:
> names = ToString /@ Range[8]
>
> And some code to create a graph with edge thickness based on the
> weights, like this:
>
> GraphPlot[Sign[rawnums], DirectedEdges -> True, MultiedgeStyle -> True,

> VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .04], Bla=
ck,

> Text[names[[#2]], #1]} &),

> EdgeRenderingFunction -> (With[{relexp = (rawnums[[#2[[1]], #2[[2]]]=

[Luci Ellis]

Thanks Sjoerd,
This was a really good suggestion. It turns out, though, that some of
the lesser-known options to the function do the trick, namely the
"RepulsiveForcePower" and "StepLength" suboptions to Method ->
"SpringElectricalEmbedding" .
Using a construction like the below gave good results for q = -0.6 and
r = 1.4. NB you get both arrows, on top of one another, using
DirectedEdges -> True, MultiedgeStyle -> False.

Manipulate[
GraphPlot[rawnums, DirectedEdges -> True, MultiedgeStyle -> False,

VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .04],

Black, Text[names[[#2]], #1]} &),

EdgeRenderingFunction -> (With[{relexp = (rawnums[[#2[[1]], #2[[

2]]]])/100}, {AbsoluteThickness[relexp*20.],

RGBColor[relexp*0.8, relexp*0.8, relexp*0.8],
Arrowheads[0.06 relexp + 0.008], Arrow[#1, 0.05]}] &),
VertexLabeling -> True, ImageSize -> 500,

PlotLabel -> Style["Plot Heading", Bold, 14, FontFamily -> "Arial"],
ImagePadding -> 0, PlotRange -> All, PlotRangePadding -> 0.02,
Method -> {"SpringElectricalEmbedding", "RepulsiveForcePower" -> q,
"StepLength" -> r}], {q, -4, -0.01}, {r, 1., 5.}]

This function might come in handy for some purposes. I used it to
verify that you get the same result for adjacency matrices as for
lists of rules, and regardless of whether you actually show all the
multiedges.

AdjacencyMatrixToRules[mat_?MatrixQ] /; Equal @@ Dimensions[mat] :=
With[{n = Length[mat]},
Flatten@(Join @@ Table[Table[i -> j, {mat[[i, j]]}], {i, n}, {j, n}])
]

Hope that helps.

Best regards,
Luci