4
$\begingroup$

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:

enter image description here

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:

enter image description here

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?

$\endgroup$
  • $\begingroup$ 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? $\endgroup$ – yohbs Jun 24 '15 at 19:38
  • $\begingroup$ 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 $\endgroup$ – Michiel van Mens Jun 24 '15 at 19:46
4
$\begingroup$

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

enter image description here

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

$\endgroup$
1
$\begingroup$

Your edge functions:

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

function to define edge styles:

estyle[edges_, weight_, color_, thickrange_] :=
 Block[{},
  Thread[edges -> (Directive[
        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[{},
  Thread[vert -> (Directive[
        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]]]} & /@ 
     GatherBy[Flatten[Thread /@ words, 1], First]];
  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}}]

enter image description here

example 2:

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

WordGraph[words, "VertexColor" -> "AvocadoColors", 
 "EdgeColor" -> "SouthwestColors", "VertexSizeRange" -> {5, 30}, 
 "EdgeThickRange" -> {0.001, 0.015}, 
 ImagePadding -> {{10, 40}, {10, 40}}]

enter image description here

$\endgroup$

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.