library(tidyverse)
library(igraph)
library(visNetwork)
library(DT)
library(plotly)
library(broom)

These are the packages that I used for this assignment.

students <- read_csv("R Class/friendship_nodes.csv")
Rows: 84 Columns: 2── Column specification ─────────────────────────────────────────────────────────
Delimiter: ","
dbl (2): id, name
ℹ Use `spec()` to retrieve the full column specification for this data.
ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
student_links <- read_csv("R Class/friendships.csv")
Rows: 6972 Columns: 4── Column specification ─────────────────────────────────────────────────────────
Delimiter: ","
dbl (4): nominator, nominated, score, expected_score
ℹ Use `spec()` to retrieve the full column specification for this data.
ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

Question 1:

student_links %>% 
  datatable(rownames = F,
            caption = 'Nominator and Nominated Scores and Expected Scores')

This is a data table showing the scores for the nominator and the nominated showing how they each score and percieve their friendship. It also shows the expected score that the nominated person believed that the nominator would give them.

Question 2:

friendship_model <- lm(expected_score ~ score, data = student_links)

tidy(friendship_model)
glance(friendship_model)
student_links |>
  plot_ly(x = ~score, y = ~expected_score) |>
  add_markers() |>
  add_lines(y = fitted(friendship_model))

This is a regression model showing how well a person can predict expected scores compared to the actual scores of closeness in friendships.

Question 3:

friends <- student_links |> 
  filter(score > 3) |> 
  select(nominator, nominated) |> 
  rename(from = nominator) |> 
  rename(to = nominated)
friendship_network <- graph_from_data_frame(friends, students, directed = T)
students |> 
    mutate(named_friends = degree((friendship_network), mode = "out")) |> 
  mutate(named_by_others= degree((friendship_network), mode = "in")) |> 
  mutate(popularity = named_by_others - named_friends) |>
  select(named_friends, named_by_others, popularity) |> 
  datatable(rownames = F)

This is a data table showing the variables named friends, named by others, and popularity. Popularity was calculated by taking the number of times a person named their friends minus the amount of times they were named by others as a friend.

Question 4:

students |> 
  mutate(named_friends = degree((friendship_network), mode = "out")) |> 
  mutate(named_by_others= degree((friendship_network), mode = "in")) |> 
  plot_ly(x = ~named_friends) |>
  add_histogram() |>
  layout(title = "Number of Friends That Students Named")

This is a histogram showing the amount of times that a student named another student as their friend.

Question 5:

reciprocity(friendship_network, mode = "ratio")
[1] 0.5205479

The reciprocity of friendships in the network is 52%, meaning that 52% of students that named another student as their friend were also named back by that student as well.

Question 6:

bestfriends <- student_links |> 
  filter(score > 4) |> 
  select(nominator, nominated) |> 
  rename(from = nominator) |> 
  rename(to = nominated)
bestfriendship_network <- graph_from_data_frame(bestfriends, students, directed = T)
students |>  
  mutate(group = membership(infomap.community(bestfriendship_network))) |>
  mutate(value = degree(bestfriendship_network)) |>
  visNetwork(friends, main = "Network of best friendships") |>
  visIgraphLayout(layout = "layout_nicely") |>
  visEdges(arrows = "to") |>
  visOptions(highlightNearest = T, nodesIdSelection = T)
Warning: There was 1 warning in `mutate()`.
ℹ In argument: `group = membership(infomap.community(bestfriendship_network))`.
Caused by warning:
! `infomap.community()` was deprecated in igraph 2.0.0.
ℹ Please use `cluster_infomap()` instead.
This warning is displayed once every 8 hours.
Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
generated.

This shows a new network created using only best friends. The different colors indicate communities of people that rated eachother similarily. The size indicates the amount of best friends that a person has.

