Nothing
## ----libs, warning=FALSE,message=FALSE----------------------------------------
library(igraph)
library(netrankr)
library(magrittr)
## ----plot,fig.height=5,fig.width=5,fig.align='center'-------------------------
data("florentine_m")
#Delete Pucci family (isolated)
florentine_m <- delete_vertices(florentine_m,which(degree(florentine_m)==0))
#plot the graph (label size proportional to wealth)
set.seed(111)
plot(florentine_m,
vertex.label.cex=V(florentine_m)$wealth*0.01,
vertex.label.color="black",
vertex.color="white",
vertex.frame.color="gray")
## ----cent---------------------------------------------------------------------
cent.df <- data.frame(
degree = degree(florentine_m),
betweenness = betweenness(florentine_m),
closeness = closeness(florentine_m),
eigenvector = eigen_centrality(florentine_m)$vector,
subgraph = subgraph_centrality(florentine_m))
# most central family according to the 5 indices
V(florentine_m)$name[apply(cent.df,2,which.max)]
## ----cent_new-----------------------------------------------------------------
#odd subgraph centrality
sc_odd <- florentine_m %>%
indirect_relations(type = "walks",FUN = walks_exp_odd) %>%
aggregate_positions(type = "self")
#family with highest score
V(florentine_m)$name[which.max(sc_odd)]
## ----ni-----------------------------------------------------------------------
P <- neighborhood_inclusion(florentine_m)
## ----ni_comp------------------------------------------------------------------
comparable_pairs(P)
## ----dom_graph,fig.height=5,fig.width=5,fig.align='center'--------------------
d <- dominance_graph(P)
V(d)$name <- V(florentine_m)$name
set.seed(113)
plot(d,vertex.label.color="black",
vertex.color="white",
vertex.frame.color="gray",
edge.arrow.size=0.5)
## ----rk_inter,fig.align='center',fig.width=5,fig.height=5---------------------
plot(rank_intervals(P))
## ----probs--------------------------------------------------------------------
res <- exact_rank_prob(P)
## ----likely_most_central------------------------------------------------------
top_rank_prob <- res$rank.prob[,15]
names(top_rank_prob) <- V(florentine_m)$name
round(top_rank_prob[top_rank_prob>0.1],3)
## ----medici_strozzi,eval=TRUE-------------------------------------------------
id_strozzi <- which(V(florentine_m)$name=="Strozzi")
id_medici <- which(V(florentine_m)$name=="Medici")
res$relative.rank[id_strozzi,id_medici]
## ----exp_rank,echo=FALSE------------------------------------------------------
tab <- data.frame(Name=V(florentine_m)$name,Expected=round(res$expected.rank,2))
tab <- tab[order(tab[,2],decreasing=TRUE),]
knitr::kable(tab,row.names = F)
## ----closeness_vs_wealth------------------------------------------------------
#Closeness
c_C <- florentine_m %>%
indirect_relations(type="dist_sp") %>%
aggregate_positions(type="invsum")
cor(c_C,V(florentine_m)$wealth,method="kendall")
## ----harmclos_wealth----------------------------------------------------------
#harmonic closeness
c_HC <- florentine_m %>%
indirect_relations(type="dist_sp",FUN=dist_inv) %>%
aggregate_positions(type="sum")
#residual closeness (Dangalchev,2006)
c_RC <- florentine_m %>%
indirect_relations(type="dist_sp",FUN=dist_2pow) %>%
aggregate_positions(type="sum")
#integration centrality (Valente & Foreman, 1998)
dist_integration <- function(x){
x <- 1 - (x - 1)/max(x)
}
c_IN <- florentine_m %>%
indirect_relations(type="dist_sp",FUN=dist_integration) %>%
aggregate_positions(type="sum")
c(cor(c_HC,V(florentine_m)$wealth,method="kendall"),
cor(c_RC,V(florentine_m)$wealth,method="kendall"),
cor(c_IN,V(florentine_m)$wealth,method="kendall")
)
## ----distalpha_wealth,warning=FALSE-------------------------------------------
#generalized closeness (Agneessens et al.,2017) (alpha>0) sum(dist^-alpha)
alpha <- c(seq(0.01,0.99,0.01),seq(1,10,0.1))
scores <-
sapply(alpha,function(x)
florentine_m %>%
indirect_relations(type="dist_sp",FUN=dist_dpow,alpha=x) %>%
aggregate_positions(type="sum")
)
cors_gc <- apply(scores,2,
function(x)cor(x,V(florentine_m)$wealth,method="kendall"))
res_gc <- c(max(cors_gc),alpha[which.max(cors_gc)])
#decay centrality (Jackson, 2010) (alpha in [0,1]) sum(alpha^dist)
alpha <- seq(0.01,0.99,0.01)
scores <-
sapply(alpha,function(x)
florentine_m %>%
indirect_relations(type="dist_sp",FUN=dist_powd,alpha=x) %>%
aggregate_positions(type="sum")
)
cors_dc <- apply(scores,2,
function(x)cor(x,V(florentine_m)$wealth,method="kendall"))
res_dc <- c(max(cors_dc),alpha[which.max(cors_dc)])
## ----pos_dom_hetero-----------------------------------------------------------
D <- florentine_m %>%
indirect_relations(type="dist_sp") %>%
positional_dominance(benefit=F)
comparable_pairs(D)
## ----pos_dom_homo-------------------------------------------------------------
D <- florentine_m %>%
indirect_relations(type="dist_sp") %>%
positional_dominance(benefit=F,map=T)
comparable_pairs(D)
## ----plot dist_dom,fig.align="center",fig.height=5,fig.width=5,echo=F---------
d <- dominance_graph(D)
V(d)$name <- V(florentine_m)$name
x <- V(florentine_m)$wealth
x[9] <- x[9]-50
x[14] <- x[14]-50
y <- colSums(D)
el <- get.edgelist(d,names = F)
E(d)$color <- "gray"
col <- apply(el,1,function(x)V(florentine_m)$wealth[x[1]]>V(florentine_m)$wealth[x[2]])
#wrong:41
E(d)$color[col] <- "indianred"
plot(d,layout=cbind(x,y),
vertex.label.cex=0.75,
vertex.label.color="black",
vertex.color="white",
vertex.frame.color="gray",
edge.arrow.size=0.4
)
## ----rk_inter_dist,fig.align='center',fig.width=5,fig.height=5----------------
plot(rank_intervals(D))
## ----dist_probs---------------------------------------------------------------
res <- exact_rank_prob(D)
## ----dist_probs_lat-----------------------------------------------------------
res <- exact_rank_prob(D,only.results = FALSE)
## ----all_rankings-------------------------------------------------------------
all_ranks <- get_rankings(res)
dim(all_ranks)
## ----all_cors-----------------------------------------------------------------
dist_cor <- apply(all_ranks,2,
function(x)cor(V(florentine_m)$wealth,x,method="kendall"))
c(max_cor = max(dist_cor),mean_cor = mean(dist_cor))
## ----cor_deg------------------------------------------------------------------
cor(degree(florentine_m),V(florentine_m)$wealth,method="kendall")
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.