Visualisation interactive de réseaux

Présentation des packages

Dans ce qui suit, nous allons utiliser les package suivants :

Nous allons utilisé comme exemple le jeu de données mulitiniveaux de graphlayouts.

data("multilvl_ex", package = "graphlayouts")

On va utiliser le package MLVSBM pour attribuer des blocks aux noeuds du réseau.

super_adj <- as_adjacency_matrix(multilvl_ex, sparse =  FALSE)
adj_upper  <- super_adj[order(rownames(super_adj))[1:50],
                        order(rownames(super_adj))[1:50]]
adj_lower  <- super_adj[order(rownames(super_adj))[51:170],
                        order(rownames(super_adj))[51:170]]
affiliation <- super_adj[order(rownames(super_adj))[51:170],
                         order(rownames(super_adj))[1:50]]
library(MLVSBM)
my_mlvsbm <- mlvsbm_create_network(X = list(I = adj_lower,
                                            O = adj_upper),
                                   A = affiliation)
fit <- mlvsbm_estimate_network(mlv = my_mlvsbm)
## 
## 

































[1] "Infering lower level :"
## [1] "# blocks: 6, ICL = -1796.99535741011 !"
## 
## 











[1] "Infering upper level :"
## [1] "# blocks: 4, ICL = -256.543365849578 !"
## [1] "======= # Individual clusters : 6 , # Organisation clusters 4,  ICL : -2065.52232386241========"
## [1] "======= # Individual blocks : 6 , # Organizational blocks 4,  ICL : -2065.52232386241========"
## [1] "ICL for independent levels : -2053.53872325969"
## [1] "ICL for interdependent levels : -2065.52232386241"
## [1] "=====The levels of this network are independent!====="
V(multilvl_ex)$block[order(rownames(super_adj))] <- c(fit$Z$O, fit$Z$I + 4)

On définit un layout avec la fonction suivante du package graphlayouts. Une matrice de taille \(n \times d\) est retourné où \(n\) est le nombre total de noeud du réseau et \(d\) est le nombre de dimension du plot.

On peut faire un layout pour tout le réseau. La fonction d’optimisation pour le layout est appliqué à tous les réseaux conjointements.

xy <- layout_as_multilevel(multilvl_ex,type = "all", alpha = 25, beta = 45)
as_tbl_graph(multilvl_ex) %>%
  activate(edges) %>% 
  mutate(block = ifelse(.N()$block[to] == .N()$block[from], 
                        .N()$block[to], 
                        NA)) %>% 
  ggraph( "manual", x = xy[, 1], y = xy[, 2]) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 1 & node2.lvl == 1),
    edge_colour = block
  ),
  alpha = 0.5, edge_width = 0.2) +
  geom_edge_link0(
    aes(filter = (node1.lvl != node2.lvl)),
    alpha = 0.3,
    edge_width = 0.1,
    edge_colour = "black"
  ) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 2 & node2.lvl == 2),
    edge_colour = block
  ),
  edge_width = 0.2, alpha = 0.5) +
  geom_node_point(aes(
    fill = block,
    shape = as.factor(lvl),
    size = nsize
  )) +
    ggforce::geom_mark_hull(
    aes(x, y, group = block, fill = block, label=block),
    concavity = 4,
    expand = unit(2, "mm"),
    alpha = 0.25
  ) +
  scale_shape_manual(values = c(21, 22)) +
  scale_size_continuous(range = c(1.5, 4.5)) +
  scale_fill_viridis(option = "A") +
  scale_edge_colour_viridis(option = "A",  na.value = "grey50") +
  scale_edge_alpha_manual(values = c(0.1, 0.7)) +
  theme_graph() +
  coord_cartesian(clip = "off", expand = TRUE) +
  theme(legend.position = "none")

Ou bien définir un fonction de layout différent par niveau.

xy <- layout_as_multilevel(multilvl_ex,type = "separate",
                           FUN1 = layout_as_backbone,
                           FUN2 = layout_with_stress,
                           alpha = 25, beta = 45)
