dev/graph-generation.lisp

   1 (in-package metabang.graph)
   2
   3 (eval-when (:compile-toplevel :load-toplevel :execute)
   4   (export '(generate-gnp
   5             generate-gnm
   6             generate-undirected-graph-via-assortativity-matrix
   7             generate-undirected-graph-via-vertex-probabilities
   8             generate-multi-group-graph-fixed
   9             #+Ignore generate-girvan-newman-graph
  10             generate-scale-free-graph
  11             generate-assortative-graph-with-degree-distributions
  12
  13             generate-simple-preferential-attachment-graph
  14             generate-preferential-attachment-graph
  15
  16             generate-acquaintance-network
  17             generate-acquaintance-network-until-stable
  18
  19             generate-graph-by-resampling-edges
  20
  21             sample-edge
  22             basic-edge-sampler
  23             weighted-edge-sampler
  24             simple-group-id-generator
  25             simple-group-id-parser
  26
  27             make-degree-sampler
  28             poisson-vertex-degree-distribution
  29             power-law-vertex-degree-distribution)))
  30
  31 ;;; ---------------------------------------------------------------------------
  32 ;;; classes
  33 ;;; ---------------------------------------------------------------------------
  34
  35 (defclass* generated-graph-mixin ()
  36   ((generation-method nil ir)
  37    (random-seed nil ir)))
  38
  39 ;;; ---------------------------------------------------------------------------
  40
  41 (defun save-generation-information (graph generator method)
  42   ;; No
  43   ;; (setf (random-seed generator) (random-seed generator))
  44   (unless (typep graph 'generated-graph-mixin)
  45     (change-class graph (find-or-create-class
  46                          'basic-graph (list 'generated-graph-mixin
  47                                             (class-name (class-of graph))))))
  48   (setf (slot-value graph 'generation-method) method
  49         (slot-value graph 'random-seed) (random-seed generator)))
  50
  51 ;;; ---------------------------------------------------------------------------
  52
  53 (defun simple-group-id-generator (kind count)
  54   (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count)))
  55
  56 ;;; ---------------------------------------------------------------------------
  57
  58 (defun simple-group-id-parser (vertex)
  59   (parse-integer (subseq (symbol-name (element vertex)) 1 3)))
  60
  61
  62 ;;; ---------------------------------------------------------------------------
  63 ;;; generate-gnp
  64 ;;; ---------------------------------------------------------------------------
  65
  66 (defmethod generate-gnp (generator (graph-class symbol) n p &key (label 'identity))
  67   (generate-gnp
  68    generator (make-instance graph-class) n p :label label))
  69
  70 ;;; ---------------------------------------------------------------------------
  71
  72 (defmethod generate-gnp (generator (graph basic-graph) n p &key (label 'identity))
  73   (let ((v 1)
  74         (w -1)
  75         (log-1-p (log (- 1 p))))
  76     (save-generation-information graph generator 'generate-gnp)
  77     (loop for i from 0 to (1- n) do
  78           (add-vertex graph (funcall label i)))
  79     (loop while (< v n) do
  80           (let ((r (uniform-random generator 0d0 1d0)))
  81             (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
  82             (loop while (and (>= w v) (< v n)) do
  83                   (setf w (- w v)
  84                         v (1+ v)))
  85             (when (< v n)
  86               (add-edge-between-vertexes
  87                graph (funcall label v) (funcall label w)))))
  88
  89     graph))
  90
  91 ;;; ---------------------------------------------------------------------------
  92 ;;; generate-gnm
  93 ;;; ---------------------------------------------------------------------------
  94
  95 (defmethod generate-gnm (generator (graph-class symbol) n p &key (label 'identity))
  96   (generate-gnm
  97    generator (make-instance graph-class) n p :label label))
  98
  99 ;;; ---------------------------------------------------------------------------
 100
 101 (defmethod generate-gnm (generator (graph basic-graph) n m &key (label 'identity))
 102   (let ((max-edge-index (1- (combination-count n 2))))
 103     (assert (<= m max-edge-index))
 104     #+Ignore
 105     (save-generation-information graph generator 'generate-gnm)
 106     (loop for i from 0 to (1- n) do
 107           (add-vertex graph (funcall label i)))
 108     (loop for i from 0 to (1- m) do
 109           (loop
 110             until (let* ((i (integer-random generator 0 max-edge-index))
 111                          (v (1+ (floor (+ -0.5 (sqrt (+ 0.25 (* 2 i)))))))
 112                          (w (- i (/ (* v (1- v)) 2)))
 113                          (label-v (funcall label v))
 114                          (label-w (funcall label w)))
 115                     (unless (find-edge-between-vertexes
 116                              graph label-v label-w :error-if-not-found? nil)
 117                       (add-edge-between-vertexes graph label-v label-w)))))
 118
 119     graph))
 120
 121 #+Ignore
 122 (pro:with-profiling
 123   (setf g (generate-gnm
 124            *random-generator*
 125            'graph-container 10000 (floor (* 0.0001 (combination-count 10000 2)))))
 126   )
 127
 128 ;;; ---------------------------------------------------------------------------
 129
 130 (defun vertex-group (v)
 131   (aref (symbol-name (element v)) 1))
 132
 133 ;;; ---------------------------------------------------------------------------
 134
 135 (defun in-group-degree (v &key (key 'vertex-group))
 136   (vertex-degree
 137    v :edge-filter (lambda (e ov)
 138                     (declare (ignore e))
 139                     (in-same-group-p v ov key))))
 140
 141 ;;; ---------------------------------------------------------------------------
 142
 143 (defun in-same-group-p (v1 v2 key)
 144   (eq (funcall key v1) (funcall key v2)))
 145
 146 ;;; ---------------------------------------------------------------------------
 147
 148 (defun out-group-degree (v &key (key 'vertex-group))
 149   (vertex-degree
 150    v :edge-filter (lambda (e ov)
 151                     (declare (ignore e))
 152                     (not (in-same-group-p v ov key)))))
 153
 154 ;;; ---------------------------------------------------------------------------
 155 ;;; generate-undirected-graph-via-assortativity-matrix
 156 ;;; ---------------------------------------------------------------------------
 157
 158 (defmethod generate-undirected-graph-via-assortativity-matrix
 159            (generator (graph-class symbol) size edge-count
 160                       kind-matrix assortativity-matrix vertex-creator
 161                       &key (duplicate-edge-function 'identity))
 162   (generate-undirected-graph-via-assortativity-matrix
 163    generator (make-instance graph-class)  size edge-count
 164    kind-matrix assortativity-matrix vertex-creator
 165    :duplicate-edge-function duplicate-edge-function))
 166
 167 ;;; ---------------------------------------------------------------------------
 168
 169 (defmethod generate-undirected-graph-via-assortativity-matrix
 170            (generator graph size edge-count
 171                       kind-matrix assortativity-matrix vertex-creator
 172                       &key (duplicate-edge-function 'identity))
 173   (let* ((kind-count (array-dimension assortativity-matrix 0))
 174          (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
 175                              #'<))
 176          (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
 177          (vertex-sampler (make-array kind-count))
 178          (edge-kinds (sample-edges-for-assortative-graph
 179                       generator edge-count assortativity-matrix))
 180          )
 181     (save-generation-information graph generator 'generate-undirected-graph-via-assortativity-matrix)
 182
 183     (loop for vertex-kind from 0 to (1- kind-count)
 184           for count in vertex-kind-counts do
 185           (setf (aref vertex-sampler vertex-kind)
 186                 (make-array (second count))))
 187
 188     (let ((current-kind 0)
 189           (current-count 0)
 190           (current-vertexes (aref vertex-sampler 0)))
 191       ;; add vertexes
 192       (loop for kind in vertex-kinds
 193             for i from 0 do
 194             (when (not (eq current-kind kind))
 195               (setf current-count 0
 196                     current-kind kind
 197                     current-vertexes (aref vertex-sampler current-kind)))
 198             (let ((vertex (funcall vertex-creator kind i)))
 199               (setf (aref current-vertexes current-count) vertex)
 200               (add-vertex graph vertex)
 201               (incf current-count)))
 202
 203       (loop for (from-kind to-kind) in edge-kinds do
 204             (let ((v1 nil)
 205                   (v2 nil))
 206               (if (= from-kind to-kind)
 207                 (let ((sample (sample-unique-elements (aref vertex-sampler from-kind)
 208                                                       generator 2)))
 209                   (setf v1 (first sample) v2 (second sample)))
 210                 (setf v1 (sample-element (aref vertex-sampler from-kind) generator)
 211                       v2 (sample-element (aref vertex-sampler to-kind) generator)))
 212               (add-edge-between-vertexes
 213                graph
 214                v1
 215                v2
 216                :if-duplicate-do (lambda (e) (funcall duplicate-edge-function e))))))
 217
 218       (values graph)))
 219
 220 ;;; ---------------------------------------------------------------------------
 221 ;;; generate-undirected-graph-via-verex-probabilities
 222 ;;; ---------------------------------------------------------------------------
 223
 224 (defmethod generate-undirected-graph-via-vertex-probabilities
 225            (generator (graph-class symbol) size
 226                       kind-matrix probability-matrix vertex-creator)
 227   (generate-undirected-graph-via-vertex-probabilities
 228    generator (make-instance graph-class) size
 229    kind-matrix probability-matrix vertex-creator))
 230
 231 ;;; ---------------------------------------------------------------------------
 232
 233 (defmethod generate-undirected-graph-via-vertex-probabilities
 234            (generator graph size
 235                       kind-matrix probability-matrix vertex-creator)
 236   (let* ((kind-count (array-dimension probability-matrix 0))
 237          (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
 238                              #'<))
 239          (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
 240          (vertex-sampler (make-array kind-count)))
 241     (save-generation-information graph generator
 242                                  'generate-undirected-graph-via-vertex-probabilities)
 243
 244     ;; initialize vertex bookkeeping
 245     (loop for vertex-kind from 0 to (1- kind-count)
 246           for count in vertex-kind-counts do
 247           (setf (aref vertex-sampler vertex-kind)
 248                 (make-array (second count))))
 249
 250     ;; add vertexes
 251     (let ((current-kind 0)
 252           (current-count 0)
 253           (current-vertexes (aref vertex-sampler 0)))
 254       (loop for kind in vertex-kinds
 255             for i from 0 do
 256             (when (not (eq current-kind kind))
 257               (setf current-count 0
 258                     current-kind kind
 259                     current-vertexes (aref vertex-sampler current-kind)))
 260             (let ((vertex (funcall vertex-creator kind i)))
 261               (setf (aref current-vertexes current-count) vertex)
 262               (add-vertex graph vertex)
 263               (incf current-count))))
 264
 265     #+Ignore
 266     ;; adjust probabilities
 267     (loop for (kind-1 count-1) in vertex-kind-counts do
 268           (loop for (kind-2 count-2) in vertex-kind-counts
 269                 when (<= kind-1 kind-2) do
 270                 (format t "~%~6,6F ~6,6F"
 271                         (aref probability-matrix kind-1 kind-2)
 272                         (float (/ (aref probability-matrix kind-1 kind-2)
 273                                   (* count-1 count-2))))
 274                 (setf (aref probability-matrix kind-1 kind-2)
 275                       (float (/ (aref probability-matrix kind-1 kind-2)
 276                                 (* count-1 count-2))))))
 277
 278     ;; add edges
 279     (flet ((add-one-edge (k1 k2 a b)
 280              (add-edge-between-vertexes
 281               graph
 282               (aref (aref vertex-sampler k1) a)
 283               (aref (aref vertex-sampler k2) b))))
 284       (loop for (kind-1 count-1) in vertex-kind-counts do
 285             (loop for (kind-2 count-2) in vertex-kind-counts
 286                   when (<= kind-1 kind-2) do
 287                   (if (eq kind-1 kind-2)
 288                     (sample-edges-of-same-kind
 289                      generator count-1 (aref probability-matrix kind-1 kind-2)
 290                      (lambda (a b)
 291                        (add-one-edge kind-1 kind-2 a b)))
 292                     (sample-edges-of-different-kinds
 293                      generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
 294                      (lambda (a b)
 295                        (add-one-edge kind-1 kind-2 a b)))))))
 296     (values graph)))
 297
 298
 299 #+Debug
 300 (defmethod generate-undirected-graph-via-vertex-probabilities
 301            (generator graph size
 302                       kind-matrix probability-matrix vertex-creator)
 303   (let* ((kind-count (array-dimension probability-matrix 0))
 304          (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
 305                              #'<))
 306          (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
 307          (vertex-sampler (make-array kind-count)))
 308
 309     (loop for vertex-kind from 0 to (1- kind-count)
 310           for count in vertex-kind-counts do
 311           (setf (aref vertex-sampler vertex-kind)
 312                 (make-array (second count))))
 313
 314     (let ((current-kind 0)
 315           (current-count 0)
 316           (current-vertexes (aref vertex-sampler 0)))
 317       ;; add vertexes
 318       (loop for kind in vertex-kinds
 319             for i from 0 do
 320             (when (not (eq current-kind kind))
 321               (setf current-count 0
 322                     current-kind kind
 323                     current-vertexes (aref vertex-sampler current-kind)))
 324             (let ((vertex (funcall vertex-creator kind i)))
 325               (setf (aref current-vertexes current-count) vertex)
 326               (add-vertex graph vertex)
 327               (incf current-count))))
 328
 329     (let ((xxx 0))
 330       (flet ((add-one-edge (k1 k2 a b)
 331                (incf xxx)
 332                (add-edge-between-vertexes
 333                 graph
 334                 (aref (aref vertex-sampler k1) a)
 335                 (aref (aref vertex-sampler k2) b))))
 336         (loop for (kind-1 count-1) in vertex-kind-counts do
 337               (loop for (kind-2 count-2) in vertex-kind-counts
 338                     when (<= kind-1 kind-2) do
 339                     (setf xxx 0)
 340                     (if (eq kind-1 kind-2)
 341                       (sample-edges-of-same-kind
 342                        generator count-1 (aref probability-matrix kind-1 kind-2)
 343                        (lambda (a b)
 344                          (add-one-edge kind-1 kind-2 a b)))
 345                       (sample-edges-of-different-kinds
 346                        generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
 347                        (lambda (a b)
 348                          (add-one-edge kind-1 kind-2 a b))))
 349                     (format t "~%~A ~A ~A ~A -> ~A"
 350                             count-1 count-2 kind-1 kind-2 xxx)))))
 351     (values graph)))
 352
 353
 354 #+Test
 355 (generate-undirected-graph-via-vertex-probabilities
 356  *random-generator* 'graph-container
 357  30
 358  #(0.8 0.2)
 359  #2A((0.1 0.02) (0.02 0.6))
 360  (lambda (kind count)
 361    (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
 362
 363 ;;; ---------------------------------------------------------------------------
 364
 365 (defun sample-edges-of-same-kind (generator n p fn)
 366   (when (plusp p)
 367     (let ((v 1)
 368           (w -1)
 369           (log-1-p (log (- 1 p))))
 370       (loop while (< v n) do
 371             (let ((r (uniform-random generator 0d0 1d0)))
 372               (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
 373               (loop while (and (>= w v) (< v n)) do
 374                     (setf w (- w v)
 375                           v (1+ v)))
 376               (when (< v n)
 377                 (funcall fn v w)))))))
 378
 379 #+Test
 380 (sample-edges-of-same-kind *random-generator* 10 0.2 (lambda (a b) (print (list a b))))
 381
 382 ;;; ---------------------------------------------------------------------------
 383
 384 (defun sample-edges-of-different-kinds (generator rows cols p fn)
 385   (when (plusp p)
 386     (let ((v 1)
 387           (w -1)
 388           (log-1-p (log (- 1 p))))
 389       (loop while (< v rows) do
 390             (let ((r (uniform-random generator 0d0 1d0)))
 391               (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
 392               (loop while (and (>= w cols) (< v rows)) do
 393                     (setf w (- w cols)
 394                           v (1+ v)))
 395               (when (< v rows)
 396                 (funcall fn v w)))))))
 397
 398 ;;; ---------------------------------------------------------------------------
 399
 400 (defun poisson-vertex-degree-distribution (z k)
 401   (/ (* (expt z k) (expt +e+ (- z)))
 402      (factorial k)))
 403
 404 #|
 405 We know the probability of finding a vertex of degree k is p_k. We want to sample
 406 from this distribution
 407 |#
 408
 409 ;;; ---------------------------------------------------------------------------
 410
 411 (defun power-law-vertex-degree-distribution (kappa k)
 412   (* (- 1 (expt +e+ (- (/ kappa)))) (expt +e+ (- (/ k kappa)))))
 413
 414 ;;; ---------------------------------------------------------------------------
 415
 416 (defun create-specified-vertex-degree-distribution (degrees)
 417   (lambda (z k)
 418     (declare (ignore z k))
 419     degrees))
 420
 421 ;;; ---------------------------------------------------------------------------
 422
 423 (defun make-degree-sampler (p_k &key (generator *random-generator*)
 424                                 (max-degree 1000)
 425                                 (min-probability 0.0001))
 426   (let ((wsc (make-container 'containers:weighted-sampling-container
 427                              :random-number-generator generator
 428                              :key #'second))
 429         (total 0.0)
 430         (max-k 0))
 431     (loop for k = 0 then (1+ k)
 432           for p = (funcall p_k k)
 433           until (or (and max-degree (> k max-degree))
 434                     (and min-probability (< (- 1.0 total) min-probability))) do
 435           (incf total p)
 436           (setf max-k k)
 437           (insert-item wsc (list k p)))
 438     (when (plusp (- 1.0 total))
 439       (insert-item wsc (list (1+ max-k) (- 1.0 total))))
 440     (lambda ()
 441       (first (next-element wsc)))))
 442
 443 ;;; ---------------------------------------------------------------------------
 444
 445 #+Old
 446 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
 447   (let ((c (make-container 'weighted-sampling-container
 448                            :random-number-generator generator
 449                            :key (lambda (item)
 450                                   (aref assortativity-matrix (first item) (second item))))))
 451     (dotimes (i (array-dimension assortativity-matrix 0))
 452       (dotimes (j (array-dimension assortativity-matrix 1))
 453         (insert-item c (list i j))))
 454     (loop repeat edge-count collect
 455           (next-element c))))
 456
 457 ;;; ---------------------------------------------------------------------------
 458
 459 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
 460   (let ((s (make-edge-sampler-for-assortative-graph generator assortativity-matrix)))
 461     (loop repeat edge-count collect
 462           (funcall s))))
 463
 464 ;;; ---------------------------------------------------------------------------
 465
 466 (defun make-edge-sampler-for-assortative-graph (generator assortativity-matrix)
 467   (let ((c (make-container 'weighted-sampling-container
 468                            :random-number-generator generator
 469                            :key (lambda (item)
 470                                   (aref assortativity-matrix (first item) (second item))))))
 471     (dotimes (i (array-dimension assortativity-matrix 0))
 472       (dotimes (j (array-dimension assortativity-matrix 1))
 473         (insert-item c (list i j))))
 474     (lambda () (next-element c))))
 475
 476 ;;; ---------------------------------------------------------------------------
 477
 478 (defun sample-vertexes-for-mixed-graph (generator size kind-matrix)
 479   (cond ((every-element-p kind-matrix (lambda (x) (fixnump x)))
 480          ;; use kind-matrix as counts
 481          (assert (= size (sum-of-array-elements kind-matrix)))
 482          (coerce (shuffle-elements!
 483                   (make-array size
 484                               :initial-contents
 485                               (loop for i = 0 then (1+ i)
 486                                     for count across kind-matrix nconc
 487                                     (make-list count :initial-element i)))
 488                   :generator generator)
 489                  'list))
 490
 491         (t
 492          ;; use kind-matrix as ratios to sample
 493          (let* ((c (make-container 'weighted-sampling-container
 494                                    :random-number-generator generator
 495                                    :key (lambda (item)
 496                                           (aref kind-matrix item)))))
 497            (dotimes (i (array-dimension kind-matrix 0))
 498              (insert-item c i))
 499            (loop repeat size collect
 500                  (next-element c))))))
 501
 502 #+Test
 503 (sample-vertexes-for-mixed-graph
 504  *random-generator*
 505  50 #2A((0.258 0.016 0.035 0.013)
 506         (0.012 0.157 0.058 0.019)
 507         (0.013 0.023 0.306 0.035)
 508         (0.005 0.007 0.024 0.016)))
 509
 510 #+Test
 511 (sample-edges 50 #2A((0.258 0.016 0.035 0.013)
 512                      (0.012 0.157 0.058 0.019)
 513                      (0.013 0.023 0.306 0.035)
 514                      (0.005 0.007 0.024 0.016)))
 515 #+Test
 516 (let ((a #2A((0.258 0.016 0.035 0.013)
 517              (0.012 0.157 0.058 0.019)
 518              (0.013 0.023 0.306 0.035)
 519              (0.005 0.007 0.024 0.016)))
 520       (c (make-container 'weighted-sampling-container :key #'second)))
 521   (dotimes (i 4)
 522     (dotimes (j 4)
 523       (insert-item c (list (list i j) (aref a i j)))))
 524   (element-counts
 525    (loop repeat 1000 collect
 526          (next-element c))
 527    :key #'first
 528    :test #'equal))
 529
 530 #+Test
 531 (let ((a #2A((0.258 0.016 0.035 0.013)
 532              (0.012 0.157 0.058 0.019)
 533              (0.013 0.023 0.306 0.035)
 534              (0.005 0.007 0.024 0.016)))
 535       (c (make-container 'weighted-sampling-container :key #'second)))
 536   (pro:with-profiling
 537     (loop repeat 100000 do
 538           (next-element c))))
 539
 540 #+Test
 541 (defun foo (percent-bad percent-mixing)
 542   (let ((kind-matrix (make-array 2 :initial-element 0d0))
 543         (mixing-matrix (make-array (list 2 2) :initial-element 0d0)))
 544     (setf (aref kind-matrix 0) (- 1d0 percent-bad)
 545           (aref kind-matrix 1) percent-bad
 546           (aref mixing-matrix 0 0) (* (aref kind-matrix 0) (- 1d0 (/ percent-mixing 1)))
 547           (aref mixing-matrix 1 1) (* (aref kind-matrix 1) (- 1d0 (/ percent-mixing 1)))
 548           (aref mixing-matrix 1 0) percent-mixing
 549           (aref mixing-matrix 0 1) percent-mixing)
 550     (normalize-matrix kind-matrix)
 551     (setf mixing-matrix (normalize-matrix mixing-matrix))
 552     (values kind-matrix
 553             mixing-matrix)))
 554
 555
 556 ;;; ---------------------------------------------------------------------------
 557 ;;; girvan-newman-test-graphs
 558 ;;; ---------------------------------------------------------------------------
 559
 560 (defun generate-girvan-newman-graph (generator graph-class z-in)
 561   (warn "This is broken!")
 562   (bind ((g (make-instance graph-class))
 563          (group-count 4)
 564          (group-size 32)
 565          (edge-count 16)
 566          (z-out (- edge-count z-in))
 567          (vertexes (make-container 'simple-associative-container))
 568          (groups (make-container 'alist-container)))
 569     (save-generation-information g generator
 570                                  'generate-girvan-newman-graph)
 571     (labels ((make-id (group index)
 572                (form-keyword "A" group "0" index))
 573
 574              (choose-inner-id (group id)
 575                (check-type group fixnum)
 576                (check-type id symbol)
 577                (loop
 578                  (let ((other (sample-element (item-at groups group :needs-in) generator)))
 579                    (when (and #+Ignore
 580                               (not (eq id other))
 581                               #+Ignore
 582                               (not (find-edge-between-vertexes
 583                                     g id other :error-if-not-found? nil)))
 584                      (return-from choose-inner-id other)))))
 585
 586              (choose-outer-id (from-group id)
 587                (declare (ignore id))
 588
 589                (check-type from-group fixnum)
 590                (loop
 591                  (bind ((other-group (integer-random generator 0 (- group-count 2)))
 592                         (other (sample-element
 593                                 (item-at groups (if (= from-group other-group)
 594                                                   (1+ other-group)
 595                                                   other-group) :needs-out)
 596                                 generator)))
 597                    (when (and other
 598                               #+Ignore
 599                               (not (find-edge-between-vertexes
 600                                     g id other :error-if-not-found? nil)))
 601                      (return-from choose-outer-id other)))))
 602
 603              (make-in-edge (from to)
 604                (let ((group (gn-id->group from)))
 605                  (when (zerop (decf (first (item-at vertexes from))))
 606                    (setf (item-at groups group :needs-in)
 607                          (remove from (item-at groups group :needs-in))))
 608                  (when (zerop (decf (first (item-at vertexes to))))
 609                    (setf (item-at groups group :needs-in)
 610                          (remove to (item-at groups group :needs-in))))
 611                  (add-edge-between-vertexes
 612                   g from to :edge-type :undirected
 613                   :if-duplicate-do (lambda (e) (incf (weight e))))))
 614
 615              (make-out-edge (from to)
 616                (let ((group-from (gn-id->group from))
 617                      (group-to (gn-id->group to)))
 618                  (when (zerop (decf (second (item-at vertexes from))))
 619                    (setf (item-at groups group-from :needs-out)
 620                          (remove from (item-at groups group-from :needs-out))))
 621                  (when (zerop (decf (second (item-at vertexes to))))
 622                    (setf (item-at groups group-to :needs-out)
 623                          (remove to (item-at groups group-to :needs-out))))
 624
 625                  (add-edge-between-vertexes
 626                   g from to :edge-type :undirected
 627                   :if-duplicate-do (lambda (e) (incf (weight e)))))))
 628
 629       ;; vertexes
 630       (loop for group from 0 to (1- group-count) do
 631             (loop for index from 0 to (1- group-size) do
 632                   (let ((id (make-id group index)))
 633                     (setf (item-at vertexes id) (list z-in z-out))
 634                     (when (plusp z-in)
 635                       (push id (item-at groups group :needs-in)))
 636                     (when (plusp z-out)
 637                       (push id (item-at groups group :needs-out))))))
 638
 639       ;; create edges
 640       (loop for group from 0 to (1- group-count) do
 641             (loop for index from 0 to (1- group-size) do
 642                   (let ((from (make-id group index)))
 643                     (print from)
 644                     (loop while (plusp (first (item-at vertexes from))) do
 645                           (make-in-edge from (choose-inner-id group from)))
 646                     (loop while (plusp (second (item-at vertexes from))) do
 647                           (make-out-edge from (choose-outer-id group from)))))))
 648
 649   (values g)))
 650
 651 ;;; ---------------------------------------------------------------------------
 652
 653 (defun gn-id->group (id)
 654   (parse-integer (subseq (symbol-name id) 1 2)))
 655
 656 ;;; ---------------------------------------------------------------------------
 657
 658 (defun collect-edge-counts (g)
 659   (let ((vertexes (make-container 'simple-associative-container
 660                                   :initial-element-fn (lambda () (list 0 0)))))
 661     (iterate-edges
 662      g
 663      (lambda (e)
 664        (bind ((v1 (vertex-1 e))
 665               (v2 (vertex-2 e))
 666               (id1 (element v1))
 667               (id2 (element v2)))
 668          (cond ((= (gn-id->group id1) (gn-id->group (element v2)))
 669                 (incf (first (item-at vertexes id1)) (weight e))
 670                 (incf (first (item-at vertexes id2)) (weight e)))
 671                (t
 672                 (incf (second (item-at vertexes id1)) (weight e))
 673                 (incf (second (item-at vertexes id2)) (weight e)))))))
 674     (sort
 675      (collect-key-value
 676       vertexes
 677       :transform (lambda (k v) (list k (first v) (second v))))
 678      #'string-lessp
 679      :key #'first)))
 680
 681 ;;; ---------------------------------------------------------------------------
 682
 683 (defclass* weighted-sampler-with-lookup-container ()
 684   ((sampler nil r)
 685    (lookup nil r)))
 686
 687 ;;; ---------------------------------------------------------------------------
 688
 689 (defmethod initialize-instance :after ((object weighted-sampler-with-lookup-container)
 690                                        &key random-number-generator key)
 691   (setf (slot-value object 'sampler)
 692         (make-container 'weighted-sampling-container
 693                         :random-number-generator random-number-generator
 694                         :key key)
 695         (slot-value object 'lookup)
 696         (make-container 'simple-associative-container)))
 697
 698 ;;; ---------------------------------------------------------------------------
 699
 700 (defmethod insert-item ((container weighted-sampler-with-lookup-container)
 701                         (item t))
 702   (let ((node (nth-value 1 (insert-item (sampler container) item))))
 703     ;;?? remove
 704     (assert (not (null node)))
 705     (setf (item-at-1 (lookup container) item) node)))
 706
 707 ;;; ---------------------------------------------------------------------------
 708
 709 (defmethod find-node ((container weighted-sampler-with-lookup-container)
 710                       (item t))
 711   (item-at-1 (lookup container) item))
 712
 713 ;;; ---------------------------------------------------------------------------
 714
 715 (defmethod delete-node ((container weighted-sampler-with-lookup-container)
 716                         (node t))
 717   ;; not going to worry about the hash table
 718   (delete-node (sampler container) node))
 719
 720 ;;; ---------------------------------------------------------------------------
 721
 722 (defmethod next-element ((container weighted-sampler-with-lookup-container))
 723   (next-element (sampler container)))
 724
 725 ;;; ---------------------------------------------------------------------------
 726
 727 (defmethod generate-scale-free-graph
 728            (generator graph size kind-matrix add-edge-count
 729                       other-vertex-kind-samplers
 730                       vertex-creator
 731                       &key (duplicate-edge-function 'identity))
 732   (let* ((kind-count (array-dimension kind-matrix 0))
 733          (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
 734          (vertex-sampler (make-array kind-count)))
 735     (save-generation-information graph generator 'generate-scale-free-graph)
 736     (flet ((sample-existing-vertexes (for-kind)
 737              ;; return list of vertexes to attach based on preferential attachment
 738              (loop for other-kind in (funcall (nth for-kind other-vertex-kind-samplers)
 739                                               add-edge-count generator) collect
 740                    (let ((vertex (next-element (aref vertex-sampler other-kind))))
 741                      (unless vertex
 742                        (loop for i from 0
 743                              for nil across vertex-sampler
 744                              until vertex do
 745                              (setf vertex (next-element (aref vertex-sampler i))
 746                                    other-kind i)))
 747
 748                      ;;?? remove. this should never happen
 749                      (unless vertex (break))
 750
 751                      (list vertex other-kind))))
 752            (update (kind thing)
 753              ;; handle bookkeeping for changed vertex degree
 754              (bind ((sampler (aref vertex-sampler kind))
 755                     (node (find-node sampler thing)))
 756                (delete-node sampler node)
 757                (insert-item sampler thing))))
 758
 759       ;; set up samplers
 760       (loop for i from 0
 761             for nil across vertex-sampler do
 762             (setf (aref vertex-sampler i)
 763                   (make-container 'weighted-sampler-with-lookup-container
 764                                   :random-number-generator generator
 765                                   :key (lambda (vertex)
 766                                          (1+ (vertex-degree vertex))))))
 767
 768       ;; add vertexes and edges
 769       (loop for kind in (shuffle-elements! vertex-kinds :generator generator)
 770             for i from 0 do
 771             (let* ((element (funcall vertex-creator kind i))
 772                    (vertex (add-vertex graph element)))
 773               (when (> i add-edge-count)
 774                 (loop for (other other-kind) in (sample-existing-vertexes kind) do
 775                       (update other-kind other)
 776                       ;;?? remove
 777                       (if (or (null kind) (null other)) (break))
 778                       (add-edge-between-vertexes
 779                        graph vertex other
 780                        :if-duplicate-do
 781                        (lambda (e) (funcall duplicate-edge-function e)))))
 782               (insert-item (aref vertex-sampler kind) vertex)))
 783
 784       graph)))
 785
 786 ;;; ---------------------------------------------------------------------------
 787
 788 #+Test
 789 (defun poisson-connector (count generator)
 790   (let* ((ts (poisson-random generator 2))
 791          (cs (poisson-random generator 2))
 792          (rest (- count ts cs)))
 793     (loop for tick = t then (not tick) while (minusp rest) do
 794           (incf rest)
 795           (if tick (decf ts) (decf cs)))
 796     (shuffle-elements!
 797      (append (make-list (truncate rest) :initial-element 0)
 798              (make-list (truncate ts) :initial-element 1)
 799              (make-list (truncate cs) :initial-element 2))
 800      :generator generator)))
 801
 802 #+Test
 803 (setf (ds :g-1100)
 804       (generate-scale-free-graph
 805        *random-generator*
 806        (make-container 'graph-container :default-edge-type :undirected)
 807        1100
 808        #(1000 50 50)
 809        10
 810        (list
 811         (lambda (count generator)
 812           (declare (ignore generator))
 813           (make-list count :initial-element 0))
 814         #'poisson-connector
 815         #'poisson-connector)
 816        (lambda (kind count)
 817          (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
 818
 819 #+Test
 820 (pro:with-profiling
 821   (generate-scale-free-graph
 822    *random-generator*
 823    (make-container 'graph-container :default-edge-type :undirected)
 824    10000
 825    #(1.0)
 826    10
 827    (list
 828     (lambda (count generator)
 829       (declare (ignore generator))
 830       (make-list count :initial-element 0)))
 831    (lambda (kind count)
 832      (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
 833
 834 #|
 835 (pro:with-profiling
 836   (generate-scale-free-graph
 837    *random-generator*
 838    (make-container 'graph-container :default-edge-type :undirected)
 839    1000
 840    #(1.0)
 841    3
 842    (list
 843     (lambda (count generator)
 844       (declare (ignore generator))
 845       (make-list count :initial-element 0)))
 846    (lambda (kind count)
 847      (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
 848
 849
 850 ;;; 61.4640 cpu seconds (61.4640 cpu seconds ignoring GC)
 851 ;;; 102,959,032 words consed
 852 Execution time profile from 2078 samples
 853   Parents
 854 Function
 855   Children                                   Relative  Absolute Consing       Conses
 856 ----
 857 %%check-keywords                                            99%     99%  100,970,656
 858   sample-existing-vertexes                       62%
 859   insert-item <weighted-sampler-with-lookup-container> <t>  32%
 860   add-vertex <basic-graph> <t>                    2%
 861   update                                          1%
 862   add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex>   1%
 863   form-keyword                                    1%
 864   iterate-container <contents-as-array-mixin> <t>   1%
 865 ----
 866   %%check-keywords                              100%
 867 sample-existing-vertexes                                    62%     61%   62,577,336
 868   walk-tree-nodes <bst-node> <t>                 99%
 869   uniform-random                                  1%
 870 ----
 871   sample-existing-vertexes                      100%
 872 walk-tree-nodes <bst-node> <t>                              61%     60%   61,607,072
 873   #<anonymous function #xaa2070e>                77%
 874   +-2                                             3%
 875   element-weight <weighted-sampling-container> <t>   2%
 876   >=-2                                            2%
 877   %double-float+-2!                               1%
 878   %%one-arg-dcode                                 1%
 879 ----
 880   walk-tree-nodes <bst-node> <t>                 98%
 881   %%before-and-after-combined-method-dcode        2%
 882 #<anonymous function #xaa2070e>                             48%     47%   48,156,256
 883   iterate-container <contents-as-array-mixin> <t>  73%
 884   %%1st-two-arg-dcode                             9%
 885   iterate-edges <graph-container-vertex> <t>      6%
 886   constantly                                      4%
 887   iterate-elements <abstract-container> <t>       2%
 888 ----
 889   #<anonymous function #xaa2070e>                99%
 890   %vertex-degree                                  1%
 891 iterate-container <contents-as-array-mixin> <t>             35%     35%   35,440,856
 892   other-vertex <graph-container-edge> <graph-container-vertex>  43%
 893   %%nth-arg-dcode                                20%
 894   #<anonymous function #x271d31e>                10%
 895 ----
 896   insert-item <weighted-sampler-with-lookup-container> <t>  92%
 897   %make-std-instance                              3%
 898   update                                          3%
 899   %%standard-combined-method-dcode                1%
 900   %call-next-method                               1%
 901 %%before-and-after-combined-method-dcode                    34%     34%   34,400,720
 902   insert-item <binary-search-tree> <bst-node>    90%
 903   #<anonymous function #xaa2070e>                 2%
 904   shared-initialize <standard-object> <t>         2%
 905   %%one-arg-dcode                                 1%
 906   %double-float+-2!                               1%
 907   +-2                                             1%
 908 ----
 909   %%check-keywords                              100%
 910 insert-item <weighted-sampler-with-lookup-container> <t>    31%     31%   31,970,488
 911   %%before-and-after-combined-method-dcode      100%
 912 ----
 913   %%before-and-after-combined-method-dcode      100%
 914 insert-item <binary-search-tree> <bst-node>                 30%     31%   31,227,120
 915   %vertex-degree                                 84%
 916   vertex-degree                                   5%
 917 ----
 918   insert-item <binary-search-tree> <bst-node>    99%
 919   #<anonymous function #xaa2070e>                 1%
 920 %vertex-degree                                              26%     25%   25,870,312
 921   #<anonymous function #xa7cee86>                68%
 922   %aref1                                          3%
 923   %std-slot-value-using-class                     1%
 924   slot-id-value                                   1%
 925   %%one-arg-dcode                                 1%
 926   iterate-container <contents-as-array-mixin> <t>   1%
 927 ----
 928   %vertex-degree                                 99%
 929   iterate-container <contents-as-array-mixin> <t>   1%
 930 #<anonymous function #xa7cee86>                             18%     17%   17,420,592
 931   %maybe-std-slot-value-using-class               8%
 932   %%one-arg-dcode                                 8%
 933   %std-slot-value-using-class                     8%
 934   slot-id-value                                   5%
 935   vertex-1 <graph-container-edge>                 5%
 936   #<anonymous function #x271d31e>                 1%
 937 ----
 938   iterate-container <contents-as-array-mixin> <t>  99%
 939   #<anonymous function #xa7cee86>                 1%
 940 other-vertex <graph-container-edge> <graph-container-vertex>   15%     14%   14,029,496
 941   %%one-arg-dcode                                 1%
 942 ----
 943   iterate-container <contents-as-array-mixin> <t>  95%
 944   %%check-keywords                                3%
 945   %%before-and-after-combined-method-dcode        1%
 946   initialize-instance (around) <basic-initial-contents-mixin>   1%
 947 %%nth-arg-dcode                                              7%      9%    9,238,560
 948 ----
 949   #<anonymous function #xaa2070e>                93%
 950   walk-tree-nodes <bst-node> <t>                  5%
 951   %%before-and-after-combined-method-dcode        2%
 952 %%1st-two-arg-dcode                                          5%      5%    4,802,264
 953 ----
 954   iterate-container <contents-as-array-mixin> <t>  96%
 955   #<anonymous function #xa7cee86>                 3%
 956   shared-initialize <standard-object> <t>         1%
 957 #<anonymous function #x271d31e>                              4%      4%    4,012,368
 958 ----
 959   #<anonymous function #xaa2070e>               100%
 960 iterate-edges <graph-container-vertex> <t>                   3%      3%    2,918,352
 961 ----
 962   #<anonymous function #xa7cee86>                59%
 963   %vertex-degree                                 14%
 964   walk-tree-nodes <bst-node> <t>                 13%
 965   shared-initialize <standard-object> <t>         6%
 966   %shared-initialize                              4%
 967   other-vertex <graph-container-edge> <graph-container-vertex>   2%
 968   member                                          2%
 969 %std-slot-value-using-class                                  2%      2%    2,115,320
 970 ----
 971   #<anonymous function #xa7cee86>                59%
 972   walk-tree-nodes <bst-node> <t>                 12%
 973   %vertex-degree                                  9%
 974   %%before-and-after-combined-method-dcode        6%
 975   shared-initialize <standard-object> <t>         4%
 976   update                                          4%
 977   other-vertex <graph-container-edge> <graph-container-vertex>   4%
 978   %shared-initialize                              2%
 979 %%one-arg-dcode                                              2%      2%    2,478,304
 980 ----
 981   make-instance <symbol>                         68%
 982   %make-instance                                 23%
 983   make-instance <standard-class>                  9%
 984 %make-std-instance                                           2%      2%    2,283,344
 985   %%before-and-after-combined-method-dcode       47%
 986   shared-initialize <standard-object> <t>        15%
 987   %%standard-combined-method-dcode               12%
 988   %maybe-std-slot-value-using-class               3%
 989 ----
 990   #<anonymous function #xa7cee86>                78%
 991   %vertex-degree                                  7%
 992   uniform-random                                  5%
 993   %make-std-instance                              2%
 994   shared-initialize <standard-object> <t>         3%
 995   view-get <simple-view> <t>                      2%
 996   walk-tree-nodes <bst-node> <t>                  3%
 997 %maybe-std-slot-value-using-class                            2%      2%    2,005,048
 998 ----
 999   add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex>  42%
1000   add-vertex <basic-graph> <t>                   40%
1001   initialize-instance (after) <graph-container-vertex>   7%
1002   add-it                                          6%
1003   %%before-and-after-combined-method-dcode        5%
1004 make-instance <symbol>                                       2%      2%    1,932,504
1005   %make-std-instance                             92%
1006 ----
1007   #<anonymous function #xaa2070e>               100%
1008 constantly                                                   2%      2%    1,629,880
1009 ----
1010   walk-tree-nodes <bst-node> <t>                 97%
1011   %%before-and-after-combined-method-dcode        3%
1012 +-2                                                          2%      2%    1,688,392
1013   %maybe-std-slot-value-using-class               3%
1014 ----
1015   %%check-keywords                              100%
1016 add-vertex <basic-graph> <t>                                 2%      2%    2,259,304
1017   make-instance <symbol>                         44%
1018   %%standard-combined-method-dcode               30%
1019   %%before-and-after-combined-method-dcode        8%
1020   %make-std-instance                              3%
1021 ----
1022 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t>        2%      2%    1,700,920
1023   %%standard-combined-method-dcode               48%
1024   %%check-keywords                               16%
1025   uniform-random                                 15%
1026   make-instance <symbol>                          6%
1027 ----
1028   generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t>  45%
1029   add-vertex <basic-graph> <t>                   25%
1030   %make-std-instance                             18%
1031   make-instance <standard-class>                  6%
1032   add-it                                          3%
1033   insert-item <weighted-sampler-with-lookup-container> <t>   3%
1034 %%standard-combined-method-dcode                             2%      2%    2,019,832
1035   insert-item <container-uses-nodes-mixin> <t>   45%
1036   %%before-and-after-combined-method-dcode       25%
1037   %%nth-arg-dcode                                 3%
1038   make-instance <symbol>                          3%
1039 ----
1040 #<GRAPH-CONTAINER 1000>
1041 ? 2
1042 2
1043 ?
1044
1045 (open-plot-in-window
1046  (histogram
1047   (collect-elements
1048    (clnuplot::data->n-buckets
1049     (sort (collect-items x :transform #'vertex-degree) #'>)
1050     20
1051     #'identity)
1052    :filter
1053    (lambda (x)
1054      (and (plusp (first x))
1055           (plusp (second x ))))
1056    :transform
1057    (lambda (x)
1058      (list (log (first x) 10) (log (second x)))))))
1059
1060
1061
1062 (clasp:linear-regression-brief
1063  (mapcar #'first
1064          '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1065           (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1066           (3.2961164921697144 1.6094379124341003)
1067           (3.3831867994748994 1.9459101490553132)
1068           (3.4556821645007902 0.6931471805599453)
1069           (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1070           (3.932600584500482 0.0))
1071          )
1072  (mapcar #'second
1073          '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1074           (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1075           (3.2961164921697144 1.6094379124341003)
1076           (3.3831867994748994 1.9459101490553132)
1077           (3.4556821645007902 0.6931471805599453)
1078           (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1079           (3.932600584500482 0.0))
1080          ))
1081
1082 |#
1083
1084 ;;; ---------------------------------------------------------------------------
1085 ;;; generate-assortative-graph-with-degree-distributions
1086 ;;; ---------------------------------------------------------------------------
1087
1088 #+Ignore
1089 (define-debugging-class generate-assortative-graph-with-degree-distributions ())
1090
1091 ;;; ---------------------------------------------------------------------------
1092
1093 (defmethod generate-assortative-graph-with-degree-distributions
1094            (generator (graph-class symbol)
1095                       edge-count assortativity-matrix
1096                       average-degrees
1097                       degree-distributions
1098                       vertex-creator
1099                       &key (duplicate-edge-function 'identity))
1100   (generate-assortative-graph-with-degree-distributions
1101    generator (make-instance graph-class)
1102    edge-count assortativity-matrix
1103    average-degrees
1104    degree-distributions
1105    vertex-creator
1106    :duplicate-edge-function duplicate-edge-function))
1107
1108 #|
1109 Split into a function to compute some of the intermediate pieces and one to use them
1110 |#
1111
1112 (defmethod generate-assortative-graph-with-degree-distributions
1113            (generator graph edge-count assortativity-matrix
1114                       average-degrees
1115                       degree-distributions
1116                       vertex-creator
1117                       &key (duplicate-edge-function 'identity))
1118   (setf assortativity-matrix (normalize-matrix assortativity-matrix))
1119   (let* ((kind-count (array-dimension assortativity-matrix 0))
1120          (vertex->degree-counts (make-array kind-count))
1121          (edges (copy-tree
1122                  (sample-edges-for-assortative-graph
1123                   generator edge-count assortativity-matrix)))
1124          (degree-sums (sort
1125                        (merge-elements
1126                         (append (element-counts edges :key #'first)
1127                                 (element-counts edges :key #'second))
1128                         (lambda (old new)
1129                           (+ old new))
1130                         (lambda (new)
1131                           new) :key #'first :argument #'second)
1132                        #'<
1133                        :key #'first))
1134          (vertex-counts (collect-elements
1135                          degree-sums
1136                          :transform
1137                          (lambda (kind-and-count)
1138                            (round (float (/ (second kind-and-count)
1139                                             (elt average-degrees (first kind-and-count))))))))
1140          (edge-samplers (make-array kind-count)))
1141     (save-generation-information graph generator 'generate-assortative-graph-with-degree-distributions)
1142
1143     ;; setup bookkeeping
1144     (loop for kind from 0 to (1- kind-count) do
1145           (setf (aref edge-samplers kind)
1146                 (make-container 'vector-container)
1147                 (aref vertex->degree-counts kind)
1148                 (make-container 'simple-associative-container)))
1149     (loop for edge in edges do
1150           (insert-item (aref edge-samplers (first edge)) (cons :source edge))
1151           (insert-item (aref edge-samplers (second edge)) (cons :target edge)))
1152     (iterate-elements
1153      edge-samplers (lambda (sampler) (shuffle-elements! sampler :generator generator)))
1154
1155     ;(spy edges degree-sums vertex-counts)
1156
1157     (loop for kind from 0 to (1- kind-count)
1158           for count in vertex-counts do
1159           (let ((distribution (nth-element degree-distributions kind))
1160                 (vertexes (make-container 'vector-container))
1161                 (vertex-degrees (aref vertex->degree-counts kind))
1162                 (total-degree 0)
1163                 (desired-sum (second (elt degree-sums kind))))
1164
1165             ;; for each type, create vertexes
1166             (loop for i from 0 to (1- count) do
1167                   (let ((vertex (funcall vertex-creator kind i))
1168                         (degree (funcall distribution)))
1169                     (insert-item vertexes vertex)
1170                     (setf (item-at-1 vertex-degrees vertex)
1171                           degree)
1172                     (incf total-degree degree)))
1173
1174             ;(spy vertexes total-degree desired-sum)
1175
1176             ;; ensure proper total degree
1177             (loop while (/= total-degree desired-sum) do
1178                   #+Ignore
1179                   (when-debugging-format
1180                    generate-assortative-graph-with-degree-distributions
1181                    "Current: ~D, Desired: ~D, Difference: ~D"
1182                    total-degree desired-sum
1183                    (abs (- total-degree desired-sum)))
1184                   (let* ((vertex (sample-element vertexes generator))
1185                          (bigger? (< total-degree desired-sum))
1186                          (current-degree (item-at-1 vertex-degrees vertex))
1187                          (new-degree 0)
1188                          (attempts 100))
1189                     (when (or bigger?
1190                               (and (not bigger?)
1191                                    (plusp current-degree)))
1192                       (decf total-degree current-degree)
1193
1194                       #+Ignore
1195                       (when-debugging-format
1196                        generate-assortative-graph-with-degree-distributions
1197                        "  ~D ~D ~:[^~]"
1198                        total-degree current-degree new-degree (not bigger?))
1199
1200                       ;; increase speed by knowing which direction we need to go...?
1201                       (loop until (or (zerop (decf attempts))
1202                                       (and bigger?
1203                                            (> (setf new-degree (funcall distribution))
1204                                               current-degree))
1205                                       (and (not bigger?)
1206                                            (< (setf new-degree (funcall distribution))
1207                                               current-degree))) do
1208
1209                             (setf bigger? (< (+ total-degree new-degree) desired-sum)))
1210
1211                       (cond ((plusp attempts)
1212                              #+Ignore
1213                              (when-debugging
1214                                generate-assortative-graph-with-degree-distributions
1215                                (format *debug-io* " -> ~D" new-degree))
1216
1217                              (setf (item-at-1 vertex-degrees vertex) new-degree)
1218                              (incf total-degree new-degree)
1219
1220                              #+Ignore
1221                              (when-debugging-format
1222                               generate-assortative-graph-with-degree-distributions
1223                               "~D ~D" total-degree desired-sum))
1224                             (t
1225                              ;; couldn't find one, try again
1226                              (incf total-degree current-degree))))))
1227
1228             ;; attach edges
1229             (let ((edge-sampler (aref edge-samplers kind)))
1230               (flet ((sample-edges-for-vertex (vertex)
1231                        ;(spy vertex)
1232                        (loop repeat (item-at-1 vertex-degrees vertex) do
1233                              (bind (((edge-kind . edge) (delete-last edge-sampler)))
1234                                (ecase edge-kind
1235                                  (:source (setf (first edge) vertex))
1236                                  (:target (setf (second edge) vertex)))))))
1237                 (iterate-elements
1238                  vertexes
1239                  #'sample-edges-for-vertex)))))
1240
1241     ;; repair self edges
1242
1243
1244     ;; now make the graph [at last]
1245     (iterate-elements
1246      edges
1247      (lambda (edge)
1248        (add-edge-between-vertexes graph (first edge) (second edge)
1249                                   :if-duplicate-do duplicate-edge-function))))
1250
1251   graph)
1252
1253 #+Test
1254 (generate-assortative-graph-with-degree-distributions
1255  *random-generator*
1256  'graph-container
1257  100
1258  #2A((0.1111111111111111 0.2222222222222222)
1259     (0.2222222222222222 0.4444444444444444))
1260  #+No
1261  #2A((0.011840772766222637 0.04524421593830334)
1262      (0.04524421593830334 0.8976707953571706))
1263  '(3 3)
1264  (list
1265   (make-degree-sampler
1266    (lambda (i)
1267      (poisson-vertex-degree-distribution 3 i))
1268    :generator *random-generator*)
1269   (make-degree-sampler
1270    (lambda (i)
1271      (poisson-vertex-degree-distribution 3 i))
1272    :generator *random-generator*))
1273
1274  (lambda (kind count)
1275    (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count))))
1276
1277 #+Test
1278 (element-counts
1279  (copy-tree
1280   (sample-edges-for-assortative-graph
1281    *random-generator*
1282    100
1283    #2A((0.1111111111111111 0.2222222222222222)
1284        (0.2222222222222222 0.4444444444444444))))
1285  :test #'eq)
1286
1287 ;;; ---------------------------------------------------------------------------
1288 ;;; generate-graph-by-resampling-edges
1289 ;;; ---------------------------------------------------------------------------
1290
1291 #|
1292 doesn't take edge weights into account when sampling
1293
1294 should include pointer back to original graph
1295 |#
1296
1297 (defclass* basic-edge-sampler ()
1298   ((generator nil ir)
1299    (graph nil ir)))
1300
1301 ;;; ---------------------------------------------------------------------------
1302
1303 (defmethod next-element ((sampler basic-edge-sampler))
1304   (sample-element (graph-edges (graph sampler)) (generator sampler)))
1305
1306 ;;; ---------------------------------------------------------------------------
1307
1308 (defclass* weighted-edge-sampler (basic-edge-sampler)
1309   ((weight-so-far 0 a)
1310    (index-iterator nil r)
1311    (edge-iterator nil r)
1312    (size nil ir)))
1313
1314 ;;; ---------------------------------------------------------------------------
1315
1316 (defmethod initialize-instance :after ((object weighted-edge-sampler) &key)
1317   (bind ((generator (generator object))
1318          (weighted-edge-count
1319           (let ((result 0))
1320             (iterate-edges (graph object) (lambda (e) (incf result (weight e))))
1321             result)))
1322     (unless (size object)
1323       (setf (slot-value object 'size) weighted-edge-count))
1324     (setf (slot-value object 'index-iterator)
1325           (make-iterator
1326            (sort (loop repeat (size object) collect
1327                        (integer-random generator 1 weighted-edge-count)) #'<))
1328           (slot-value object 'edge-iterator)
1329           (make-iterator (graph-edges (graph object))))))
1330
1331 ;;; ---------------------------------------------------------------------------
1332
1333 (defmethod next-element ((object weighted-edge-sampler))
1334   (let ((edge-iterator (edge-iterator object))
1335         (index-iterator (index-iterator object)))
1336     (move-forward index-iterator)
1337     (loop while (< (weight-so-far object) (current-element index-iterator)) do
1338           (move-forward edge-iterator)
1339           (incf (weight-so-far object) (weight (current-element edge-iterator))))
1340     (current-element edge-iterator)))
1341
1342 ;;; ---------------------------------------------------------------------------
1343
1344 (defmethod generate-graph-by-resampling-edges
1345            (generator original-graph &key
1346                       (edge-sampler-class 'basic-edge-sampler)
1347                       (edge-count (edge-count original-graph)))
1348   (let ((graph (copy-template original-graph))
1349         (edge-sampler (make-instance edge-sampler-class
1350                         :generator generator
1351                         :graph original-graph
1352                         :size edge-count)))
1353     (save-generation-information graph generator 'generate-graph-by-resampling-edges)
1354
1355     ;; vertexes
1356     (iterate-vertexes
1357      original-graph
1358      (lambda (v)
1359        (add-vertex graph (element v))))
1360
1361     ;; sample edges
1362     (loop repeat edge-count do
1363           (let ((edge (next-element edge-sampler)))
1364             (if (directed-edge-p edge)
1365               (add-edge-between-vertexes
1366                graph (element (source-vertex edge)) (element (target-vertex edge))
1367                :edge-type :directed
1368                :if-duplicate-do (lambda (e) (incf (weight e))))
1369               (add-edge-between-vertexes
1370                graph (element (vertex-1 edge)) (element (vertex-2 edge))
1371                :edge-type :undirected
1372                :if-duplicate-do (lambda (e) (incf (weight e)))))))
1373
1374     graph))
1375
1376 #+Test
1377 (fluid-bind (((random-seed *random-generator*) 1))
1378   (let* ((dd-1 (lambda (i)
1379                  #+Ignore
1380                  (power-law-vertex-degree-distribution 3 i)
1381                  (poisson-vertex-degree-distribution 3 i)))
1382          (dd-2 (lambda (i)
1383                  #+Ignore
1384                  (power-law-vertex-degree-distribution 3 i)
1385                  (poisson-vertex-degree-distribution 3 i)))
1386          (g (generate-assortative-graph-with-degree-distributions
1387              *random-generator*
1388              (make-instance 'graph-container
1389                :default-edge-type :undirected
1390                :undirected-edge-class 'weighted-edge)
1391              100
1392              #2A((0.011840772766222637 0.04524421593830334)
1393                  (0.04524421593830334 0.8976707953571706))
1394              '(3 3)
1395              (list
1396               (make-degree-sampler
1397                dd-1
1398                :generator *random-generator*
1399                :max-degree 40
1400                :min-probability nil)
1401               (make-degree-sampler
1402                dd-2
1403                :generator *random-generator*
1404                :max-degree 40
1405                :min-probability nil))
1406              #'simple-group-id-generator
1407              :duplicate-edge-function (lambda (e) (incf (weight e))))))
1408     (flet ((avd (g)
1409              (average-vertex-degree
1410               g
1411               :vertex-filter (lambda (v)
1412                                (plusp (edge-count v)))
1413               :edge-size #'weight)))
1414       (print (avd g))
1415       (loop for i from 1 to 10
1416             do
1417             (fluid-bind (((random-seed *random-generator*) i))
1418               (print (avd
1419                       (generate-graph-by-resampling-edges
1420                        *random-generator* g 'weighted-edge-sampler (edge-count g)))))))))
1421
1422 ;;; ---------------------------------------------------------------------------
1423 ;;; some preferential attachment algorithms
1424 ;;; ---------------------------------------------------------------------------
1425
1426 #+Ignore
1427 (define-debugging-class generate-preferential-attachment-graph
1428   (graph-generation))
1429
1430 ;;; ---------------------------------------------------------------------------
1431
1432 (defmethod generate-simple-preferential-attachment-graph
1433            (generator (graph-class symbol) size minimum-degree)
1434   (generate-simple-preferential-attachment-graph
1435    generator (make-instance graph-class) size minimum-degree))
1436
1437 ;;; ---------------------------------------------------------------------------
1438
1439 (defmethod generate-simple-preferential-attachment-graph
1440            (generator graph size minimum-degree)
1441   (bind ((m (make-array (list (* 2 size minimum-degree)))))
1442     (loop for v from 0 to (1- size) do
1443           (loop for i from 0 to (1- minimum-degree) do
1444                 (bind ((index (* 2 (+ i (* v minimum-degree))))
1445                        (r (integer-random generator 0 index)))
1446                   (setf (item-at m index) v
1447                         (item-at m (1+ index)) (item-at m r)))))
1448     (loop for i from 0 to (1- (* size minimum-degree)) do
1449           (add-edge-between-vertexes
1450            graph (item-at m (* 2 i)) (item-at m (1+ (* 2 i)))))
1451     graph))
1452
1453 #+Test
1454 (setf (ds :g-b)
1455       (generate-simple-preferential-attachment-graph
1456        *random-generator*
1457        (make-container 'graph-container :default-edge-type :undirected)
1458        10000
1459        10))
1460
1461 #+Test
1462 (element-counts
1463    (collect-nodes (ds :g-b)
1464                   :transform (lambda (v) (list (element v) (vertex-degree v))))
1465    :key #'second
1466    :sort #'>
1467    :sort-on :values)
1468
1469 ;;; ---------------------------------------------------------------------------
1470
1471 (defmethod generate-preferential-attachment-graph
1472            (generator (graph-class symbol) size kind-matrix minimum-degree
1473                       assortativity-matrix
1474                       &key (vertex-labeler 'simple-group-id-generator)
1475                       (duplicate-edge-function :ignore))
1476   (generate-preferential-attachment-graph
1477    generator (make-instance graph-class)
1478    size kind-matrix minimum-degree assortativity-matrix
1479    :vertex-labeler vertex-labeler
1480    :duplicate-edge-function duplicate-edge-function))
1481
1482 ;;; ---------------------------------------------------------------------------
1483
1484 (defmethod generate-preferential-attachment-graph
1485            (generator (graph basic-graph) size kind-matrix minimum-degree
1486                       assortativity-matrix
1487                       &key (vertex-labeler 'simple-group-id-generator)
1488                       (duplicate-edge-function :ignore))
1489   (bind ((kind-count (array-dimension kind-matrix 0))
1490          (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
1491          (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
1492          (edge-recorders (make-array (list kind-count)))
1493          (count-recorders (make-array (list kind-count) :initial-element 0))
1494          (edge-samplers (make-array (list kind-count))))
1495
1496     ;; set up record keeping
1497     (dotimes (i kind-count)
1498       (setf (aref edge-recorders i)
1499             (make-array (list (* 2 (item-at vertex-kind-counts i) minimum-degree))
1500                         :initial-element nil))
1501       (setf (aref edge-samplers i)
1502             (make-edge-sampler-for-preferential-attachment-graph
1503              generator (array-row assortativity-matrix i))))
1504
1505     ;; add vertexes (to ensure that we have something at which to point)
1506     (loop for v from 0 to (1- size)
1507           for kind in vertex-kinds do
1508           (bind ((edge-recorder (aref edge-recorders kind)))
1509             (loop for i from 0 to (1- minimum-degree) do
1510                   (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
1511                     (setf (item-at edge-recorder index)
1512                           (funcall vertex-labeler kind v)))))
1513           (incf (aref count-recorders kind)))
1514
1515     ;; determine edges
1516     (dotimes (i kind-count)
1517       (setf (aref count-recorders i) 0))
1518     (loop for v from 0 to (1- size)
1519           for kind in vertex-kinds do
1520           (bind ((edge-recorder (aref edge-recorders kind))
1521                  (edge-sampler (aref edge-samplers kind)))
1522             (loop for i from 0 to (1- minimum-degree) do
1523                   (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
1524                          (other-kind (funcall edge-sampler))
1525                          (other-index (* 2 (+ i (* (min (1- (item-at vertex-kind-counts other-kind))
1526                                                         (aref count-recorders other-kind))
1527                                                    minimum-degree))))
1528                          (other-edge-recorder (aref edge-recorders other-kind))
1529                          (r (integer-random generator 0 (1- other-index))))
1530                     #+Ignore
1531                     (when-debugging-format
1532                      generate-preferential-attachment-graph
1533                      "[~2D ~6D] [~2D ~6D] (max: ~6D)"
1534                      kind (1+ index) other-kind r other-index)
1535                     (setf (item-at edge-recorder (1+ index))
1536                           (cond ((item-at other-edge-recorder r)
1537                                  (item-at other-edge-recorder r))
1538                                 ((and (= kind other-kind)
1539                                       (= (1+ index) r))
1540                                  ;; it's me!
1541                                  (item-at edge-recorder index))
1542                                 (t
1543                                  ;; haven't done the other one yet... save it for later fixing
1544                                  (list other-kind r))))))
1545             (incf (aref count-recorders kind))))
1546
1547     ;; record fixups
1548     (let ((corrections 0)
1549           (last-corrections nil)
1550           (again? t))
1551       (loop while again? do
1552             (setf corrections 0
1553                   again? nil)
1554             (dotimes (kind kind-count)
1555               (loop for vertex across (aref edge-recorders kind)
1556                     for index = 0 then (1+ index)
1557                     when (consp vertex) do
1558                     (bind (((other-kind other-index) vertex))
1559                       #+Ignore
1560                       (when-debugging-format
1561                        generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A"
1562                        kind index vertex
1563                        (aref (aref edge-recorders other-kind) other-index))
1564                       (incf corrections)
1565                       (if (and (= kind other-kind) (= index other-index))
1566                         ;; pointing at myself
1567                         (setf (aref (aref edge-recorders kind) index)
1568                               (aref (aref edge-recorders kind) (1- index)))
1569                         (let ((new (aref (aref edge-recorders other-kind) other-index)))
1570                           (when (consp new)
1571                             (setf again? t))
1572                           (setf (aref (aref edge-recorders kind) index) new))))))
1573             (when (and last-corrections
1574                        (>= corrections last-corrections))
1575               (error "It's not getting any better old boy"))
1576             (setf last-corrections corrections)))
1577
1578     ;; make sure we got 'em all
1579     (dotimes (i kind-count)
1580       (loop for vertex across (aref edge-recorders i)
1581             when (not (symbolp vertex)) do (error "bad function, down boy")))
1582
1583     (dotimes (i kind-count)
1584       (let ((edge-recorder (aref edge-recorders i)))
1585         (loop for index from 0 to (1- (size edge-recorder)) by 2 do
1586               (add-edge-between-vertexes
1587                graph (item-at edge-recorder index) (item-at edge-recorder (1+ index))
1588                :if-duplicate-do duplicate-edge-function))))
1589
1590     #|
1591 ;; record properties
1592     (record-graph-properties graph)
1593     (setf (get-value graph :initial-seed) (random-seed generator))
1594     (setf (get-value graph :size) size
1595           (get-value graph :minimum-degree) minimum-degree
1596           (get-value graph :assortativity-matrix) assortativity-matrix
1597           (get-value graph :duplicate-edge-function) duplicate-edge-function)
1598 |#
1599
1600     graph))
1601
1602 ;;; ---------------------------------------------------------------------------
1603
1604 (defun make-edge-sampler-for-preferential-attachment-graph (generator assortativities)
1605   (let ((c (make-container 'weighted-sampling-container
1606                            :random-number-generator generator
1607                            :key (lambda (item)
1608                                   (aref assortativities item)))))
1609     (dotimes (i (array-dimension assortativities 0))
1610       (insert-item c i))
1611     (lambda () (next-element c))))
1612
1613
1614 #+Test
1615 (let ((s
1616        (make-edge-sampler-for-preferential-attachment-graph
1617         *random-generator* #(0.02 0.25 0.25))))
1618   (loop repeat 100 collect (funcall s)))
1619
1620 #+Test
1621 (progn
1622   (setf (random-seed *random-generator*) 2)
1623   (generate-preferential-attachment-graph
1624    *random-generator*
1625    (make-graph 'graph-container :edge-type :undirected)
1626    100
1627    #(90 5 5)
1628    3
1629    #2A((0.96 0.02 0.02)
1630        (0.02 0.25 0.25)
1631        (0.02 0.25 0.25))))
1632
1633 #+Test
1634 (generate-preferential-attachment-graph
1635  *random-generator*
1636  (make-graph 'graph-container :edge-type :undirected)
1637  1100
1638  #(1000 50 50)
1639  3
1640  #2A((0.96 0.02 0.02)
1641      (0.02 0.25 0.25)
1642      (0.02 0.25 0.25)))
1643
1644 #+Test
1645 (pro:with-profiling
1646   (generate-preferential-attachment-graph
1647    *random-generator*
1648    (make-graph 'graph-container :edge-type :undirected)
1649    11000
1650    #(10000 500 500)
1651    3
1652    #2A((0.96 0.02 0.02)
1653        (0.02 0.25 0.25)
1654        (0.02 0.25 0.25))))
1655
1656 ;;; ---------------------------------------------------------------------------
1657
1658
1659 (defmethod generate-acquaintance-network
1660     (generator (class-name symbol) size death-probability iterations vertex-labeler
1661      &key (duplicate-edge-function :ignore))
1662   (generate-acquaintance-network
1663          generator (make-instance class-name)
1664          size death-probability iterations vertex-labeler
1665          :duplicate-edge-function duplicate-edge-function))
1666
1667 (defmethod generate-acquaintance-network
1668            (generator graph size death-probability iterations vertex-labeler
1669                       &key (duplicate-edge-function :ignore))
1670   ;; bring the graph up to size
1671   (loop for i from (size graph) to (1- size) do
1672         (add-vertex graph (funcall vertex-labeler 0 i)))
1673
1674   (loop repeat iterations do
1675         (add-acquaintance-and-maybe-kill-something
1676          generator graph death-probability duplicate-edge-function))
1677   (values graph))
1678
1679 ;;; ---------------------------------------------------------------------------
1680
1681 (defmethod generate-acquaintance-network-until-stable
1682            (generator graph size death-probability step-count
1683                       stability-fn vertex-labeler
1684                       &key (duplicate-edge-function :ignore))
1685   ;; bring the graph up to size
1686   (loop for i from (size graph) to (1- size) do
1687         (add-vertex graph (funcall vertex-labeler 0 i)))
1688
1689   (loop do
1690         (loop repeat step-count do
1691               (add-acquaintance-and-maybe-kill-something
1692                generator graph death-probability duplicate-edge-function))
1693         (when (funcall stability-fn graph)
1694           (return)))
1695
1696   (values graph))
1697
1698 ;;; ---------------------------------------------------------------------------
1699
1700 (defun add-acquaintance-and-maybe-kill-something
1701        (generator graph death-probability duplicate-edge-function)
1702   ;; add edges step
1703   (bind ((vertex (sample-element (graph-vertexes graph) generator))
1704          (neighbors (when (>= (size (vertex-edges vertex)) 2)
1705                       (sample-unique-elements
1706                        (vertex-edges vertex) generator 2))))
1707     (flet ((sample-other-vertex ()
1708              (loop for result = (sample-element (graph-vertexes graph) generator)
1709                    until (not (eq vertex result))
1710                    finally (return result))))
1711       (if neighbors
1712         (add-edge-between-vertexes
1713          graph
1714          (other-vertex (first neighbors) vertex)
1715          (other-vertex (second neighbors) vertex)
1716          :if-duplicate-do duplicate-edge-function)
1717         (add-edge-between-vertexes
1718          graph vertex (sample-other-vertex)
1719          :if-duplicate-do duplicate-edge-function))))
1720
1721   ;; remove vertexes step
1722   (when (random-boolean generator death-probability)
1723     (let ((vertex (sample-element (graph-vertexes graph) generator)))
1724       (delete-vertex graph vertex)
1725       (add-vertex graph (element vertex)))))
1726
1727 #+Ignore
1728 (defun sv (v)
1729   (format t "~%~A ~A"
1730           v
1731           (adjustable-array-p (contents (vertex-edges v)))))
1732
1733 #+Test
1734 (generate-acquaintance-network
1735  *random-generator*
1736  (make-graph 'graph-container :edge-type :undirected)
1737  1000
1738  0.001
1739  10000
1740  'simple-group-id-generator)