dev/graph-generation.lisp

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