library(tidyverse)
library(igraph)                    # This is the package to analyze the network
library(visNetwork)                # Creates visualizations of the network
library(DT)
library(plotly)
HP_nodes <- read_csv("HP_nodes.csv")

-- Column specification ------------------------------------------------------------------------
cols(
  id = col_double(),
  name = col_character(),
  bio = col_character()
)
HP_links <- read_csv("HP_links.csv")

-- Column specification ------------------------------------------------------------------------
cols(
  from = col_double(),
  to = col_double()
)

Network of Harry Potter Characters

The following network analysis is an analysis of characters from the bestselling books and fantasy films, Harry Potter. The following tables indicates there are 65 characters and 356 ways they are connected.

HP_nodes %>% 
  datatable(rownames = F)
HP_links %>% 
  datatable(rownames = F)

All relationships in this analysis are considered to be two-way and the density, which is the number of connections divided by the potential connections, is 0.17.

HP_network <- graph_from_data_frame(HP_links, 
                                           vertices = HP_nodes, 
                                           directed = F)
HP_network %>% 
  edge_density()
[1] 0.1711538

The shortest paths between two nodes is two. This graph indicates there are many nodes in this network that are only two or three hops apart, however, there are some nodes that are 6 or more hops apart. The graph shows 65 connections at 0. Sixty-five is the total number of characters in this analysis. They are counted as connected to themselves with 0 hops. The mean distance between two connections is calculated at 2.64.

HP_network %>% 
  distances() %>% 
  as.vector() %>%              # these two lines convert the distances matrix
  as_tibble() %>%              # to something plotly can graph
  plot_ly(x = ~value) %>% 
  add_histogram()
HP_network %>%
  mean_distance()
[1] 2.64723

Next we will look at the length of the diameter of the network. The diameter is 7 which is the longest path between nodes.

HP_network %>% 
  get_diameter() %>% 
  length()
[1] 7
HP_nodes <- HP_nodes %>% 
  mutate(label = name)
HP_nodes <- HP_nodes %>% 
  mutate(title = name)
HP_nodes <- HP_nodes %>%
  mutate(degree = degree(HP_network))
HP_nodes <- HP_nodes %>% 
  mutate(value = degree)

Now we will determine which character had the most connections in the Harry Potter Network. In the graph below, we can see that Vincent Crabbe, Sr., was the go-between for Severus Snape and 8 other characters.

HP_links <- HP_links %>% 
  mutate(betweenness = edge_betweenness(HP_network)) %>% 
  mutate(value = betweenness)
  
visNetwork(HP_nodes, 
           HP_links, 
           main = "Network of Harry Potter Characters") %>% 
  visIgraphLayout(layout = "layout_nicely") %>% 
  visOptions(highlightNearest = T, nodesIdSelection = T)

Finally, we will determine who is in which network.The graph below indicates that those in group 1 compromise the largest group which includes Harry Potter. However, Rita Skeeter, a reporter with the Daily Prophet, was in a group all by herself.

HP_network %>% 
  infomap.community()
IGRAPH clustering infomap, groups: 21, mod: 0.17
+ groups:
  $`1`
  [1] "Lavender Brown"            "Hermione Granger"          "Alastor \"Mad-Eye\" Moody"
  [4] "Ron Weasley"               "Dobby"                     "Aragog"                   
  
  $`2`
  [1] "Minerva McGonagall" "Harry Potter"       "Severus Snape"      "Hedwig"            
  [5] "Moaning Myrtle"    
  
  $`3`
  [1] "Fred Weasley"  "Molly Weasley" "Percy Weasley"
  + ... omitted several groups/vertices
HP_network %>% 
  infomap.community() %>% 
  membership()
      Regulus Arcturus Black                 Sirius Black               Lavender Brown 
                          13                            7                           12 
                   Cho Chang           Vincent Crabbe Sr.               Vincent Crabbe 
                          12                           13                           11 