as_tbl_graph(multilvl_ex) %>%
  activate(edges) %>% 
  mutate(block = ifelse(.N()$block[to] == .N()$block[from], 
                        .N()$block[to], 
                        NA)) %>% 
  ggraph( "manual", x = xy[, 1], y = xy[, 2]) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 1 & node2.lvl == 1),
    edge_colour = block
  ),
  alpha = 0.5, edge_width = 0.2) +
  geom_edge_link0(
    aes(filter = (node1.lvl != node2.lvl)),
    alpha = 0.3,
    edge_width = 0.1,
    edge_colour = "black"
  ) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 2 & node2.lvl == 2),
    edge_colour = block
  ),
  edge_width = 0.2, alpha = 0.5) +
  geom_node_point(aes(
    fill = block,
    shape = as.factor(lvl),
    size = nsize
  )) +
  ggforce::geom_mark_hull(
    aes(x, y, group = block, fill = block, label=block),
    concavity = 4,
    expand = unit(2, "mm"),
    alpha = 0.25
  ) +
  scale_shape_manual(values = c(21, 22)) +
  scale_size_continuous(range = c(1.5, 4.5)) +
  scale_fill_viridis(option = "A") +
  scale_edge_colour_viridis(option = "A",  na.value = "grey50") +
  scale_edge_alpha_manual(values = c(0.1, 0.7)) +
  theme_graph() +
  coord_cartesian(clip = "off", expand = TRUE) +
  theme(legend.position = "none")

Ou alors fixer le layout d’un niveau et ordonné l’autre niveau de manière à minimiser la longueur des liens (ou le nombre de croisement des liens ?) interniveaux.

xy <- layout_as_multilevel(multilvl_ex,type = "fix2",
                           FUN2 = layout_with_stress,
                           alpha = 25, beta = 45)

as_tbl_graph(multilvl_ex) %>%
  activate(edges) %>% 
  mutate(block = ifelse(.N()$block[to] == .N()$block[from], 
                        .N()$block[to], 
                        NA)) %>% 
  ggraph( "manual", x = xy[, 1], y = xy[, 2]) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 1 & node2.lvl == 1),
    edge_colour = block
  ),
  alpha = 0.5, edge_width = 0.2) +
  geom_edge_link0(
    aes(filter = (node1.lvl != node2.lvl)),
    alpha = 0.3,
    edge_width = 0.1,
    edge_colour = "black"
  ) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 2 & node2.lvl == 2),
    edge_colour = block
  ),
  edge_width = 0.2, alpha = 0.5) +
  geom_node_point(aes(
    fill = block,
    shape = as.factor(lvl),
    size = nsize
  )) +
  scale_shape_manual(values = c(21, 22)) +
  scale_size_continuous(range = c(1.5, 4.5)) +
  scale_fill_viridis(option = "A") +
  scale_edge_colour_viridis(option = "A",  na.value = "grey50") +
  scale_edge_alpha_manual(values = c(0.1, 0.7)) +
  theme_graph() +
  coord_cartesian(clip = "off", expand = TRUE) +
  theme(legend.position = "none")

Fixer le layout du niveau du dessous :

xy <- layout_as_multilevel(multilvl_ex,
                           type = "fix1",
                           FUN1 = layout_as_backbone,
                           alpha = 25, beta = 45)

as_tbl_graph(multilvl_ex) %>%
  activate(edges) %>% 
  mutate(block = ifelse(.N()$block[to] == .N()$block[from], 
                        .N()$block[to], 
                        NA)) %>% 
  ggraph( "manual", x = xy[, 1], y = xy[, 2]) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 1 & node2.lvl == 1),
    edge_colour = block
  ),
  alpha = 0.5, edge_width = 0.2) +
  geom_edge_link0(
    aes(filter = (node1.lvl != node2.lvl)),
    alpha = 0.3,
    edge_width = 0.1,
    edge_colour = "black"
  ) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 2 & node2.lvl == 2),
    edge_colour = block
  ),
  edge_width = 0.2, alpha = 0.5) +
  geom_node_point(aes(
    fill = block,
    shape = as.factor(lvl),
    size = nsize
  )) +
  scale_shape_manual(values = c(21, 22)) +
  scale_size_continuous(range = c(1.5, 4.5)) +
  scale_fill_viridis(na.value = "grey50", option = "A") +
  scale_edge_colour_viridis( na.value = "grey50", option = "A") +
  scale_edge_alpha_manual(values = c(0.1, 0.7)) +
  theme_graph() +
  coord_cartesian(clip = "off", expand = TRUE) +
  theme(legend.position = "none")

