Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I have some data of corporate board members in Australia in excel format here (Dropbox public link). It is the data behind this graph. The first worksheet is of all the vertexes (directors and companies with a unique ID for each, and a market capitalisation to use for weighting the size of vertexes in displayed graphs). The second worksheet is the relationship between companies and directors (edges).

The edges table looks a bit like this

{{"Source", "Target"}, {"BHP BILLITON", 
  "Mr Alberto Calderon"}, {"BHP BILLITON", 
  "Mr Andrew Mackenzie"}, {"BHP BILLITON", 
  "Mr Brendan Harris"}, {"BHP BILLITON", 
  "Mr Carlos Cordeiro"}, {"BHP BILLITON", 
  "Ms Carolyn Hewson"}, {"BHP BILLITON", 
  "Mr David Crawford, AO"}, {"BHP BILLITON", 
  "Mr Graham Kerr"}, {"BHP BILLITON", 
  "Mr Jac Nasser, AO"}, {"BHP BILLITON", 
  "Dr John Buchanan"}, {"BHP BILLITON", 
  "Dr John Schubert, AO"}, {"BHP BILLITON", 
  "Ms Karen Wood"}, {"BHP BILLITON", 
  "Mr Keith Rumble"}, {"BHP BILLITON", "Mr Lindsay Maxsted"}... 

What I ultimately want is a graph of that eliminates the companies, with undirected edges between only directors who are on boards together.

    ASXdata = 
      Import["https://dl.dropbox.com/u/3997716/ASXdata.xls"];
    ASXvertexes = Take[ASXdata[[2]]];
    ASXedges = Take[ASXdata[[1]]];
graphFunc = Function[{u, v}, v \[UndirectedEdge] u];
twoMode = graphFunc @@@ ASXvertexes;
twoModeGraph = Graph[twoMode, ImageSize -> 500]

The above code gets me the below 2-mode graph (includes company and director vertexes).

enter image description here

Somehow I want a function that assigns all the possible undirected edges between the directors that have the same company in the first column.

I should then see a graph that looks a bit like the below snippet (my previous function can turn it into an undirected graph).

{{Mr ALberto Calderon,Mr Andrew Mackenzie},{Mr Alberto Calderon, Mr Brendan Harris}...

Obviously the graph will be much bigger because of all the extra edges required - eg. for the 21 directors in BHP there will now be 210 edges between them, instead of the previous 21 between the company and each director.

Ideally I could also create a network for just companies, with edges where they share a common board member. I literally have no idea how to even start, but assume I could apply whatever function someone can come up with to the columns in reverse for this.

{{BHP BILLITON, ASCIANO},{ANZ,TELSTRA}...

I guess the other main question, since I intend to be doing this sort of stuff quite a bit, is whether I first map the unique numerical vertex IDs from the first worksheet in the spreadsheet before doing these type of operations and before working with the resulting graph (measuring centrality, components, clusters, paths etc).

UPDATE

I have been able to divide the edges list by company. I figured that I would take the director name list for each company that comes from this, them make a complete graph of each, then combine them. However CompleteGraph doesn't seem to like the list input

   ASXvertexes = Take[ASXdata[[1]]];
ASXedges = Take[ASXdata[[2]]];
tASXedges = Transpose[ASXedges];
graphFunc = Function[{u, v}, v \[UndirectedEdge] u];
twoMode = graphFunc @@@ ASXedges;
twoModeGraph = Graph[twoMode, ImageSize -> 500];
compnames = Union[Transpose[ASXedges][[1]]];
directornames = Union[Transpose[ASXedges][[2]]];

t = Split[Rest@tASXedges[[1, All]]];

match = Table[
  Cases[ASXedges, {n_, __} /; n == compnames[[b]]], {b, 1, 
   Length[compnames]}]
c1 = Flatten[Take[Flatten[Take[match, 1], 1], All, -1]]
CompleteGraph[c1]

Which gives as output

CompleteGraph[{"Mr Bill Bartlett", "Mr Rod De Aboitiz", 
  "Mr Malcolm G Irving", "Mr John M Thame", "Dr Frank M Wolf", 
  "Mr David Bastian", "Mr Ellis Varejes", "Mrs Myra Salkinder", 
  "Mr Neil Summerfield"}]

UPDATE 2

With a bit of help from @kguler I can assign unique IDs to the names, and do a bit of sorting.

But for some reason the Graph function won't accept what I give it (it looks like a reasonably constructed graph to me). I get the error message "Graph::supp : Mixed graphs and multi graphs are not supported>>"

I've had this problem before, but I though the filtering of Union, DeleteCases etc would have done it.

Here's the current code

ASXdata = 
  Import["https://dl.dropbox.com/u/3997716/ASXdata.xls"];
ASXvertexes = Take[ASXdata[[1]]];
ASXedges = Drop[Take[ASXdata[[2]]], 1];
graphFunc = Function[{u, v}, v \[UndirectedEdge] u];
compnames = Union[Transpose[ASXedges][[1]]];
directornames = Union[Transpose[ASXedges][[2]]];
edges = ArrayComponents[ASXedges];
blist = Flatten[Take[edges, All, 1]];

match = Table[Cases[edges, {n_, __} /; n == b], {b, blist}];
directorgroups = 
  Union[Table[Part[match, i, All, 2], {i, 1, Length[match]}]];

example =
 Sort[
  Flatten[
   Table[
    DeleteCases[
     Union[
      Tuples[directorgroups[[i]]
       , 2],
      SameTest -> (First[#1] == Last[#2] &)]
     , _List?(Equal @@ # &)]
    , {i, 1, Length[directorgroups]}]
   , 1]
  ]

testdirectorgraph = graphFunc @@@ example;
Graph[testdirectorgraph]

Many thanks again.

share|improve this question
    
@belisarius Looks like it's all public knowledge, and just representing what you can find at http://www.nationaltimes.com.au/opinion/ASXmap. Whether it should all be so easily digestible and put together like this, though, I guess is a bit more of a judgement call (although since I think they're public corps...)! –  programming_historian Sep 26 '12 at 13:32
2  
The data is pubic. And you can download it from the newspaper here images.nationaltimes.com.au/file/2012/08/17/3562444/asx-gexf-js/… –  Cameron Murray Sep 26 '12 at 20:22
    
Also, the data is on ASX website. For example It's common field of research in sociology example If you are interested, my research tries to merge social ties, group loyalty, and rent-seeking into something comprehensible, (particularly for economists). Economic theory is very limited in its consideration of anything to do with social power structures or inequalities that arise from being born into a particular position on the social network. –  Cameron Murray Sep 26 '12 at 20:49
3  
@Cam "The data is public" - ah, good. We've had problems with people posting things they shouldn't be posting in public once before, so pardon us for having to ask. –  J. M. Sep 26 '12 at 23:35
    
Cameron, you can try Graph[DeleteDuplicates[testdirectorgraph]] or GraphPlot[testdirectorgraph /. UndirectedEdge -> Rule]. (Graph does not support mixed graphs (mixture of directed and and undirected edges) or multi-graphs (graphs with duplicate edges)). –  kguler Sep 27 '12 at 7:06
show 1 more comment

2 Answers

For your last question, you can use ArrayComponents:

 style = {VertexStyle -> White, VertexShapeFunction -> "Circle", VertexSize -> 0.3,
 EdgeStyle -> Directive[Opacity[.5], Hue[.15, .5, .8]], 
 Background -> Black, EdgeShapeFunction -> (Line[#1] &), 
 ImageSize -> 500};

 CompleteGraph[ArrayComponents[c1],style]

enter image description here

EDIT: Regarding the question in the comments: with a simple list of pairs

datalist = Tuples[Join[CharacterRange["a", "d"], CharacterRange["b", "c"]], 2] /.{i_,i_} :> Sequence[] // DeleteDuplicates
(* {{"a", "b"}, {"a", "c"}, {"a", "d"}, {"b", "a"}, {"b", "c"},{"b", "d"}, 
    {"c", "a"}, {"c", "b"}, {"c", "d"}, {"d", "a"}, {"d", "b"}, {"d", "c"}}*)

Thread /@ Thread[{datalist, ArrayComponents[datalist]}]

gives

{{{"a", 1}, {"b", 2}}, {{"a", 1}, {"c", 3}}, {{"a", 1}, {"d", 4}},
 {{"b", 2}, {"a", 1}}, {{"b", 2}, {"c", 3}}, {{"b", 2}, {"d", 4}}, 
 {{"c", 3}, {"a", 1}}, {{"c", 3}, {"b", 2}}, {{"c", 3}, {"d", 4}},
 {{"d", 4}, {"a", 1}}, {{"d", 4}, {"b", 2}}, {{"d", 4}, {"c", 3}}}

Among many alternative ways, you can also use:

 datalist /. MapIndexed[# -> {#, First@#2} &, DeleteDuplicates@Flatten[datalist]]

or

datalist /. Thread[# -> 
   Thread[{#, Range[Length[#]]}]] &[DeleteDuplicates@Flatten@datalist]

to get the same output. The last two should work for arbitrary lists. If you use Union isntead of DeleteDuplicates you get indices based on sorted list of unique elements in datalist. (With ArrayComponents and DeleteDuplicates the indices are based on the order the elements appear in the input list.)

share|improve this answer
    
That's really useful. Do you know if I retrieve the matching done by ArrayComponents as a list (or some form)? e.g. {{BHP,1},{ANX,2},{Steve,3}... –  Cameron Murray Sep 27 '12 at 1:26
    
Cameron, if your list does not have duplicates you can use something like MapIndexed[{#1, First@#2} &, CharacterRange["a", "d"]] which gives {{"a", 1}, {"b", 2}, {"c", 3}, {"d", 4}}. –  kguler Sep 27 '12 at 1:34
    
I has lots of duplicates actually, and whole names. eg {"BHP BILLITON", "Mr Alberto Calderon"}, {"BHP BILLITON", "Mr Andrew Mackenzie"}, {"BHP BILLITON", "Mr Brendan Harris"}. –  Cameron Murray Sep 27 '12 at 1:39
    
... or {i = 1}; {#, i++} & /@ c1. For input lists with more complicated structures and possible duplicates, you can use something like data /. MapIndexed[# -> {#,First@#2} &, Flatten[data]]. –  kguler Sep 27 '12 at 1:46
    
Thanks. The last one works (although it duplicated the result where there are multiple instances - I'm trying to clean it with Union or something (help?)). Is there a way to test that the indexation of MapIndexed is the same as ArrayComponents? I guess I just want to be certain about the matching, –  Cameron Murray Sep 27 '12 at 2:09
show 3 more comments
up vote 3 down vote accepted

I managed to get exactly what I wanted done. But to me it looks pretty ugly.

Here's the complete code (that you can use - the data file is on the web).

data = Import[
   "https://dl.dropbox.com/u/3997716/ASXdata.xls"];

vertexes = Take[data[[1]]];
edges = Drop[Take[data[[2]]], 1];
graphFunc = Function[{u, v}, u \[UndirectedEdge] v];

compnames = Union[Transpose[edges][[1]]];
directornames = Union[Transpose[edges][[2]]];
codeedges = ArrayComponents[edges];

(* Provides the key to match back numerical vertex numbers to names *)

index = Sort[
   RotateLeft[
    Union[Flatten[Thread /@ Thread[{edges, ArrayComponents[edges]}], 
      1]], {0, 1}]];

blist = Flatten[Take[codeedges, All, 1]];
clist = Flatten[Take[codeedges, All, -1]];

match = Table[Cases[codeedges, {n_, __} /; n == b], {b, blist}];
match2 = Table[
   Cases[Map[Reverse, codeedges], {m_, _} /; m == c], {c, clist}];

directorgroups = 
  Union[Table[Part[match, i, All, 2], {i, 1, Length[match]}]];
companygroups = 
  Union[Table[Part[match2, i, All, -1], {i, 1, Length[match2]}]];
example = 
  Sort[Flatten[
    Table[DeleteCases[
      Union[Tuples[directorgroups[[i]], 2], 
       SameTest -> (First[#1] == 
           Last[#2] &)], _List?(Equal @@ # &)], {i, 1, 
      Length[directorgroups]}], 1]];
example2 = 
  Sort[Flatten[
    Table[DeleteCases[
      Union[Tuples[companygroups[[i]], 2], 
       SameTest -> (First[#1] == 
           Last[#2] &)], _List?(Equal @@ # &)], {i, 1, 
      Length[companygroups]}], 1]];
directorgraph = graphFunc @@@ example;
companygraph = graphFunc @@@ example2;

directorG = 
 Graph[blist, DeleteDuplicates[directorgraph], 
  GraphLayout -> "SpringElectricalEmbedding", 
  GraphStyle -> "LargeNetwork", ImageSize -> 900]

companyG = 
 Graph[clist, DeleteDuplicates[companygraph], 
  GraphLayout -> "SpringElectricalEmbedding", 
  GraphStyle -> "LargeNetwork", ImageSize -> 900]

It gets me the two graph objects that I can then analyse (KCoreComponents, BetweennessCentrality etc). An example is at the bottom of this post.

It anyone has further tips about how to turn this into a couple of functions that accept data in the form of the variable edges, that would be great. I've had a crack, but it's pretty cumbersome with my code.

Also, any tips on presenting large graphs (or links to other discussions, examples) would be appreciated.

enter image description here

share|improve this answer
    
I created a similar graph in Gephi, see this question, mathematica.stackexchange.com/q/7764/1635. I have not had the time to redo this in Mathematica –  FredrikD Oct 2 '12 at 19:12
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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