Bartemius "Barty" Crouch Sr. Bartemius "Barty" Crouch Jr.               Fleur Delacour 
                          13                            1                            4 
              Cedric Diggory        Alberforth Dumbledore             Albus Dumbledore 
                          12                            2                            2 
              Dudley Dursley              Petunia Dursley               Vernon Dursley 
                          10                           10                           10 
                 Argus Filch              Seamus Finnigan               Nicolas Flamel 
                           3                           12                            2 
             Cornelius Fudge                    Goyle Sr.                Gregory Goyle 
                          19                           11                           11 
            Hermione Granger                Rubeus Hagrid               Igor Karkaroff 
                           3                            8                           21 
                 Viktor Krum          Bellatrix Lestrange             Alice Longbottom 
                          21                           18                           20 
            Frank Longbottom           Neville Longbottom                Luna Lovegood 
                          20                            1                            1 
        Xenophilius Lovegood                  Remus Lupin                 Draco Malfoy 
                           1                           14                           15 
               Lucius Malfoy              Narcissa Malfoy                Olympe Maxime 
                          15                           18                            4 
          Minerva McGonagall      Alastor "Mad-Eye" Moody              Peter Pettigrew 
                           8                            5                           16 
                Harry Potter                 James Potter                  Lily Potter 
                           5                           14                            2 
           Quirinus Quirrell               Tom Riddle Sr.                  Mary Riddle 
                           2                           17                           17 
              Lord Voldemort                 Rita Skeeter                Severus Snape 
                          16                           22                            3 
            Nymphadora Tonks       Dolores Janes Umbridge               Arthur Weasley 
                          14                           19                            7 
                Bill Weasley              Charlie Weasley                 Fred Weasley 
                           9                            4                            9 
              George Weasley                Ginny Weasley                Molly Weasley 
                           6                            4                            2 
               Percy Weasley                  Ron Weasley                        Dobby 
                           6                            1                            1 
                      Fluffy                       Hedwig               Moaning Myrtle 
                           8                            5                            5 
                      Aragog                        Grawp 
                           1                            3 
HP_nodes <- HP_nodes %>% 
  mutate(group = membership(infomap.community(HP_network)))

HP_nodes %>% 
  datatable()

NA
visNetwork(HP_nodes, 
           HP_links, 
           main = "Network of Harry Potter Characters") %>% 
  visIgraphLayout(layout = "layout_nicely") %>% 
  visOptions(highlightNearest = T, nodesIdSelection = T, selectedBy = "group")