Représentation avec widget interactif avec threejs

Avec threejs, on peut faire un graph en 3d sur le quel on peut effectuer des rotations ou bien zoomer. On peut également animé le graph pour effectuer des transitions d’un layout à u autre :

V(multilvl_ex)$color <- scales::viridis_pal(option = "A")(10)[V(multilvl_ex)$block]
V(multilvl_ex)$vertex.label <- V(multilvl_ex)$name
    
graphjs(multilvl_ex, 
        layout = list(
          layout_as_multilevel(multilvl_ex, type = "all", alpha = 25, beta = 45,
                               project2D = FALSE),
          layout_as_multilevel(multilvl_ex,type = "separate",
                           FUN1 = layout_as_backbone,
                           FUN2 = layout_with_stress,
                           project2D = FALSE),
          layout_as_multilevel(multilvl_ex,
                           type = "fix1",
                           FUN1 = layout_as_backbone,
                           alpha = 25, beta = 45, project2D = FALSE),
          layout_as_multilevel(multilvl_ex,
                           type = "fix2",
                           FUN2 = layout_with_stress,
                           alpha = 25, beta = 45, project2D = FALSE)
          ),
        main=list("all layout", "separate layout",
                  "lower layout", "upper layout"),
        fpl=300)

En 3d standard avec .

xyz <- layout_as_multilevel(multilvl_ex,type = "separate",
                           FUN1 = layout_as_backbone,
                           FUN2 = layout_with_stress,
                           project2D = FALSE)
multilvl_ex$layout <- xyz
V(multilvl_ex)$color <- scales::viridis_pal(option = "A")(10)[V(multilvl_ex)$block]
V(multilvl_ex)$vertex.label <- V(multilvl_ex)$name
    
graphjs(multilvl_ex, bg="white", vertex.shape="sphere")

network3D et forcenetwork

Le package network3d permet de cliquer sur certaine partie du réseau. Mais on ne peut pas lui imposer le layout défini avec les package graphlayouts ou igraph.

xy <- layout_as_multilevel(multilvl_ex,
                           type = "separate",
                           FUN1 = layout_as_backbone,
                           FUN2 = layout_with_stress,
                           alpha = 25, beta = 45)

net_d3 <- as_tbl_graph(multilvl_ex) %>%
  activate(edges) %>% 
  mutate(block = ifelse(.N()$block[to] == .N()$block[from], 
                        .N()$block[to], 
                        NA)) %>%  igraph_to_networkD3(group = V(multilvl_ex)$block)

forceNetwork(Links = net_d3$links, Nodes = net_d3$nodes,
             Source = 'source', Target = 'target', NodeID = 'name',
             Group = 'group', opacity = .8)

Il ne semble pas y avoir de moyen d’importe un layout…

Avec ggiraph

Avec ggiraph, on peut faire apparaitre un popup pour avoir des informations sur les noeuds (et/ou les arêtes ?).

library(ggiraph)
xy <- layout_as_multilevel(multilvl_ex,type = "separate",
                           FUN1 = layout_as_backbone,
                           FUN2 = layout_with_stress,
                           alpha = 25, beta = 45)

p <- as_tbl_graph(multilvl_ex) %>%
  activate(edges) %>% 
  mutate(block = ifelse(.N()$block[to] == .N()$block[from], 
                        .N()$block[to], 
                        NA)) %>% 
  ggraph( "manual", x = xy[, 1], y = xy[, 2]) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 1 & node2.lvl == 1),
    edge_colour = block
  ),
  alpha = 0.5, edge_width = 0.2) +
  geom_edge_link0(
    aes(filter = (node1.lvl != node2.lvl)),
    alpha = 0.3,
    edge_width = 0.1,
    edge_colour = "black",
    edge_linetype = "dashed"
  ) +
  geom_edge_link0(aes(
    filter = (node1.lvl == 2 & node2.lvl == 2),
    edge_colour = block
  ),
  edge_width = 0.2, alpha = 0.5) +
  geom_point_interactive(aes(
    x = x,
    y = y,
    fill = block,
    shape = as.factor(lvl),
    size = nsize, 
    tooltip = paste0(name, ": ", "\n",
                      "group: ", grp, "\n",
                      "block: ", block, "\n",
                      "degree: ", nsize)
  )) +
  scale_shape_manual(values = c(21, 22)) +
  scale_size_continuous(range = c(1.5, 4.5)) +
  scale_fill_viridis(option = "A") +
  scale_edge_colour_viridis(option = "A",  na.value = "grey50") +
  scale_edge_alpha_manual(values = c(0.1, 0.7)) +
  theme_graph() +
  coord_cartesian(clip = "off", expand = TRUE) +
  theme(legend.position = "none")
