use_case.R
In netrankr: Analyzing Partial Rankings in Networks

## ----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")