Igraph - Enlever le bord le plus faible de chaque triangle

Question

Disons que j'ai un grand réseau et que je veux supprimer, pour chaque triangle, le bord le plus faible en fonction de son poids. Donc, si le graphique

A - B, B - C, C - A, D - A a des poids 0,5, 0,3, 0,2, 0,1

respectivement, retirer C - A (le sommet D ne fait pas partie d'un triangle).

Quel est le moyen le plus efficace de le faire?

Answer 1

Commençons par un exemple un peu plus intéressant qui a deux triangles:

dat <- data.frame(V1=c("A", "B", "C", "D", "D"), V2=c("B", "C", "A", "A", "B"), wt=c(0.5, 0.3, 0.2, 0.1, 0.3), stringsAsFactors=FALSE) 

Pour plus de commodité plus tard, nous commanderons des sommets par ordre alphabétique

dat <- data.frame(V1=pmin(dat$V1, dat$V2), V2=pmax(dat$V1, dat$V2), wt=dat$wt) 

Regardons notre graphique:

library(igraph) 
G <-graph.data.frame(dat, directed=FALSE) 
plot(G, edge.label=E(G)$wt) 

La fonction igraph cliques peut trouver tous les triangles (qui sont cliques de taille 3):

(triangles <- do.call(rbind, lapply(cliques(G, min=3, max=3), function(x) sort(V(G)$name[x])))) 
#  [,1] [,2] [,3] 
# [1,] "A" "B" "C" 
# [2,] "A" "B" "D" 

Pour identifier les bords de poids minimal pour enlever de telle sorte que l'on se débarrasse de tous les triangles, je propose une formulation de programmation entière, où nous avons une variable binaire pour chaque arête indiquant si elle est supprimée. Nous avons une contrainte pour chaque triangle qui nécessite qu'au moins une arête du triangle soit supprimée. L'objectif est de minimiser la somme des poids des arêtes supprimées. Ceci est assez simple à faire avec le paquet lpSolve, et je le fais dans la fonction ci-dessous, qui met toutes nos pas ensemble:

library(lpSolve) 
min.cost.removal <- function(dat) { 
    dat <- data.frame(V1=pmin(dat$V1, dat$V2), V2=pmax(dat$V1, dat$V2), wt=dat$wt) 
    G <-graph.data.frame(dat, directed=FALSE) 
    triangles <- do.call(rbind, lapply(cliques(G, min=3, max=3), function(x) sort(V(G)$name[x]))) 
    constr <- t(apply(triangles, 1, function(x) (dat$V1 == x[1] & dat$V2 == x[2]) + 
               (dat$V1 == x[1] & dat$V2 == x[3]) + 
               (dat$V1 == x[2] & dat$V2 == x[3]))) 
    mod <- lp(objective.in = dat$wt, 
      const.mat = constr, 
      const.dir = rep(">=", nrow(triangles)), 
      const.rhs = rep(1, nrow(triangles)), 
      all.bin = TRUE) 
    dat[mod$solution >= 0.999,] 
} 

Pour notre graphique, la programmation entière identifie à juste titre que l'approche minimale coût pour la suppression tous les triangles enlève les bords AC et AD:

min.cost.removal(dat) 
# V1 V2 wt 
# 3 A C 0.2 
# 4 A D 0.1 

Si nous réduisons considérablement le poids sur le bord AB (je diminue à 0,2 ici), puis en retirant ce bord devient le meilleur moyen de supprimer les deux triangles en même Heure:

dat <- data.frame(V1=c("A", "B", "C", "D", "D"), V2=c("B", "C", "A", "A", "B"), wt=c(0.2, 0.3, 0.2, 0.1, 0.3), stringsAsFactors=FALSE) 
min.cost.removal(dat) 
# V1 V2 wt 
# 1 A B 0.2