library(readr)
library(igraph)

Bimodal (bipartite) networks

Part 1. Create a toy bimodal network

bi_data = read_csv("/Users/macbook/Desktop/NETWORKS/Seminar6/imbd_bidata.csv")
bi_matrix = as.matrix(table(bi_data)) 
# Convert the matrix to a bipartitie network using graph.incidence() command
bi_gr = graph.incidence(bi_matrix)
#V(bi_gr)$type  
shape = ifelse(V(bi_gr)$type, "circle", "square") # assign shape by node type
col = ifelse(V(bi_gr)$type, "lightcoral", "lightblue") # assign color by node type

Bipartite graph

plot(bi_gr, 
     vertex.shape = shape,  
     vertex.color = col, 
     vertex.label.size = 0.5,
     vertex.size = 5,
     edge.arrow.size = 1)

plot(bi_gr, 
     vertex.shape = shape, 
     layout = layout_as_bipartite(bi_gr),
     vertex.color = col, 
     vertex.label = "",
     vertex.size = 5,
     edge.arrow.size = 1)

plot(bi_gr, 
     vertex.shape = shape, 
     layout = layout_with_kk(bi_gr),
     vertex.color = col, 
     vertex.label.size = degree(bi_gr),
     vertex.size = 5,
     edge.arrow.size = 1)

Projections

matrix_row <- bi_matrix %*% t(bi_matrix) #creates adjacency matrix of rows
matrix_column <- t(bi_matrix) %*% bi_matrix #creates adjacency matrix of columns
# Projection for raws -> directors of films
bi_graph_row <- graph_from_adjacency_matrix(matrix_row,   
                          mode = "undirected",
                          diag = FALSE,
                          weighted=TRUE)
e<-E(bi_graph_row)$weight

Graph for directors

plot(bi_graph_row, 
     layout = layout_with_kk(bi_graph_row),
     vertex.shape = shape, 
     vertex.color = col, 
     vertex.size = 5,
     vertex.label.size = 0.4,
     edge.width = e)

There are several connections between directors that means they work with the same production companies. The weight between nodes means that some directors more often work with the similar particular companies.

# Projection for columns -> production companies of films
bi_graph_column <- graph_from_adjacency_matrix(matrix_column,
                            mode = "undirected",
                             diag = FALSE, 
                            weighted=TRUE)
e1<-E(bi_graph_column)$weight

Graph for production companies

plot(bi_graph_column, 
     layout = layout_with_kk(bi_graph_column),
     vertex.shape = 'circle', 
     vertex.color = "lightcoral", 
     vertex.size = degree(bi_graph_column),
     vertex.label.size = 0.4,
     edge.width = e1)

We see that Paramount Pictures, Warner Bros. have the biggest degree that means it is the most popular companies among directors. The weight between nodes means that some companies more often work with the same directors.

