Graph: vary color/length vertextlabels based on frequency

In this example I use a small network of 5 words.

words1 = {{{"word1", "word2"}, 12}, {{"word1", "word3"},
11}, {{"word1", "word4"}, 10}, {{"word2", "word3"},
5}, {{"word2", "word4"}, 5}, {{"word2", "word5"}, 5}}


{{{word1,word2},12},{{word1,word3},11},{{word1,word4},10},{{word2,word3},5},{{word2,word4},5},{{word2,word5},5}}

edgeList = Map[#[[1]] -> #[[2]] &, words1[[All, 1]]]


{"word1" -> "word2", "word1" -> "word3", "word1" -> "word4", "word2" -> "word3", "word2" -> "word4", "word2" -> "word5"}

To visualise this network I use this code:

edgeFun[pts_, e__] :=
BezierCurve[{#, # - {-0.5, 0.5}, #2} & @@ pts[[{1, -1}]]];
pl = Graph[edgeList, DirectedEdges -> True,
VertexLabels -> Placed["Name", Center],
VertexShapeFunction -> "Circle", EdgeShapeFunction -> edgeFun,
ImageSize -> 500, ImagePadding -> 80, Frame -> False]


The output is:

I would like to vary the color and fontsize based on the frequency of the different words.

words2 = {{"word1", 33}, {"word2", 27}, {"word3", 16}, {"word4",
15}, {"word5", 5}};
tally = Reverse@SortBy[words2, Last];
range = {Min@(Last /@ tally), Max@(Last /@ tally)}
words3 = First@# ->
Style[First@#, FontFamily -> "Cracked", FontWeight -> Bold,
FontColor ->
Hue[RandomReal[], RandomReal[{.5, 1}], RandomReal[{.5, 1}]],
FontSize -> Last@Rescale[#, range, {12, 70}]] & /@ tally


The desired output is:

In this example I can use 'VertexLabels' to define de different Characteristics. In my real problem I work with a large set of twitter-messages and thousends of different words. The solutions I thought was

words1 = words /. Rule -> List

pl = Graph[edgeList, DirectedEdges -> True, VertexLabels -> words2,
ImageSize -> 2000, ImagePadding -> 80, Frame -> False]


But this doesn't work

Who has a suggestion to do this on a smarter way?

• What exactly is the problem with the existing code? I agree that it is a bit cumbersome, but it seems to work. Is the problem that it's too slow? – yohbs Jun 24 '15 at 19:38
• You can do this by hand with 5 words. But if you want to create a graph with 5.000 words you I would like to use a smartert way – Michiel van Mens Jun 24 '15 at 19:46

First, let's generate some random words and graph

nWords = 15;
nEdges = 30;
words = RandomSample[DictionaryLookup[___], nWords];
wordsWeight = RandomInteger[{1, 100}, nWords];
edgeList =
Flatten[Table[
UndirectedEdge[words[[i]], words[[j]]], {i, nWords}, {j, nWords}],
1];
edgeList = RandomSample[edgeList, nEdges];
edgeWeight = RandomInteger[{1, 100}, nEdges];


If you want to scale each word and edge by their weight you can use, for example,

vls = Table[
words[[i]] ->
Rescale[wordsWeight[[i]], {Min[wordsWeight],
Max[wordsWeight]}, {10, 20}],
{i, nWords}];
es = Table[
edgeList[[i]] -> Thickness[
Rescale[edgeWeight[[i]], {Min[edgeWeight],
Max[edgeWeight]}, {0.001, 0.01}]],
{i, nWords}];ΒΈ


Then, feed these to VertexLabelStyle and EdgeStyle, e.g.

Graph[edgeList, DirectedEdges -> True,
VertexLabels -> Placed["Name", Center],
VertexShapeFunction -> "Circle",  ImageSize -> 500, ImagePadding -> 80, Frame -> False,
EdgeStyle -> es, VertexLabelStyle -> vls
]


Here's what I get

You can add more stuff to vls and es to tweak colors, fonts, etc.

edgeFun[pts_, e__] :=
BezierCurve[{#, # - {-0.5, 0.5}, #2} & @@ pts[[{1, -1}]]];


function to define edge styles:

estyle[edges_, weight_, color_, thickrange_] :=
Block[{},
ColorData[color][Rescale[#, thickrange, {0, 1}]],
Thickness[#]] & /@
Rescale[weight, {Min[weight], Max[weight]}, thickrange])]
]


function to define vertex label styles:

vlabelstyle[vert_, weight_, color_, vsizerange_] := Block[{},
ColorData[color][Rescale[#, vsizerange, {0, 1}]],
FontFamily -> "Cracked", #] & /@
Rescale[weight, {Min[weight], Max[weight]}, vsizerange])]
]


main function to draw graph:

Options[WordGraph] =
Join[{"VertexColor" -> "DarkRainbow", "EdgeColor" -> "DarkRainbow",
"EdgeThickRange" -> {0.01, 0.05}, "VertexSizeRange" -> {12, 70}},
Options[Graph]];

WordGraph[words_, opts : OptionsPattern[]] :=

Block[{edges, eweights, vert, vweights, vcolor, ecolor, etrange,
vsrange, gopt},
{vcolor, ecolor, etrange, vsrange} = {OptionValue["VertexColor"],
OptionValue["EdgeColor"], OptionValue["EdgeThickRange"],
OptionValue["VertexSizeRange"]};
gopt = FilterRules[Flatten[{opts}], Options[Graph]];
{edges, eweights} = Transpose[{DirectedEdge @@ #, #2} & @@@ words];
{vert, vweights} =
Transpose[{#[[1, 1]], Total[#[[All, 2]]]} & /@
Graph[vert, edges, gopt, EdgeShapeFunction -> edgeFun,
VertexLabels -> "Name",
VertexLabelStyle -> vlabelstyle[vert, vweights, vcolor, vsrange],
EdgeStyle -> estyle[edges, eweights, ecolor, etrange],
GraphStyle -> "ThickEdge"]
]


example 1:

words = {{{"word1", "word2"}, 12}, {{"word1", "word3"},
11}, {{"word1", "word4"}, 10}, {{"word2", "word3"},
5}, {{"word2", "word4"}, 5}, {{"word2", "word5"}, 5}};
WordGraph[words, ImagePadding -> {{10, 100}, {10, 100}}]


example 2:

l = 40; e = 60; words =
Transpose[{RandomChoice[
RandomSample[DictionaryLookup[___], l], {e, 2}],
RandomInteger[{1, 20}, e]}];