Generate Newman-Watts Graphs

.gitignore

@@ -7,3 +7,6 @@ classes
 /.lein-*
 .nrepl-port
 out
+
+*iml
+.idea/*

src/loom/alg.cljc

@@ -10,9 +10,11 @@ can use these functions."
                      out-degree in-degree weighted? directed? graph digraph transpose]
              :as graph]
             [loom.alg-generic :refer [trace-path preds->span]]
-            #?(:clj [clojure.data.priority-map :as pm]
-               :cljs [tailrecursion.priority-map :as pm])
-            [clojure.set :as clj.set]))
+    #?(:clj
+            [clojure.data.priority-map :as pm]
+       :cljs [tailrecursion.priority-map :as pm])
+            [clojure.set :as clj.set]
+            [clojure.set :as set]))
 
 ;;;
 ;;; Convenience wrappers for loom.alg-generic functions
@@ -792,3 +794,32 @@ can use these functions."
                                       (edges g1))))))
 
 ;; ;; Todo: MST, coloring, matching, etc etc
+
+(defn clustering-coefficient
+  "Computes clustering coefficient as described in Watts and Strogatz (1998).
+  When g and node are supplied as arguments, returns the local clustering
+  coefficient for node in g. When only g is supplied as an argument, returns
+  the average over all clustering coefficients. For details see
+  Watts, Duncan J., and Steven H. Strogatz. “Collective Dynamics of ‘Small-World’
+  Networks.” Nature 393, no. 6684 (June 1998): 440–42. https://doi.org/10.1038/30918."
+  ([g node]
+   (let [neighbours (successors g node)
+         potential-connections (/ (* (count neighbours) (dec (count neighbours))) 2)]
+     (if (> (count neighbours) 1)
+       ;; how many connections between the neighbours
+       ;; of node are there?
+       (let [neighbour-overlaps (for [n neighbours]
+                                  (let [potential (clj.set/difference neighbours #{n})
+                                        actual (successors g n)
+                                        overlap (clj.set/intersection potential actual)]
+                                    (count overlap)))
+             sum-overlaps (reduce + 0 neighbour-overlaps)]
+         (/ sum-overlaps potential-connections 2))
+       ;; if there are not at least 2 neighbours,
+       ;; clustering-coefficient is set to zero
+       0)))
+  ([g]
+    (let [nodeset (nodes g)
+          sum-coeffs (reduce #(+ %1 (clustering-coefficient g %2)) 0 nodeset)]
+      (/ sum-coeffs (count nodeset)))))
+

src/loom/gen.clj

@@ -1,7 +1,7 @@
 (ns ^{:doc "Graph-generating functions"
       :author "Justin Kramer"}
   loom.gen
-  (:require [loom.graph :refer [weighted? directed? add-nodes* add-edges*]]))
+  (:require [loom.graph :refer [weighted? directed? add-nodes* add-edges* nodes]]))
 
 (defn gen-rand
   "Adds num-nodes nodes and approximately num-edges edges to graph g. Nodes
@@ -53,3 +53,38 @@
     (-> g
         (add-nodes* nodes)
         (add-edges* edges))))
+
+(defn gen-circle
+  "Adds num-nodes nodes to graph g and connects each one to out-degree
+  other nodes."
+  [g num-nodes out-degree]
+  {:pre [(> num-nodes (* out-degree 2))]}
+  (let [nodes (range num-nodes)
+        edges (for [n nodes
+                    d (range 1 (inc out-degree))]
+                [n (mod (+ n d) (count nodes))])]
+    (-> g
+        (add-nodes* nodes)
+        (add-edges* edges))))
+
+(defn ^:private add-shortcuts
+  "Computes additional edges for graph g as described in Newman and
+  Watts (1999)."
+  ([g phi seed]
+   (let [rnd (java.util.Random. seed)
+         nodes (loom.graph/nodes g)
+         shortcuts (for [n nodes
+                         :when (> phi (.nextDouble rnd))]
+                     [n (.nextInt rnd (count nodes))])]
+     (-> g
+         (add-edges* shortcuts)))))
+
+(defn gen-newman-watts
+  "Generate a graph with small-world properties as described in Newman
+  and Watts (1999)."
+  ([g num-nodes out-degree phi seed]
+   (-> g
+       (gen-circle num-nodes out-degree)
+       (add-shortcuts phi seed)))
+  ([g num-nodes out-degree phi]
+    (gen-newman-watts g num-nodes out-degree phi (System/nanoTime))))

test/loom/test/alg.cljc

@@ -13,7 +13,8 @@
                               coloring? greedy-coloring prim-mst-edges
                               prim-mst-edges prim-mst astar-path astar-dist
                               degeneracy-ordering maximal-cliques
-                              subgraph? eql? isomorphism?]]
+                              subgraph? eql? isomorphism?
+                              clustering-coefficient]]
             [loom.derived :refer [mapped-by]]
             clojure.walk
             #?@(:clj [[clojure.test :refer :all]]
@@ -627,3 +628,24 @@
     false (isomorphism? g7 (mapped-by inc g7) dec)
     false (isomorphism? (digraph) (graph) identity)
     false(isomorphism? (digraph [1 2]) (graph [1 2]) identity)))
+
+(deftest clustering-coefficient-test
+  (let [g1 (graph {0 #{}, 1 #{}, 2 #{}, 3 #{}})             ; empty graph
+        g2 (graph {0 #{1 2 3}, 1 #{0 2 3}, 2 #{0 1 3}, 3 #{0 1 2}}) ; fully connected
+        g3 (graph {0 #{1 4}, 1 #{2 0}, 2 #{3 1}, 3 #{4 2}, 4 #{0 3}}) ; circle
+        g4 (graph {0 #{1 2 3}, 1 #{0 3}, 2 #{0}, 3 #{0 1}})
+        g5 (graph [0 1] [0 2] [0 3] [1 3])]
+    (testing "local clustering coefficients"
+      (are [expected got] (= expected got)
+        (clustering-coefficient g1 0) 0
+        (clustering-coefficient g2 1) 1
+        (clustering-coefficient g3 0) 0
+        (clustering-coefficient g4 0) (/ 1 3)
+        (clustering-coefficient g5 0) (/ 1 3)))
+    (testing "global clustering coefficients"
+      (are [expected got] (= expected got)
+        (clustering-coefficient g1) 0
+        (clustering-coefficient g2) 1
+        (clustering-coefficient g3) 0
+        (clustering-coefficient g4) (/ 7 12)
+        (clustering-coefficient g4) (clustering-coefficient g5)))))

test/loom/test/gen.clj

@@ -0,0 +1,69 @@
+(ns loom.test.gen
+  (:require [clojure.test :refer (deftest testing is are)]
+            [loom.graph :refer (graph digraph weighted-graph weighted-digraph graph? nodes edges)]
+            [loom.alg :refer (clustering-coefficient)]
+            [loom.gen :refer (gen-circle gen-newman-watts gen-barabasi-albert)]))
+
+(deftest build-circle-test
+  (let [g1 (gen-circle (graph) 5 1)
+        g2 (gen-circle (graph) 6 2)
+        g3 (gen-circle (digraph) 6 2)
+        g4 (gen-circle (weighted-graph {0 {1 42 2 42} 1 {2 42 3 42} 2 {3 42 4 42}}) 10 1)
+        g5 (gen-circle (weighted-graph) 10 1)
+        g6 (gen-circle (weighted-digraph [0 1 42] [1 2 42] [2 3 42] [1 0 43] [2 1 43] [3 2 43]) 10 1)
+        g7 (gen-circle (weighted-digraph) 10 1)]
+    (testing "Generating circle-graphs from the different graph types"
+      (are [graphs] (graph? graphs)
+        g1 g2 g3 g4 g5 g6 g7))
+    (testing "Nodes and Edges"
+      (are [expected got] (= expected got)
+        (into #{} (range 5)) (nodes g1)
+        (into #{} (range 6)) (nodes g2)
+        (into #{} (range 6)) (nodes g3)
+        (into #{} (range 10)) (nodes g4)
+        (into #{} (range 10)) (nodes g5)
+        (into #{} (range 10)) (nodes g6)
+        (into #{} (range 10)) (nodes g7)
+        #{[0 1] [1 0] [1 2] [2 1] [2 3] [3 2] [3 4] [4 3] [4 0] [0 4]} (set (edges g1))
+        #{[0 1] [1 0] [1 2] [2 1] [2 3] [3 2] [3 4] [4 3] [4 5] [5 4] [5 0] [0 5]
+          [0 2] [2 0] [1 3] [3 1] [2 4] [4 2] [3 5] [5 3] [4 0] [0 4] [1 5] [5 1]} (set (edges g2))
+        #{[0 1] [1 2] [2 3] [3 4] [4 5] [5 0] [0 2] [1 3] [2 4] [3 5] [4 0] [5 1]} (set (edges g3))
+        #{[0 1] [1 2] [2 3] [3 4] [4 5] [5 6] [6 7] [7 8] [8 9] [9 0]
+          [0 2] [1 3] [2 4]
+          [1 0] [2 1] [3 2] [4 3] [5 4] [6 5] [7 6] [8 7] [9 8] [0 9]
+          [2 0] [3 1] [4 2]} (set (edges g4))
+        #{[0 1] [1 2] [2 3] [3 4] [4 5] [5 6] [6 7] [7 8] [8 9] [9 0]
+          [1 0] [2 1] [3 2] [4 3] [5 4] [6 5] [7 6] [8 7] [9 8] [0 9]} (set (edges g5))
+        #{[0 1] [1 2] [2 3] [3 4] [4 5] [5 6] [6 7] [7 8] [8 9] [9 0]
+          [1 0] [2 1] [3 2]} (set (edges g6))
+        #{[0 1] [1 2] [2 3] [3 4] [4 5] [5 6] [6 7] [7 8] [8 9] [9 0]} (set (edges g7))))))
+
+(deftest build-newman-watts-test
+  (let [g1 (gen-newman-watts (graph) 20 2 0.2)
+        g2 (gen-newman-watts (graph) 100 5 0.3)
+        g3 (gen-newman-watts (graph) 100 6 0)]
+    (testing "Construction, Nodes, Edges, Clustering coefficient for g1"
+      (is loom.graph/graph? g1)
+      (is (= 20 (count (nodes g1))))
+      (is (and
+            (>= (count (edges g1)) (* 2 20 2))
+            (<= (count (edges g1)) (+ (* 2 20 2) (* 20 2 0.35)))))
+      (is (and
+            (<= (- (/ 3 4) 0.5) (clustering-coefficient g1))
+            (>= (+ (/ 3 4) 0.5) (clustering-coefficient g1)))))
+    (testing "Construction, Nodes, Edges, Clustering coefficient for g2"
+      (is loom.graph/graph? g2)
+      (is (= 100 (count (nodes g2))))
+      (is (and
+            (>= (count (edges g2)) (* 2 100 5))
+            (<= (count (edges g2)) (+ (* 2 100 5) (* 100 5 0.45)))))
+      (is (and
+            (<= (- (/ 3 4) 0.5) (clustering-coefficient g2))
+            (>= (+ (/ 3 4) 0.5) (clustering-coefficient g2)))))
+    (testing "Construction, Nodes, Edges, Clustering coefficient for g3"
+      (is loom.graph/graph? g3)
+      (is (= 100 (count (nodes g2))))
+      (is (= (count (edges g3)) (* 2 100 6)))
+      (is (and
+            (<= (- (/ 3 4) 0.2) (clustering-coefficient g2))
+            (>= (+ (/ 3 4) 0.2) (clustering-coefficient g2)))))))