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