-(in-package metabang.graph)
-
-(export '(generate-Gnp
- generate-Gnm
- generate-undirected-graph-via-assortativity-matrix
- generate-undirected-graph-via-vertex-probabilities
- generate-multi-group-graph-fixed
- #+Ignore generate-girvan-newman-graph
- generate-scale-free-graph
- generate-assortative-graph-with-degree-distributions
-
- generate-simple-preferential-attachment-graph
- generate-preferential-attachment-graph
-
- generate-acquaintance-network
- generate-acquaintance-network-until-stable
-
- generate-graph-by-resampling-edges
-
- sample-edge
- basic-edge-sampler
- weighted-edge-sampler
- simple-group-id-generator
- simple-group-id-parser
-
- make-degree-sampler
- poisson-vertex-degree-distribution
- power-law-vertex-degree-distribution))
-
-;;; ---------------------------------------------------------------------------
+(in-package #:metabang.graph)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(generate-gnp
+ generate-gnm
+ generate-undirected-graph-via-assortativity-matrix
+ generate-undirected-graph-via-vertex-probabilities
+ generate-multi-group-graph-fixed
+ #+Ignore generate-girvan-newman-graph
+ generate-scale-free-graph
+ generate-assortative-graph-with-degree-distributions
+
+ generate-simple-preferential-attachment-graph
+ generate-preferential-attachment-graph
+
+ generate-acquaintance-network
+ generate-acquaintance-network-until-stable
+
+ generate-graph-by-resampling-edges
+
+ sample-edge
+ basic-edge-sampler
+ weighted-edge-sampler
+ simple-group-id-generator
+ simple-group-id-parser
+
+ make-degree-sampler
+ poisson-vertex-degree-distribution
+ power-law-vertex-degree-distribution)))
+
;;; classes
-;;; ---------------------------------------------------------------------------
(defclass* generated-graph-mixin ()
((generation-method nil ir)
(random-seed nil ir)))
-;;; ---------------------------------------------------------------------------
(defun save-generation-information (graph generator method)
;; No
(setf (slot-value graph 'generation-method) method
(slot-value graph 'random-seed) (random-seed generator)))
-;;; ---------------------------------------------------------------------------
(defun simple-group-id-generator (kind count)
(form-keyword "H" (format nil "~2,'0D~4,'0D" kind count)))
-;;; ---------------------------------------------------------------------------
(defun simple-group-id-parser (vertex)
(parse-integer (subseq (symbol-name (element vertex)) 1 3)))
-;;; ---------------------------------------------------------------------------
-;;; generate-Gnp
-;;; ---------------------------------------------------------------------------
+;;; generate-gnp
-(defmethod generate-Gnp (generator (graph-class symbol) n p &key (label 'identity))
- (generate-Gnp
+(defmethod generate-gnp (generator (graph-class symbol) n p &key (label 'identity))
+ (generate-gnp
generator (make-instance graph-class) n p :label label))
-;;; ---------------------------------------------------------------------------
-(defmethod generate-Gnp (generator (graph basic-graph) n p &key (label 'identity))
+(defmethod generate-gnp (generator (graph basic-graph) n p &key (label 'identity))
(let ((v 1)
(w -1)
(log-1-p (log (- 1 p))))
graph))
-;;; ---------------------------------------------------------------------------
-;;; generate-Gnm
-;;; ---------------------------------------------------------------------------
+;;; generate-gnm
-(defmethod generate-Gnm (generator (graph-class symbol) n p &key (label 'identity))
- (generate-Gnm
+(defmethod generate-gnm (generator (graph-class symbol) n p &key (label 'identity))
+ (generate-gnm
generator (make-instance graph-class) n p :label label))
-;;; ---------------------------------------------------------------------------
-(defmethod generate-Gnm (generator (graph basic-graph) n m &key (label 'identity))
+(defmethod generate-gnm (generator (graph basic-graph) n m &key (label 'identity))
(let ((max-edge-index (1- (combination-count n 2))))
+ (assert (<= m max-edge-index))
#+Ignore
(save-generation-information graph generator 'generate-gnm)
(loop for i from 0 to (1- n) do
'graph-container 10000 (floor (* 0.0001 (combination-count 10000 2)))))
)
-;;; ---------------------------------------------------------------------------
(defun vertex-group (v)
(aref (symbol-name (element v)) 1))
-;;; ---------------------------------------------------------------------------
(defun in-group-degree (v &key (key 'vertex-group))
(vertex-degree
(declare (ignore e))
(in-same-group-p v ov key))))
-;;; ---------------------------------------------------------------------------
(defun in-same-group-p (v1 v2 key)
(eq (funcall key v1) (funcall key v2)))
-;;; ---------------------------------------------------------------------------
(defun out-group-degree (v &key (key 'vertex-group))
(vertex-degree
(declare (ignore e))
(not (in-same-group-p v ov key)))))
-;;; ---------------------------------------------------------------------------
;;; generate-undirected-graph-via-assortativity-matrix
-;;; ---------------------------------------------------------------------------
(defmethod generate-undirected-graph-via-assortativity-matrix
(generator (graph-class symbol) size edge-count
kind-matrix assortativity-matrix vertex-creator
:duplicate-edge-function duplicate-edge-function))
-;;; ---------------------------------------------------------------------------
(defmethod generate-undirected-graph-via-assortativity-matrix
(generator graph size edge-count
(values graph)))
-;;; ---------------------------------------------------------------------------
;;; generate-undirected-graph-via-verex-probabilities
-;;; ---------------------------------------------------------------------------
(defmethod generate-undirected-graph-via-vertex-probabilities
(generator (graph-class symbol) size
generator (make-instance graph-class) size
kind-matrix probability-matrix vertex-creator))
-;;; ---------------------------------------------------------------------------
(defmethod generate-undirected-graph-via-vertex-probabilities
(generator graph size
(lambda (kind count)
(form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
-;;; ---------------------------------------------------------------------------
(defun sample-edges-of-same-kind (generator n p fn)
(when (plusp p)
#+Test
(sample-edges-of-same-kind *random-generator* 10 0.2 (lambda (a b) (print (list a b))))
-;;; ---------------------------------------------------------------------------
(defun sample-edges-of-different-kinds (generator rows cols p fn)
(when (plusp p)
(when (< v rows)
(funcall fn v w)))))))
-;;; ---------------------------------------------------------------------------
(defun poisson-vertex-degree-distribution (z k)
- (/ (* (expt z k) (expt +e+ (- z)))
+ (/ (* (expt z k) (expt cl-mathstats:+e+ (- z)))
(factorial k)))
#|
from this distribution
|#
-;;; ---------------------------------------------------------------------------
(defun power-law-vertex-degree-distribution (kappa k)
- (* (- 1 (expt +e+ (- (/ kappa)))) (expt +e+ (- (/ k kappa)))))
+ (* (- 1 (expt cl-mathstats:+e+ (- (/ kappa))))
+ (expt cl-mathstats:+e+ (- (/ k kappa)))))
-;;; ---------------------------------------------------------------------------
(defun create-specified-vertex-degree-distribution (degrees)
(lambda (z k)
(declare (ignore z k))
degrees))
-;;; ---------------------------------------------------------------------------
(defun make-degree-sampler (p_k &key (generator *random-generator*)
(max-degree 1000)
(lambda ()
(first (next-element wsc)))))
-;;; ---------------------------------------------------------------------------
#+Old
(defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
(loop repeat edge-count collect
(next-element c))))
-;;; ---------------------------------------------------------------------------
(defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
(let ((s (make-edge-sampler-for-assortative-graph generator assortativity-matrix)))
(loop repeat edge-count collect
(funcall s))))
-;;; ---------------------------------------------------------------------------
(defun make-edge-sampler-for-assortative-graph (generator assortativity-matrix)
(let ((c (make-container 'weighted-sampling-container
(insert-item c (list i j))))
(lambda () (next-element c))))
-;;; ---------------------------------------------------------------------------
(defun sample-vertexes-for-mixed-graph (generator size kind-matrix)
(cond ((every-element-p kind-matrix (lambda (x) (fixnump x)))
mixing-matrix)))
-;;; ---------------------------------------------------------------------------
;;; girvan-newman-test-graphs
-;;; ---------------------------------------------------------------------------
(defun generate-girvan-newman-graph (generator graph-class z-in)
(warn "This is broken!")
- (bind ((g (make-instance graph-class))
+ (let ((g (make-instance graph-class))
(group-count 4)
(group-size 32)
(edge-count 16)
(check-type from-group fixnum)
(loop
- (bind ((other-group (integer-random generator 0 (- group-count 2)))
+ (let ((other-group (integer-random generator 0 (- group-count 2)))
(other (sample-element
(item-at groups (if (= from-group other-group)
(1+ other-group)
(values g)))
-;;; ---------------------------------------------------------------------------
(defun gn-id->group (id)
(parse-integer (subseq (symbol-name id) 1 2)))
-;;; ---------------------------------------------------------------------------
(defun collect-edge-counts (g)
(let ((vertexes (make-container 'simple-associative-container
(iterate-edges
g
(lambda (e)
- (bind ((v1 (vertex-1 e))
+ (let ((v1 (vertex-1 e))
(v2 (vertex-2 e))
(id1 (element v1))
(id2 (element v2)))
#'string-lessp
:key #'first)))
-;;; ---------------------------------------------------------------------------
(defclass* weighted-sampler-with-lookup-container ()
((sampler nil r)
(lookup nil r)))
-;;; ---------------------------------------------------------------------------
(defmethod initialize-instance :after ((object weighted-sampler-with-lookup-container)
&key random-number-generator key)
(slot-value object 'lookup)
(make-container 'simple-associative-container)))
-;;; ---------------------------------------------------------------------------
(defmethod insert-item ((container weighted-sampler-with-lookup-container)
(item t))
(assert (not (null node)))
(setf (item-at-1 (lookup container) item) node)))
-;;; ---------------------------------------------------------------------------
(defmethod find-node ((container weighted-sampler-with-lookup-container)
(item t))
(item-at-1 (lookup container) item))
-;;; ---------------------------------------------------------------------------
(defmethod delete-node ((container weighted-sampler-with-lookup-container)
(node t))
;; not going to worry about the hash table
(delete-node (sampler container) node))
-;;; ---------------------------------------------------------------------------
(defmethod next-element ((container weighted-sampler-with-lookup-container))
(next-element (sampler container)))
-;;; ---------------------------------------------------------------------------
(defmethod generate-scale-free-graph
(generator graph size kind-matrix add-edge-count
(list vertex other-kind))))
(update (kind thing)
;; handle bookkeeping for changed vertex degree
- (bind ((sampler (aref vertex-sampler kind))
+ (let ((sampler (aref vertex-sampler kind))
(node (find-node sampler thing)))
(delete-node sampler node)
(insert-item sampler thing))))
graph)))
-;;; ---------------------------------------------------------------------------
#+Test
(defun poisson-connector (count generator)
|#
-;;; ---------------------------------------------------------------------------
;;; generate-assortative-graph-with-degree-distributions
-;;; ---------------------------------------------------------------------------
#+Ignore
(define-debugging-class generate-assortative-graph-with-degree-distributions ())
-;;; ---------------------------------------------------------------------------
(defmethod generate-assortative-graph-with-degree-distributions
(generator (graph-class symbol)
(flet ((sample-edges-for-vertex (vertex)
;(spy vertex)
(loop repeat (item-at-1 vertex-degrees vertex) do
- (bind (((edge-kind . edge) (delete-last edge-sampler)))
+ (let (((edge-kind . edge) (delete-last edge-sampler)))
(ecase edge-kind
(:source (setf (first edge) vertex))
(:target (setf (second edge) vertex)))))))
(0.2222222222222222 0.4444444444444444))))
:test #'eq)
-;;; ---------------------------------------------------------------------------
;;; generate-graph-by-resampling-edges
-;;; ---------------------------------------------------------------------------
#|
doesn't take edge weights into account when sampling
((generator nil ir)
(graph nil ir)))
-;;; ---------------------------------------------------------------------------
(defmethod next-element ((sampler basic-edge-sampler))
(sample-element (graph-edges (graph sampler)) (generator sampler)))
-;;; ---------------------------------------------------------------------------
(defclass* weighted-edge-sampler (basic-edge-sampler)
((weight-so-far 0 a)
(edge-iterator nil r)
(size nil ir)))
-;;; ---------------------------------------------------------------------------
(defmethod initialize-instance :after ((object weighted-edge-sampler) &key)
- (bind ((generator (generator object))
+ (let ((generator (generator object))
(weighted-edge-count
(let ((result 0))
(iterate-edges (graph object) (lambda (e) (incf result (weight e))))
(slot-value object 'edge-iterator)
(make-iterator (graph-edges (graph object))))))
-;;; ---------------------------------------------------------------------------
(defmethod next-element ((object weighted-edge-sampler))
(let ((edge-iterator (edge-iterator object))
(generate-graph-by-resampling-edges
*random-generator* g 'weighted-edge-sampler (edge-count g)))))))))
-;;; ---------------------------------------------------------------------------
;;; some preferential attachment algorithms
-;;; ---------------------------------------------------------------------------
#+Ignore
(define-debugging-class generate-preferential-attachment-graph
(graph-generation))
-;;; ---------------------------------------------------------------------------
+
+(defmethod generate-simple-preferential-attachment-graph
+ (generator (graph-class symbol) size minimum-degree)
+ (generate-simple-preferential-attachment-graph
+ generator (make-instance graph-class) size minimum-degree))
+
(defmethod generate-simple-preferential-attachment-graph
(generator graph size minimum-degree)
- (bind ((m (make-array (list (* 2 size minimum-degree)))))
+ (let ((m (make-array (list (* 2 size minimum-degree)))))
(loop for v from 0 to (1- size) do
(loop for i from 0 to (1- minimum-degree) do
- (bind ((index (* 2 (+ i (* v minimum-degree))))
+ (let ((index (* 2 (+ i (* v minimum-degree))))
(r (integer-random generator 0 index)))
(setf (item-at m index) v
(item-at m (1+ index)) (item-at m r)))))
:sort #'>
:sort-on :values)
-;;; ---------------------------------------------------------------------------
(defmethod generate-preferential-attachment-graph
(generator (graph-class symbol) size kind-matrix minimum-degree
:vertex-labeler vertex-labeler
:duplicate-edge-function duplicate-edge-function))
-;;; ---------------------------------------------------------------------------
(defmethod generate-preferential-attachment-graph
(generator (graph basic-graph) size kind-matrix minimum-degree
assortativity-matrix
&key (vertex-labeler 'simple-group-id-generator)
(duplicate-edge-function :ignore))
- (bind ((kind-count (array-dimension kind-matrix 0))
+ (let ((kind-count (array-dimension kind-matrix 0))
(vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
(vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
(edge-recorders (make-array (list kind-count)))
;; add vertexes (to ensure that we have something at which to point)
(loop for v from 0 to (1- size)
for kind in vertex-kinds do
- (bind ((edge-recorder (aref edge-recorders kind)))
+ (let ((edge-recorder (aref edge-recorders kind)))
(loop for i from 0 to (1- minimum-degree) do
- (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
+ (let ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
(setf (item-at edge-recorder index)
(funcall vertex-labeler kind v)))))
(incf (aref count-recorders kind)))
(setf (aref count-recorders i) 0))
(loop for v from 0 to (1- size)
for kind in vertex-kinds do
- (bind ((edge-recorder (aref edge-recorders kind))
+ (let ((edge-recorder (aref edge-recorders kind))
(edge-sampler (aref edge-samplers kind)))
(loop for i from 0 to (1- minimum-degree) do
- (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
+ (let ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
(other-kind (funcall edge-sampler))
(other-index (* 2 (+ i (* (min (1- (item-at vertex-kind-counts other-kind))
(aref count-recorders other-kind))
(loop for vertex across (aref edge-recorders kind)
for index = 0 then (1+ index)
when (consp vertex) do
- (bind (((other-kind other-index) vertex))
+ (let (((other-kind other-index) vertex))
#+Ignore
(when-debugging-format
generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A"
graph))
-;;; ---------------------------------------------------------------------------
(defun make-edge-sampler-for-preferential-attachment-graph (generator assortativities)
(let ((c (make-container 'weighted-sampling-container
(0.02 0.25 0.25)
(0.02 0.25 0.25))))
-;;; ---------------------------------------------------------------------------
-(Defmethod generate-acquaintance-network
+
+(defmethod generate-acquaintance-network
+ (generator (class-name symbol) size death-probability iterations vertex-labeler
+ &key (duplicate-edge-function :ignore))
+ (generate-acquaintance-network
+ generator (make-instance class-name)
+ size death-probability iterations vertex-labeler
+ :duplicate-edge-function duplicate-edge-function))
+
+(defmethod generate-acquaintance-network
(generator graph size death-probability iterations vertex-labeler
&key (duplicate-edge-function :ignore))
;; bring the graph up to size
generator graph death-probability duplicate-edge-function))
(values graph))
-;;; ---------------------------------------------------------------------------
(defmethod generate-acquaintance-network-until-stable
(generator graph size death-probability step-count
(values graph))
-;;; ---------------------------------------------------------------------------
(defun add-acquaintance-and-maybe-kill-something
(generator graph death-probability duplicate-edge-function)
;; add edges step
- (bind ((vertex (sample-element (graph-vertexes graph) generator))
+ (let ((vertex (sample-element (graph-vertexes graph) generator))
(neighbors (when (>= (size (vertex-edges vertex)) 2)
(sample-unique-elements
(vertex-edges vertex) generator 2))))
(flet ((sample-other-vertex ()
(loop for result = (sample-element (graph-vertexes graph) generator)
until (not (eq vertex result))
- finally (return result)))) ;; CTM: 'finally do' not legal in openMCL
+ finally (return result))))
(if neighbors
(add-edge-between-vertexes
graph
(let ((vertex (sample-element (graph-vertexes graph) generator)))
(delete-vertex graph vertex)
(add-vertex graph (element vertex)))))
+
+#+Ignore
+(defun sv (v)
+ (format t "~%~A ~A"
+ v
+ (adjustable-array-p (contents (vertex-edges v)))))
#+Test
(generate-acquaintance-network
projects / cl-graph.git / blobdiff