LS0tCnRpdGxlOiAiUHJhY3RpY2UgNiIKYXV0aG9yOiAiQW5hc3Rhc2lhIE11cmFjaCIKZGF0ZTogIjUvMjEvMjAyMiIKb3V0cHV0OgogIGh0bWxfbm90ZWJvb2sKLS0tCgpgYGB7ciBzZXR1cCwgaW5jbHVkZT1GQUxTRX0Ka25pdHI6Om9wdHNfY2h1bmskc2V0KGVjaG8gPSBUUlVFKQprbml0cjo6b3B0c19jaHVuayRzZXQobWVzc2FnZT1GQUxTRSkKa25pdHI6Om9wdHNfY2h1bmskc2V0KHdhcm5pbmc9RkFMU0UpCmBgYAoKYGBge3J9CmxpYnJhcnkocmVhZHIpCmxpYnJhcnkoaWdyYXBoKQpgYGAKCiMjIyBCaW1vZGFsIChiaXBhcnRpdGUpIG5ldHdvcmtzICMjIwoKUGFydCAxLiBDcmVhdGUgYSB0b3kgYmltb2RhbCBuZXR3b3JrCmBgYHtyfQpiaV9kYXRhID0gcmVhZF9jc3YoIi9Vc2Vycy9tYWNib29rL0Rlc2t0b3AvTkVUV09SS1MvU2VtaW5hcjYvaW1iZF9iaWRhdGEuY3N2IikKYmlfbWF0cml4ID0gYXMubWF0cml4KHRhYmxlKGJpX2RhdGEpKSAKYGBgCgpgYGB7cn0KIyBDb252ZXJ0IHRoZSBtYXRyaXggdG8gYSBiaXBhcnRpdGllIG5ldHdvcmsgdXNpbmcgZ3JhcGguaW5jaWRlbmNlKCkgY29tbWFuZApiaV9nciA9IGdyYXBoLmluY2lkZW5jZShiaV9tYXRyaXgpCmBgYAogCmBgYHtyfQojVihiaV9ncikkdHlwZSAgCnNoYXBlID0gaWZlbHNlKFYoYmlfZ3IpJHR5cGUsICJjaXJjbGUiLCAic3F1YXJlIikgIyBhc3NpZ24gc2hhcGUgYnkgbm9kZSB0eXBlCmNvbCA9IGlmZWxzZShWKGJpX2dyKSR0eXBlLCAibGlnaHRjb3JhbCIsICJsaWdodGJsdWUiKSAjIGFzc2lnbiBjb2xvciBieSBub2RlIHR5cGUKYGBgCgojIyMgQmlwYXJ0aXRlIGdyYXBoCmBgYHtyLCBmaWcud2lkdGg9MTAsIGZpZy5oZWlnaHQ9MTB9CnBsb3QoYmlfZ3IsIAogICAgIHZlcnRleC5zaGFwZSA9IHNoYXBlLCAgCiAgICAgdmVydGV4LmNvbG9yID0gY29sLCAKICAgICB2ZXJ0ZXgubGFiZWwuc2l6ZSA9IDAuNSwKICAgICB2ZXJ0ZXguc2l6ZSA9IDUsCiAgICAgZWRnZS5hcnJvdy5zaXplID0gMSkKYGBgCgpgYGB7ciwgZmlnLndpZHRoPTUsIGZpZy5oZWlnaHQ9NX0KcGxvdChiaV9nciwgCiAgICAgdmVydGV4LnNoYXBlID0gc2hhcGUsIAogICAgIGxheW91dCA9IGxheW91dF9hc19iaXBhcnRpdGUoYmlfZ3IpLAogICAgIHZlcnRleC5jb2xvciA9IGNvbCwgCiAgICAgdmVydGV4LmxhYmVsID0gIiIsCiAgICAgdmVydGV4LnNpemUgPSA1LAogICAgIGVkZ2UuYXJyb3cuc2l6ZSA9IDEpCmBgYAoKYGBge3IsIGZpZy53aWR0aD01LCBmaWcuaGVpZ2h0PTV9CnBsb3QoYmlfZ3IsIAogICAgIHZlcnRleC5zaGFwZSA9IHNoYXBlLCAKICAgICBsYXlvdXQgPSBsYXlvdXRfd2l0aF9rayhiaV9nciksCiAgICAgdmVydGV4LmNvbG9yID0gY29sLCAKICAgICB2ZXJ0ZXgubGFiZWwuc2l6ZSA9IGRlZ3JlZShiaV9nciksCiAgICAgdmVydGV4LnNpemUgPSA1LAogICAgIGVkZ2UuYXJyb3cuc2l6ZSA9IDEpCmBgYAoKIyMjIFByb2plY3Rpb25zCmBgYHtyfQptYXRyaXhfcm93IDwtIGJpX21hdHJpeCAlKiUgdChiaV9tYXRyaXgpICNjcmVhdGVzIGFkamFjZW5jeSBtYXRyaXggb2Ygcm93cwptYXRyaXhfY29sdW1uIDwtIHQoYmlfbWF0cml4KSAlKiUgYmlfbWF0cml4ICNjcmVhdGVzIGFkamFjZW5jeSBtYXRyaXggb2YgY29sdW1ucwpgYGAKCmBgYHtyfQojIFByb2plY3Rpb24gZm9yIHJhd3MgLT4gZGlyZWN0b3JzIG9mIGZpbG1zCmJpX2dyYXBoX3JvdyA8LSBncmFwaF9mcm9tX2FkamFjZW5jeV9tYXRyaXgobWF0cml4X3JvdywgICAKICAgICAgICAgICAgICAgICAgICAgICAgICBtb2RlID0gInVuZGlyZWN0ZWQiLAogICAgICAgICAgICAgICAgICAgICAgICAgIGRpYWcgPSBGQUxTRSwKICAgICAgICAgICAgICAgICAgICAgICAgICB3ZWlnaHRlZD1UUlVFKQpgYGAKCmBgYHtyfQplPC1FKGJpX2dyYXBoX3Jvdykkd2VpZ2h0CmBgYAoKIyMgR3JhcGggZm9yIGRpcmVjdG9ycwpgYGB7ciwgZmlnLndpZHRoPTgsIGZpZy5oZWlnaHQ9OH0KcGxvdChiaV9ncmFwaF9yb3csIAogICAgIGxheW91dCA9IGxheW91dF93aXRoX2trKGJpX2dyYXBoX3JvdyksCiAgICAgdmVydGV4LnNoYXBlID0gc2hhcGUsIAogICAgIHZlcnRleC5jb2xvciA9IGNvbCwgCiAgICAgdmVydGV4LnNpemUgPSA1LAogICAgIHZlcnRleC5sYWJlbC5zaXplID0gMC40LAogICAgIGVkZ2Uud2lkdGggPSBlKQpgYGAKCipUaGVyZSBhcmUgc2V2ZXJhbCBjb25uZWN0aW9ucyBiZXR3ZWVuIGRpcmVjdG9ycyB0aGF0IG1lYW5zIHRoZXkgd29yayB3aXRoIHRoZSBzYW1lIHByb2R1Y3Rpb24gY29tcGFuaWVzLiBUaGUgd2VpZ2h0IGJldHdlZW4gbm9kZXMgbWVhbnMgdGhhdCBzb21lIGRpcmVjdG9ycyBtb3JlIG9mdGVuIHdvcmsgd2l0aCB0aGUgc2ltaWxhciBwYXJ0aWN1bGFyIGNvbXBhbmllcy4qCgpgYGB7cn0KIyBQcm9qZWN0aW9uIGZvciBjb2x1bW5zIC0+IHByb2R1Y3Rpb24gY29tcGFuaWVzIG9mIGZpbG1zCmJpX2dyYXBoX2NvbHVtbiA8LSBncmFwaF9mcm9tX2FkamFjZW5jeV9tYXRyaXgobWF0cml4X2NvbHVtbiwKICAgICAgICAgICAgICAgICAgICAgICAgICAgIG1vZGUgPSAidW5kaXJlY3RlZCIsCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgZGlhZyA9IEZBTFNFLCAKICAgICAgICAgICAgICAgICAgICAgICAgICAgIHdlaWdodGVkPVRSVUUpCmBgYAoKYGBge3J9CmUxPC1FKGJpX2dyYXBoX2NvbHVtbikkd2VpZ2h0CmBgYAoKIyMgR3JhcGggZm9yIHByb2R1Y3Rpb24gY29tcGFuaWVzCmBgYHtyLCBmaWcud2lkdGg9OCwgZmlnLmhlaWdodD04fQpwbG90KGJpX2dyYXBoX2NvbHVtbiwgCiAgICAgbGF5b3V0ID0gbGF5b3V0X3dpdGhfa2soYmlfZ3JhcGhfY29sdW1uKSwKICAgICB2ZXJ0ZXguc2hhcGUgPSAnY2lyY2xlJywgCiAgICAgdmVydGV4LmNvbG9yID0gImxpZ2h0Y29yYWwiLCAKICAgICB2ZXJ0ZXguc2l6ZSA9IGRlZ3JlZShiaV9ncmFwaF9jb2x1bW4pLAogICAgIHZlcnRleC5sYWJlbC5zaXplID0gMC40LAogICAgIGVkZ2Uud2lkdGggPSBlMSkKYGBgCgoqV2Ugc2VlIHRoYXQgUGFyYW1vdW50IFBpY3R1cmVzLCBXYXJuZXIgQnJvcy4gaGF2ZSB0aGUgYmlnZ2VzdCBkZWdyZWUgdGhhdCBtZWFucyBpdCBpcyB0aGUgbW9zdCBwb3B1bGFyIGNvbXBhbmllcyBhbW9uZyBkaXJlY3RvcnMuIFRoZSB3ZWlnaHQgYmV0d2VlbiBub2RlcyBtZWFucyB0aGF0IHNvbWUgY29tcGFuaWVzIG1vcmUgb2Z0ZW4gd29yayB3aXRoIHRoZSBzYW1lIGRpcmVjdG9ycy4qCg==