NA
LS0tDQp0aXRsZTogIkludHJvZHVjdGlvbiB0byBOZXR3b3JrIEFuYWx5c2lzIg0Kb3V0cHV0OiBodG1sX25vdGVib29rDQotLS0NCg0KYGBge3J9DQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCmxpYnJhcnkoaWdyYXBoKSAgICAgICAgICAgICAgICAgICAgIyBUaGlzIGlzIHRoZSBwYWNrYWdlIHRvIGFuYWx5emUgdGhlIG5ldHdvcmsNCmxpYnJhcnkodmlzTmV0d29yaykgICAgICAgICAgICAgICAgIyBDcmVhdGVzIHZpc3VhbGl6YXRpb25zIG9mIHRoZSBuZXR3b3JrDQpsaWJyYXJ5KERUKQ0KbGlicmFyeShwbG90bHkpDQpgYGANCg0KDQoNCmBgYHtyfQ0KSFBfbm9kZXMgPC0gcmVhZF9jc3YoIkhQX25vZGVzLmNzdiIpDQpIUF9saW5rcyA8LSByZWFkX2NzdigiSFBfbGlua3MuY3N2IikNCmBgYA0KDQojIyMgTmV0d29yayBvZiBIYXJyeSBQb3R0ZXIgQ2hhcmFjdGVycw0KDQpUaGUgZm9sbG93aW5nIG5ldHdvcmsgYW5hbHlzaXMgaXMgYW4gYW5hbHlzaXMgb2YgY2hhcmFjdGVycyBmcm9tIHRoZSBiZXN0c2VsbGluZyBib29rcyBhbmQgZmFudGFzeSBmaWxtcywgSGFycnkgUG90dGVyLiBUaGUgZm9sbG93aW5nIHRhYmxlcyBpbmRpY2F0ZXMgdGhlcmUgYXJlIDY1IGNoYXJhY3RlcnMgYW5kIDM1NiB3YXlzIHRoZXkgYXJlIGNvbm5lY3RlZC4NCg0KDQpgYGB7cn0NCkhQX25vZGVzICU+JSANCiAgZGF0YXRhYmxlKHJvd25hbWVzID0gRikNCmBgYA0KDQoNCg0KYGBge3J9DQpIUF9saW5rcyAlPiUgDQogIGRhdGF0YWJsZShyb3duYW1lcyA9IEYpDQpgYGANCg0KDQoNCkFsbCByZWxhdGlvbnNoaXBzIGluIHRoaXMgYW5hbHlzaXMgYXJlIGNvbnNpZGVyZWQgdG8gYmUgdHdvLXdheSBhbmQgdGhlIGRlbnNpdHksIHdoaWNoIGlzIHRoZSBudW1iZXIgb2YgY29ubmVjdGlvbnMgZGl2aWRlZCBieSB0aGUgcG90ZW50aWFsIGNvbm5lY3Rpb25zLCBpcyAwLjE3Lg0KDQpgYGB7cn0NCkhQX25ldHdvcmsgPC0gZ3JhcGhfZnJvbV9kYXRhX2ZyYW1lKEhQX2xpbmtzLCANCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICB2ZXJ0aWNlcyA9IEhQX25vZGVzLCANCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBkaXJlY3RlZCA9IEYpDQoNCmBgYA0KDQoNCg0KYGBge3J9DQpIUF9uZXR3b3JrICU+JSANCiAgZWRnZV9kZW5zaXR5KCkNCmBgYA0KDQoNCg0KVGhlIHNob3J0ZXN0IHBhdGhzIGJldHdlZW4gdHdvIG5vZGVzIGlzIHR3by4gVGhpcyBncmFwaCBpbmRpY2F0ZXMgdGhlcmUgYXJlIG1hbnkgbm9kZXMgaW4gdGhpcyBuZXR3b3JrIHRoYXQgYXJlIG9ubHkgdHdvIG9yIHRocmVlIGhvcHMgYXBhcnQsIGhvd2V2ZXIsIHRoZXJlIGFyZSBzb21lIG5vZGVzIHRoYXQgYXJlIDYgb3IgbW9yZSBob3BzIGFwYXJ0LiBUaGUgZ3JhcGggc2hvd3MgNjUgY29ubmVjdGlvbnMgYXQgMC4gU2l4dHktZml2ZSBpcyB0aGUgdG90YWwgbnVtYmVyIG9mIGNoYXJhY3RlcnMgaW4gdGhpcyBhbmFseXNpcy4gVGhleSBhcmUgY291bnRlZCBhcyBjb25uZWN0ZWQgdG8gdGhlbXNlbHZlcyB3aXRoIDAgaG9wcy4gVGhlIG1lYW4gZGlzdGFuY2UgYmV0d2VlbiB0d28gY29ubmVjdGlvbnMgaXMgY2FsY3VsYXRlZCBhdCAyLjY0LiANCg0KDQoNCmBgYHtyfQ0KSFBfbmV0d29yayAlPiUgDQogIGRpc3RhbmNlcygpICU+JSANCiAgYXMudmVjdG9yKCkgJT4lICAgICAgICAgICAgICAjIHRoZXNlIHR3byBsaW5lcyBjb252ZXJ0IHRoZSBkaXN0YW5jZXMgbWF0cml4DQogIGFzX3RpYmJsZSgpICU+JSAgICAgICAgICAgICAgIyB0byBzb21ldGhpbmcgcGxvdGx5IGNhbiBncmFwaA0KICBwbG90X2x5KHggPSB+dmFsdWUpICU+JSANCiAgYWRkX2hpc3RvZ3JhbSgpDQpgYGANCg0KDQpgYGB7cn0NCkhQX25ldHdvcmsgJT4lDQogIG1lYW5fZGlzdGFuY2UoKQ0KDQpgYGANCg0KTmV4dCB3ZSB3aWxsIGxvb2sgYXQgdGhlIGxlbmd0aCBvZiB0aGUgZGlhbWV0ZXIgb2YgdGhlIG5ldHdvcmsuIFRoZSBkaWFtZXRlciBpcyA3IHdoaWNoIGlzIHRoZSBsb25nZXN0IHBhdGggYmV0d2VlbiBub2Rlcy4NCg0KDQpgYGB7cn0NCkhQX25ldHdvcmsgJT4lIA0KICBnZXRfZGlhbWV0ZXIoKSAlPiUgDQogIGxlbmd0aCgpDQpgYGANCg0KDQpgYGB7cn0NCkhQX25vZGVzIDwtIEhQX25vZGVzICU+JSANCiAgbXV0YXRlKGxhYmVsID0gbmFtZSkNCg0KDQpgYGANCg0KDQpgYGB7cn0NCkhQX25vZGVzIDwtIEhQX25vZGVzICU+JSANCiAgbXV0YXRlKHRpdGxlID0gbmFtZSkNCg0KDQpgYGANCg0KDQoNCg0KYGBge3J9DQpIUF9ub2RlcyA8LSBIUF9ub2RlcyAlPiUNCiAgbXV0YXRlKGRlZ3JlZSA9IGRlZ3JlZShIUF9uZXR3b3JrKSkNCg0KDQpgYGANCg0KDQoNCmBgYHtyfQ0KSFBfbm9kZXMgPC0gSFBfbm9kZXMgJT4lIA0KICBtdXRhdGUodmFsdWUgPSBkZWdyZWUpDQoNCg0KDQpgYGANCg0KTm93IHdlIHdpbGwgZGV0ZXJtaW5lIHdoaWNoIGNoYXJhY3RlciBoYWQgdGhlIG1vc3QgY29ubmVjdGlvbnMgaW4gdGhlIEhhcnJ5IFBvdHRlciBOZXR3b3JrLiBJbiB0aGUgZ3JhcGggYmVsb3csIHdlIGNhbiBzZWUgdGhhdCBWaW5jZW50IENyYWJiZSwgU3IuLCB3YXMgdGhlIGdvLWJldHdlZW4gZm9yIFNldmVydXMgU25hcGUgYW5kIDggb3RoZXIgY2hhcmFjdGVycy4NCg0KYGBge3J9DQpIUF9saW5rcyA8LSBIUF9saW5rcyAlPiUgDQogIG11dGF0ZShiZXR3ZWVubmVzcyA9IGVkZ2VfYmV0d2Vlbm5lc3MoSFBfbmV0d29yaykpICU+JSANCiAgbXV0YXRlKHZhbHVlID0gYmV0d2Vlbm5lc3MpDQogIA0KYGBgDQoNCg0KDQpgYGB7cn0NCnZpc05ldHdvcmsoSFBfbm9kZXMsIA0KICAgICAgICAgICBIUF9saW5rcywgDQogICAgICAgICAgIG1haW4gPSAiTmV0d29yayBvZiBIYXJyeSBQb3R0ZXIgQ2hhcmFjdGVycyIpICU+JSANCiAgdmlzSWdyYXBoTGF5b3V0KGxheW91dCA9ICJsYXlvdXRfbmljZWx5IikgJT4lIA0KICB2aXNPcHRpb25zKGhpZ2hsaWdodE5lYXJlc3QgPSBULCBub2Rlc0lkU2VsZWN0aW9uID0gVCkNCmBgYA0KDQoNCkZpbmFsbHksIHdlIHdpbGwgZGV0ZXJtaW5lIHdobyBpcyBpbiB3aGljaCBuZXR3b3JrLlRoZSBncmFwaCBiZWxvdyBpbmRpY2F0ZXMgdGhhdCB0aG9zZSBpbiBncm91cCAxIGNvbXByb21pc2UgdGhlIGxhcmdlc3QgZ3JvdXAgd2hpY2ggaW5jbHVkZXMgSGFycnkgUG90dGVyLiBIb3dldmVyLCBSaXRhIFNrZWV0ZXIsIGEgcmVwb3J0ZXIgd2l0aCB0aGUgRGFpbHkgUHJvcGhldCwgd2FzIGluIGEgZ3JvdXAgYWxsIGJ5IGhlcnNlbGYuDQoNCmBgYHtyfQ0KSFBfbmV0d29yayAlPiUgDQogIGluZm9tYXAuY29tbXVuaXR5KCkNCmBgYA0KDQpgYGB7cn0NCkhQX25ldHdvcmsgJT4lIA0KICBpbmZvbWFwLmNvbW11bml0eSgpICU+JSANCiAgbWVtYmVyc2hpcCgpDQpgYGANCg0KDQoNCmBgYHtyfQ0KSFBfbm9kZXMgPC0gSFBfbm9kZXMgJT4lIA0KICBtdXRhdGUoZ3JvdXAgPSBtZW1iZXJzaGlwKGluZm9tYXAuY29tbXVuaXR5KEhQX25ldHdvcmspKSkNCg0KSFBfbm9kZXMgJT4lIA0KICBkYXRhdGFibGUoKQ0KDQpgYGANCg0KDQoNCmBgYHtyfQ0KdmlzTmV0d29yayhIUF9ub2RlcywgDQogICAgICAgICAgIEhQX2xpbmtzLCANCiAgICAgICAgICAgbWFpbiA9ICJOZXR3b3JrIG9mIEhhcnJ5IFBvdHRlciBDaGFyYWN0ZXJzIikgJT4lIA0KICB2aXNJZ3JhcGhMYXlvdXQobGF5b3V0ID0gImxheW91dF9uaWNlbHkiKSAlPiUgDQogIHZpc09wdGlvbnMoaGlnaGxpZ2h0TmVhcmVzdCA9IFQsIG5vZGVzSWRTZWxlY3Rpb24gPSBULCBzZWxlY3RlZEJ5ID0gImdyb3VwIikNCg0KYGBgDQoNCg0KDQo=