########################Complex Systems Networks##########################
library(igraph)
##
## Attaching package: 'igraph'
## The following objects are masked from 'package:stats':
##
## decompose, spectrum
## The following object is masked from 'package:base':
##
## union
edgelist<-read.csv("weighted_authorship.csv")
edgelist <-edgelist
edgelist <- edgelist[,-1]
weights <- edgelist[,3]
edgelist <- edgelist[,1:2]
dim(edgelist)
## [1] 734 2
names(edgelist)
## [1] "V1" "V2"
edgelist <- as.matrix(edgelist)
#Creates a campus indicator by semester
#a$campus<-ifelse(a$term==min(a$term), as.character(a$sem1_campus), as.character(a$sem2_campus))
#head(a[a$sem1_campus!=a$sem2_campus,c("term", "sem1_campus", "sem2_campus", "campus")], 200)
#The following code retrieves the student-course connections to be saved under an graph object called "g"
g<- graph.edgelist(edgelist, directed = FALSE)
E(g)$weight <-weights
#Gets centrality measures
cent<-data.frame(bet=betweenness(g, normalized=T, directed = FALSE)/max(betweenness(g, normalized=T, directed = FALSE)),eig=evcent(g)$vector, degree=degree(g, mode="total"))
cent$name<-rownames(cent) #Ids in this case
head(cent);tail(cent)
## bet eig degree name
## bebianno, mj 1.000000000 1.0000000 172 bebianno, mj
## serafim, a 0.047306189 0.8275401 57 serafim, a
## company, r 0.065530701 0.6875101 61 company, r
## langston, wj 0.001004348 0.1805738 8 langston, wj
## cravo, a 0.013193838 0.3530326 33 cravo, a
## lopes, b 0.011543521 0.3444342 32 lopes, b
## bet eig degree name
## sawyer, gs 0.001301605 0.01314032 10 sawyer, gs
## nieto, jm 0.004156166 0.04181687 13 nieto, jm
## norberto, r 0.008206451 0.04498953 13 norberto, r
## pereira, r 0.008206451 0.04498953 13 pereira, r
## nowell, g 0.004156166 0.04181687 13 nowell, g
## araujo, o 0.008206451 0.04498953 13 araujo, o
#Gets time invariant actor attributes
#actors<- a[!duplicated(a$pseudoid), c("pseudoid", "hsgpa", "sem2_cume_gpa", "year1_persist",
#"year1_creditsearned", "firstgen")]
#Interactive Visualization
V(g)$label<-V(g)$name
V(g)$name<-1:length(V(g))
#In HTML visualizations (like NetworkD3) we need two datasets, one for links, another for nodes attributes.
#Gets edgelist from graph, also any other attribute at the edge level to be included in the mapping
links<-as.data.frame(cbind(get.edgelist(g), E(g)$weight))
#Needs to be numeric
links$V1<-as.numeric(as.character(links$V1))
links$V2<-as.numeric(as.character(links$V2))
str(links)
## 'data.frame': 734 obs. of 3 variables:
## $ V1: num 1 1 2 1 1 1 1 1 1 2 ...
## $ V2: num 2 3 3 4 5 6 7 8 9 6 ...
## $ V3: chr "36" "27" "22" "15" ...
links$V3<-round(as.numeric(as.character(links$V3)),3)
head(links)
## V1 V2 V3
## 1 1 2 36
## 2 1 3 27
## 3 2 3 22
## 4 1 4 15
## 5 1 5 15
## 6 1 6 11
colnames(links)<-c("source","target", "value")
#Counts begin at zero in computer programming
links[,1:2]<-(links[,1:2]-1)
dim(links)
## [1] 734 3
#b1<-aggregate(position~artist, data=b, FUN=mean)
#Adding attributes at the actor level
V(g)$size<- cent$bet[match(V(g)$label, cent$name)]
#V(g)$group <- round(cent$eig[match(V(g)$label, b1$artist)],3)
V(g)$eig <- round(cent$eig[match(V(g)$label, cent$name)],3)
###############################################################################
#If you have codes with no attributes at the code level, this may be needed##
###############################################################################
# V(g)$firstgen <- ifelse(is.na(V(g)$firstgen), .5, V(g)$firstgen)
#V(g)$group <- ifelse(is.na(V(g)$group), 1, V(g)$group)
#summary(V(g)$size)
#summary(V(g)$group)
nodes <- data.frame(name= V(g)$label, size=abs(V(g)$size), eig = V(g)$eig)
nodes$name<-as.character(nodes$name)
summary(nodes$eig)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.01200 0.01300 0.02300 0.05882 0.04500 1.00000
#Name of course, rather than code
#nodes$name[(i+1):length(V(g)$label)] <- a$crse_ld[match(nodes$name[(i+1):length(V(g)$label)], a$term_course)]
#head(nodes);tail(nodes)
nodes$group<-NA
nodes$group <-cut(nodes$eig, c(0,.013,.02300,.0458,max(nodes$eig)), right=TRUE, labels = c(
1,2,3,4))
table(is.na(nodes$group))
##
## FALSE
## 173
table(nodes$group)
##
## 1 2 3 4
## 61 26 45 41
head(nodes[is.na(nodes$group),],20)
## [1] name size eig group
## <0 rows> (or 0-length row.names)
nodes$group<-ifelse(nodes$group==1, "Low Quartile", ifelse(nodes$group==2, "Second quartile", ifelse(nodes$group==3, "Third quartile", "Top quartile")))
counts<-data.frame(table(nodes$group))
counts$labels <- paste(counts$Var1, ", N= ", counts$Freq, sep="")
nodes$groups <- counts$labels[match(nodes$group, counts$Var1)]
head(counts)
## Var1 Freq labels
## 1 Low Quartile 61 Low Quartile, N= 61
## 2 Second quartile 26 Second quartile, N= 26
## 3 Third quartile 45 Third quartile, N= 45
## 4 Top quartile 41 Top quartile, N= 41
library(networkD3)
library(magrittr)
library(htmlwidgets)
##
## Attaching package: 'htmlwidgets'
## The following object is masked from 'package:networkD3':
##
## JS
library(htmltools)
netviz<-forceNetwork(Links = links, Nodes = nodes,
Source = 'source', Target = 'target',
NodeID = 'name',
Group = "groups", # color nodes by group calculated earlier
charge = -30, # node repulsion
linkDistance = JS("function(d) { return d.linkDistance; }"),#JS("function(d){return d.value}"),
linkWidth = JS("function(d) { return Math.sqrt(d.value)*2; }"),
opacity = 0.8,
Value = "value",
Nodesize = 'size',
radiusCalculation = JS("Math.sqrt(d.nodesize*30)+4"),
zoom = T,
fontSize=14,
bounded= F,
legend= TRUE)
# linkColour = JS("d3.scaleOrdinal(d3.schemeCategory10)"))
HTMLaddons <-
"function(el, x) {
d3.select('body').style('background-color', ' #212f3d ')
d3.selectAll('.legend text').style('fill', 'white')
d3.selectAll('.link').append('svg:title')
.text(function(d) { return 'Collaborations ' + d.value ; })
var options = x.options;
var svg = d3.select(el).select('svg')
var node = svg.selectAll('.node');
var link = svg.selectAll('link');
var mouseout = d3.selectAll('.node').on('mouseout');
function nodeSize(d) {
if (options.nodesize) {
return eval(options.radiusCalculation);
} else {
return 6;
}
}
d3.selectAll('.node').on('click', onclick)
function onclick(d) {
if (d3.select(this).on('mouseout') == mouseout) {
d3.select(this).on('mouseout', mouseout_clicked);
} else {
d3.select(this).on('mouseout', mouseout);
}
}
function mouseout_clicked(d) {
node.style('opacity', +options.opacity);
link.style('opacity', +options.opacity);
d3.select(this).select('circle').transition()
.duration(750)
.attr('r', function(d){return nodeSize(d);});
d3.select(this).select('text').transition()
.duration(1250)
.attr('x', 0)
.style('font', options.fontSize + 'px ');
}
}
"
netviz$x$links$linkDistance <- (1/links$value)*500
onRender(netviz, HTMLaddons)