Merging (combining) tables of graph relationships (2-mode to 1-mode network)

Question

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

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.

Answer 1

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.

Answer 2

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]

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