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