dev/graph-generation.lisp

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