LS0tCnRpdGxlOiAiTmV0d29yayBBbmFseXNpcyIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKYGBge3J9CmxpYnJhcnkodGlkeXZlcnNlKQpsaWJyYXJ5KGlncmFwaCkKbGlicmFyeSh2aXNOZXR3b3JrKQpsaWJyYXJ5KERUKQpsaWJyYXJ5KHBsb3RseSkKbGlicmFyeShicm9vbSkKYGBgCgpUaGVzZSBhcmUgdGhlIHBhY2thZ2VzIHRoYXQgSSB1c2VkIGZvciB0aGlzIGFzc2lnbm1lbnQuIAoKYGBge3J9CnN0dWRlbnRzIDwtIHJlYWRfY3N2KCJSIENsYXNzL2ZyaWVuZHNoaXBfbm9kZXMuY3N2IikKYGBgCgpgYGB7cn0Kc3R1ZGVudF9saW5rcyA8LSByZWFkX2NzdigiUiBDbGFzcy9mcmllbmRzaGlwcy5jc3YiKQpgYGAKClF1ZXN0aW9uIDE6CgpgYGB7cn0Kc3R1ZGVudF9saW5rcyAlPiUgCiAgZGF0YXRhYmxlKHJvd25hbWVzID0gRiwKICAgICAgICAgICAgY2FwdGlvbiA9ICdOb21pbmF0b3IgYW5kIE5vbWluYXRlZCBTY29yZXMgYW5kIEV4cGVjdGVkIFNjb3JlcycpCmBgYAoKVGhpcyBpcyBhIGRhdGEgdGFibGUgc2hvd2luZyB0aGUgc2NvcmVzIGZvciB0aGUgbm9taW5hdG9yIGFuZCB0aGUgbm9taW5hdGVkIHNob3dpbmcgaG93IHRoZXkgZWFjaCBzY29yZSBhbmQgcGVyY2lldmUgdGhlaXIgZnJpZW5kc2hpcC4gSXQgYWxzbyBzaG93cyB0aGUgZXhwZWN0ZWQgc2NvcmUgdGhhdCB0aGUgbm9taW5hdGVkIHBlcnNvbiBiZWxpZXZlZCB0aGF0IHRoZSBub21pbmF0b3Igd291bGQgZ2l2ZSB0aGVtLiAKClF1ZXN0aW9uIDI6CgpgYGB7cn0KZnJpZW5kc2hpcF9tb2RlbCA8LSBsbShleHBlY3RlZF9zY29yZSB+IHNjb3JlLCBkYXRhID0gc3R1ZGVudF9saW5rcykKCnRpZHkoZnJpZW5kc2hpcF9tb2RlbCkKYGBgCgpgYGB7cn0KZ2xhbmNlKGZyaWVuZHNoaXBfbW9kZWwpCmBgYAoKYGBge3J9CnN0dWRlbnRfbGlua3MgfD4KICBwbG90X2x5KHggPSB+c2NvcmUsIHkgPSB+ZXhwZWN0ZWRfc2NvcmUpIHw+CiAgYWRkX21hcmtlcnMoKSB8PgogIGFkZF9saW5lcyh5ID0gZml0dGVkKGZyaWVuZHNoaXBfbW9kZWwpKQpgYGAKClRoaXMgaXMgYSByZWdyZXNzaW9uIG1vZGVsIHNob3dpbmcgaG93IHdlbGwgYSBwZXJzb24gY2FuIHByZWRpY3QgZXhwZWN0ZWQgc2NvcmVzIGNvbXBhcmVkIHRvIHRoZSBhY3R1YWwgc2NvcmVzIG9mIGNsb3NlbmVzcyBpbiBmcmllbmRzaGlwcy4KClF1ZXN0aW9uIDM6CgpgYGB7cn0KZnJpZW5kcyA8LSBzdHVkZW50X2xpbmtzIHw+IAogIGZpbHRlcihzY29yZSA+IDMpIHw+IAogIHNlbGVjdChub21pbmF0b3IsIG5vbWluYXRlZCkgfD4gCiAgcmVuYW1lKGZyb20gPSBub21pbmF0b3IpIHw+IAogIHJlbmFtZSh0byA9IG5vbWluYXRlZCkKYGBgCgpgYGB7cn0KZnJpZW5kc2hpcF9uZXR3b3JrIDwtIGdyYXBoX2Zyb21fZGF0YV9mcmFtZShmcmllbmRzLCBzdHVkZW50cywgZGlyZWN0ZWQgPSBUKQpgYGAKCmBgYHtyfQpzdHVkZW50cyB8PiAKICAgIG11dGF0ZShuYW1lZF9mcmllbmRzID0gZGVncmVlKChmcmllbmRzaGlwX25ldHdvcmspLCBtb2RlID0gIm91dCIpKSB8PiAKICBtdXRhdGUobmFtZWRfYnlfb3RoZXJzPSBkZWdyZWUoKGZyaWVuZHNoaXBfbmV0d29yayksIG1vZGUgPSAiaW4iKSkgfD4gCiAgbXV0YXRlKHBvcHVsYXJpdHkgPSBuYW1lZF9ieV9vdGhlcnMgLSBuYW1lZF9mcmllbmRzKSB8PgogIHNlbGVjdChuYW1lZF9mcmllbmRzLCBuYW1lZF9ieV9vdGhlcnMsIHBvcHVsYXJpdHkpIHw+IAogIGRhdGF0YWJsZShyb3duYW1lcyA9IEYpCmBgYAoKVGhpcyBpcyBhIGRhdGEgdGFibGUgc2hvd2luZyB0aGUgdmFyaWFibGVzIG5hbWVkIGZyaWVuZHMsIG5hbWVkIGJ5IG90aGVycywgYW5kIHBvcHVsYXJpdHkuIFBvcHVsYXJpdHkgd2FzIGNhbGN1bGF0ZWQgYnkgdGFraW5nIHRoZSBudW1iZXIgb2YgdGltZXMgYSBwZXJzb24gbmFtZWQgdGhlaXIgZnJpZW5kcyBtaW51cyB0aGUgYW1vdW50IG9mIHRpbWVzIHRoZXkgd2VyZSBuYW1lZCBieSBvdGhlcnMgYXMgYSBmcmllbmQuICAKClF1ZXN0aW9uIDQ6CgpgYGB7cn0Kc3R1ZGVudHMgfD4gCiAgbXV0YXRlKG5hbWVkX2ZyaWVuZHMgPSBkZWdyZWUoKGZyaWVuZHNoaXBfbmV0d29yayksIG1vZGUgPSAib3V0IikpIHw+IAogIG11dGF0ZShuYW1lZF9ieV9vdGhlcnM9IGRlZ3JlZSgoZnJpZW5kc2hpcF9uZXR3b3JrKSwgbW9kZSA9ICJpbiIpKSB8PiAKICBwbG90X2x5KHggPSB+bmFtZWRfZnJpZW5kcykgfD4KICBhZGRfaGlzdG9ncmFtKCkgfD4KICBsYXlvdXQodGl0bGUgPSAiTnVtYmVyIG9mIEZyaWVuZHMgVGhhdCBTdHVkZW50cyBOYW1lZCIpCmBgYAoKVGhpcyBpcyBhIGhpc3RvZ3JhbSBzaG93aW5nIHRoZSBhbW91bnQgb2YgdGltZXMgdGhhdCBhIHN0dWRlbnQgbmFtZWQgYW5vdGhlciBzdHVkZW50IGFzIHRoZWlyIGZyaWVuZC4gIAoKUXVlc3Rpb24gNToKCmBgYHtyfQpyZWNpcHJvY2l0eShmcmllbmRzaGlwX25ldHdvcmssIG1vZGUgPSAicmF0aW8iKQoKYGBgCgpUaGUgcmVjaXByb2NpdHkgb2YgZnJpZW5kc2hpcHMgaW4gdGhlIG5ldHdvcmsgaXMgNTIlLCBtZWFuaW5nIHRoYXQgNTIlIG9mIHN0dWRlbnRzIHRoYXQgbmFtZWQgYW5vdGhlciBzdHVkZW50IGFzIHRoZWlyIGZyaWVuZCB3ZXJlIGFsc28gbmFtZWQgYmFjayBieSB0aGF0IHN0dWRlbnQgYXMgd2VsbC4gCgpRdWVzdGlvbiA2OgoKYGBge3J9CmJlc3RmcmllbmRzIDwtIHN0dWRlbnRfbGlua3MgfD4gCiAgZmlsdGVyKHNjb3JlID4gNCkgfD4gCiAgc2VsZWN0KG5vbWluYXRvciwgbm9taW5hdGVkKSB8PiAKICByZW5hbWUoZnJvbSA9IG5vbWluYXRvcikgfD4gCiAgcmVuYW1lKHRvID0gbm9taW5hdGVkKQpgYGAKCmBgYHtyfQpiZXN0ZnJpZW5kc2hpcF9uZXR3b3JrIDwtIGdyYXBoX2Zyb21fZGF0YV9mcmFtZShiZXN0ZnJpZW5kcywgc3R1ZGVudHMsIGRpcmVjdGVkID0gVCkKCmBgYAoKYGBge3J9CnN0dWRlbnRzIHw+ICAKICBtdXRhdGUoZ3JvdXAgPSBtZW1iZXJzaGlwKGluZm9tYXAuY29tbXVuaXR5KGJlc3RmcmllbmRzaGlwX25ldHdvcmspKSkgfD4KICBtdXRhdGUodmFsdWUgPSBkZWdyZWUoYmVzdGZyaWVuZHNoaXBfbmV0d29yaykpIHw+CiAgdmlzTmV0d29yayhmcmllbmRzLCBtYWluID0gIk5ldHdvcmsgb2YgYmVzdCBmcmllbmRzaGlwcyIpIHw+CiAgdmlzSWdyYXBoTGF5b3V0KGxheW91dCA9ICJsYXlvdXRfbmljZWx5IikgfD4KICB2aXNFZGdlcyhhcnJvd3MgPSAidG8iKSB8PgogIHZpc09wdGlvbnMoaGlnaGxpZ2h0TmVhcmVzdCA9IFQsIG5vZGVzSWRTZWxlY3Rpb24gPSBUKQpgYGAKClRoaXMgc2hvd3MgYSBuZXcgbmV0d29yayBjcmVhdGVkIHVzaW5nIG9ubHkgYmVzdCBmcmllbmRzLiBUaGUgZGlmZmVyZW50IGNvbG9ycyBpbmRpY2F0ZSBjb21tdW5pdGllcyBvZiBwZW9wbGUgdGhhdCByYXRlZCBlYWNob3RoZXIgc2ltaWxhcmlseS4gVGhlIHNpemUgaW5kaWNhdGVzIHRoZSBhbW91bnQgb2YgYmVzdCBmcmllbmRzIHRoYXQgYSBwZXJzb24gaGFzLiAKCgoKCgo=