girafe(ggobj = p, 
        options = list(opts_tooltip(use_fill = TRUE),
                       opts_hover_inv(css = "opacity:0.1;"),
    opts_hover(css = "fill:red;")))

Widget interactif avec visNetwork (S. Donnet)

On propose d’utiliser le package visNetwork (développé par un dirigeant de RStudio).

Essai sur un cas simple.

library(visNetwork)
nodes <- data.frame(id = 1:3,
                    color.background = c("red", "blue", "green"),
                    color.highlight.background = c("red", NA, "red"),
                    shadow.size = c(5, 10, 15))

edges <- data.frame(from = c(1,2), to = c(1,3),
                    label = LETTERS[1:2],
                    font.color =c ("red", "blue"),
                    font.size = c(10,20))


visNetwork(nodes, edges)

Cela semble joli. De plus, on peut spécifier des caratérisqiques globales ou locales pour les neouds et arêtes.

On essaie donc sur un réseaux petit mais avec plus de contraintes.

load('data/myDataNetwork.rda')

list_Net <- resMBM$list_Net
whichModel = 1
dataR6 <- GREMLIN:::formattingData(list_Net,v_distrib = resMBM$fittedModel[[whichModel]]$paramEstim$v_distrib)
Q <- length(resMBM$fittedModel[[1]]$paramEstim$list_pi)
nbNet <- length(resMBM$fittedModel[[1]]$paramEstim$list_theta)
param <- resMBM$fittedModel[[whichModel]]$paramEstim
v_K <- param$v_K
labelNode <- lapply(1:Q,function(q){1:v_K[q]})
sizeNode <- lapply(1:Q,function(q){param$list_pi[[q]]})
cumVK <-  c(0,cumsum(v_K))
codeNode <- lapply(2:(Q + 1),function(q){seq(cumVK[q - 1] + 1,cumVK[q],1)})

myNodes = as.data.frame(unlist(codeNode))
names(myNodes) = 'id'
myNodes$shadow.size <- 1
myNodes$group <- rep(dataR6$namesFG,v_K)
mycol <-  palette(rainbow(Q))
myshapes <-  c("square", "triangle",  "star",
                      "ellipse", "database", "text", "diamond")[1:Q]
myNodes$label = unlist(lapply(1:Q,function(q){1:v_K[q]}))
myNodes$color.highlight.background <- 'NA'
myNodes$value <- unlist(sizeNode)*rep(dataR6$v_NQ,v_K)
myEdges <- as.data.frame(cbind(sample(1:7,10,replace=TRUE),sample(1:7,10,replace=TRUE)))
names(myEdges) <- c('from','to')

On définit un dataframe pour les noeuds et un pour les arêtes.

P <- visNetwork(myNodes,myEdges)
for (q in 1:Q) {
 P    <- P %>% visGroups(groupname = dataR6$namesFG[q], color = mycol[q], shape = myshapes[q])
}
P %>% visLegend( main = "Functional Groups")

Avis : Il est difficile de contrôler à la fois les options globales et par noeuds. Le rendu est un peu artisanal (par exemple certaines shapes on un label dedans, d’autres en dessous) et gadget. Le rendu joli grâce aux ombres mais difficilement utilisable pour des dessins automatiques. Par ailleurs, le côté widget n’est pas utile pour les petits réseaux (vue mesoscopiques des SBM) Je vais plutôt essayer avec ggraph.