├── .gitignore ├── src ├── README.org ├── notused │ ├── test-polynomial.lisp │ ├── polynomials.lisp │ ├── timeseries.lisp │ └── armodel.lisp ├── utilities.lisp ├── notes.org ├── package.lisp ├── validation.lisp ├── slice-sampling.lisp ├── samplers.lisp ├── mosaic.lisp ├── chains.lisp ├── dlm.lisp └── mcmc.lisp ├── tests ├── package.lisp ├── setup.lisp ├── samplers.lisp ├── dlm.lisp └── chains.lisp ├── README.md ├── references.bib ├── cl-bayesian.asd └── examples └── sine-mcmc.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *~ 3 | -------------------------------------------------------------------------------- /src/README.org: -------------------------------------------------------------------------------- 1 | 2 | * Things to do 3 | - test overdispersion routines 4 | -------------------------------------------------------------------------------- /tests/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-bayesian-tests 2 | (:use #:common-lisp #:iterate #:let-plus #:anaphora #:alexandria 3 | #:cl-num-utils #:lla #:cl-random #:cl-bayesian #:lift) 4 | ;; also in alexandria 5 | (:shadowing-import-from #:cl-num-utils 6 | #:mean #:variance #:median #:xor) 7 | (:export #:run-cl-bayesian-tests)) 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Project Status: Abandoned – Initial development has started, but there has not yet been a stable, usable release; the project has been abandoned and the author(s) do not intend on continuing development.](http://www.repostatus.org/badges/latest/abandoned.svg)](http://www.repostatus.org/#abandoned) This library is [**abandonned**](https://tpapp.github.io/post/orphaned-lisp-libraries/). 2 | 3 | Various Common Lisp routines for Bayesian estimation and analysis. 4 | 5 | Currently, very preliminary and incomplete. 6 | -------------------------------------------------------------------------------- /tests/setup.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-bayesian-tests) 4 | 5 | (deftestsuite cl-bayesian-tests () () 6 | (:equality-test #'==)) 7 | 8 | (defun small-zs? (z-statistics &key (threshold 2) (margin 4)) 9 | "Test if the number of Z statistics larger than THRESHOLD is smaller than 10 | the expected number when corrected by MARGIN." 11 | (format t "z-statistics: ~A~%" z-statistics) 12 | (let* ((count (count-if (curry #'< threshold) z-statistics)) 13 | (p (* 2 (- 1 (cdf (r-normal) threshold)))) 14 | (allowed-large-z (ceiling (* margin p (length z-statistics))))) 15 | (<= count allowed-large-z))) 16 | 17 | ;; EXTERNAL 18 | 19 | (defun run () 20 | "Run all the tests." 21 | (run-tests :suite 'cl-bayesian-tests)) 22 | -------------------------------------------------------------------------------- /references.bib: -------------------------------------------------------------------------------- 1 | @article{gelman1992inference, 2 | title={{Inference from Iterative Simulation Using Multiple Sequences}}, 3 | author={Gelman, A. and Rubin, D.B.}, 4 | journal={Statistical Science}, 5 | volume={7}, 6 | number={4}, 7 | pages={457--472}, 8 | year={1992} 9 | } 10 | 11 | @article{brooks1998alternative, 12 | title={{Alternative methods for monitoring convergence of iterative simulations}}, 13 | author={Brooks, S.P. and Gelman, A.}, 14 | journal={Journal of Computational and Graphical Statistics}, 15 | volume={7}, 16 | number={4}, 17 | pages={434--455}, 18 | year={1998} 19 | } 20 | 21 | @article{cook2006validation, 22 | title={Validation of software for Bayesian models using posterior quantiles}, 23 | author={Cook, S.R. and Gelman, A. and Rubin, D.B.}, 24 | journal={Journal of Computational and Graphical Statistics}, 25 | volume={15}, 26 | number={3}, 27 | pages={675--692}, 28 | year={2006}, 29 | publisher={ASA} 30 | } 31 | 32 | @article{bda, 33 | title={Bayesian data analysis}, 34 | author={Gelman, A. and Carlin, J.B. and Stern, H.S. and Rubin, D.B.}, 35 | year={2004} 36 | } 37 | -------------------------------------------------------------------------------- /src/notused/test-polynomial.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op :lift) 2 | (asdf:oos 'asdf:load-op :cl-timeseries) 3 | 4 | (in-package :cl-timeseries) 5 | 6 | (use-package :lift) 7 | 8 | ;;; HELPER FUNCTIONS 9 | 10 | ;;; TEST SUITE 11 | 12 | (deftestsuite cl-timeseries () () 13 | :equality-test #'equalp) 14 | 15 | ;;; polynomials 16 | 17 | (addtest (cl-timeseries) 18 | polynomials 19 | (let ((a (make-poly 2d0)) 20 | (b (make-poly 3d0)) 21 | (c (make-poly 5d0 7d0)) 22 | (d (make-poly 11d0 13d0 17d0))) 23 | (ensure-same (poly* a b) #(5.0d0 6.0d0)) 24 | (ensure-same (poly* b c) #(8.0d0 22.0d0 21.0d0)) 25 | (ensure-same (poly* c d) #(16.0d0 75.0d0 159.0d0 176.0d0 119.0d0)))) 26 | 27 | (addtest (cl-timeseries) 28 | filter 29 | (let ((x (make-poly 1d0 2d0 3d0 3d0 5d0 6d0))); abusing make-poly :-) 30 | (ensure-same (filter x (make-poly)) 31 | #(1.0d0 2.0d0 3.0d0 3.0d0 5.0d0 6.0d0)) 32 | (ensure-same (filter x (make-poly 0d0)) 33 | #(2.0d0 3.0d0 3.0d0 5.0d0 6.0d0)) 34 | (ensure-same (filter x (make-poly -1d0)) 35 | #(1.0d0 1.0d0 0.0d0 2.0d0 1.0d0)) 36 | (ensure-same (filter x (make-poly -0.5d0 -0.5d0)) 37 | #(1.5d0 0.5d0 2.0d0 2.0d0)))) 38 | -------------------------------------------------------------------------------- /cl-bayesian.asd: -------------------------------------------------------------------------------- 1 | (defsystem #:cl-bayesian 2 | :description "" 3 | :author "Tamas K Papp" 4 | :license "LLGPL" 5 | :in-order-to ((test-op (test-op cl-bayesian-tests))) 6 | :serial t 7 | :components 8 | ((:module 9 | "package-init" 10 | :pathname #P "src/" 11 | :components 12 | ((:file "package"))) 13 | (:module 14 | "basics" 15 | :pathname #P"src/" 16 | :depends-on ("package-init") 17 | :serial t 18 | :components 19 | ((:file "utilities") 20 | (:file "mcmc") 21 | (:file "slice-sampling") 22 | (:file "mosaic") 23 | (:file "samplers") 24 | (:file "chains") 25 | (:file "validation") 26 | (:file "dlm") 27 | ;; (:file "polynomials") 28 | ))) 29 | :depends-on (#:iterate #:let-plus #:anaphora #:alexandria #:cl-num-utils 30 | #:lla #:cl-random #:fare-mop)) 31 | 32 | (defsystem #:cl-bayesian-tests 33 | :description "Unit tests for the CL-BAYESIAN library." 34 | :author "Tamas K Papp" 35 | :license "Same as CL-BAYESIAN -- this is part of the latter." 36 | :serial t 37 | :components 38 | ((:module 39 | "package-init" 40 | :pathname #P "tests/" 41 | :components 42 | ((:file "package"))) 43 | (:module 44 | "setup" 45 | :pathname #P"tests/" 46 | :depends-on ("package-init") 47 | :serial t 48 | :components 49 | ((:file "setup"))) 50 | (:module 51 | "tests" 52 | :pathname #P"tests/" 53 | :components 54 | ((:file "samplers") 55 | (:file "chains") 56 | (:file "dlm")))) 57 | :depends-on 58 | (#:iterate #:let-plus #:anaphora #:alexandria #:lift #:cl-num-utils #:lla 59 | #:cl-random #:cl-random-tests)) 60 | -------------------------------------------------------------------------------- /src/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*- 2 | 3 | (in-package #:cl-bayesian) 4 | 5 | (defgeneric overdisperse (distribution factor &key &allow-other-keys) 6 | (:documentation "Return an overdispersed distribution. Usually variance is 7 | blown up by FACTOR and the mean is preserved, but methods may behave 8 | differently. The semantics is only define heuristically: use this for 9 | generating overdispersed distributions for MCMC.") 10 | (:method (distribution factor &key nu) 11 | (let+ (((&accessors-r/o mean variance) distribution) 12 | (variance (e* factor variance))) 13 | (if (numberp mean) 14 | (if nu 15 | (r-t mean (/ (sqrt variance) 16 | (t-scale-to-variance-coefficient nu)) 17 | nu) 18 | (r-normal mean variance)) 19 | (if nu 20 | (r-multivariate-t 21 | mean 22 | (e/ variance (t-scale-to-variance-coefficient nu)) nu) 23 | (r-multivariate-normal mean variance))))) 24 | (:method ((distribution r-gamma) factor &key) 25 | (let+ (((&accessors-r/o alpha beta) distribution)) 26 | (r-gamma (/ alpha factor) (* beta factor)))) 27 | (:method ((distribution r-inverse-gamma) factor &key) 28 | (let+ (((&accessors-r/o alpha beta) distribution)) 29 | (r-inverse-gamma (1+ (* factor (1- alpha))) (* factor beta)))) 30 | (:method ((distribution r-multivariate-t) factor &key) 31 | (let+ (((&accessors-r/o multivariate-normal scaling-factor) 32 | distribution)) 33 | (r-multivariate-t nil nil nil 34 | :multivariate-normal multivariate-normal 35 | :scaling-factor (overdisperse 36 | scaling-factor factor))))) 37 | -------------------------------------------------------------------------------- /src/notes.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Notes for CL-BAYESIAN 2 | #+OPTIONS: TeX:t LaTeX:t skip:nil d:nil tags:not-in-toc author:nil 3 | #+OPTIONS: H:3 num:nil toc:t \n:nil @:t ::t |:t ^:t -:t f:t *:tl creator:nil 4 | 5 | Sketches of proofs and reminders for the algorithms behind some 6 | functions. Most of these results are entirely standard, I am including them here mainly to fix notation. For distributions, I am using the same parametrization as Gelman et al (2004) [BDA]. 7 | 8 | * UDDU decomposition 9 | 10 | $$A=UD^2U^T$$ 11 | where $U$ is unitary (ie $UU^T=I$ and $U$ is square) and $D$ is a diagonal matrix. 12 | 13 | ** Inverting it is really cheap: 14 | $$A^{-1} = (UD^2U^T)^{-1} = {U^T}^{-1} D^{-2} U^{-1} = U D^{-2} U^T$$ 15 | 16 | ** Adding a Hermitian matrix $H=LL^T$: 17 | $$A+H = XX^T \qquad\text{where}\qquad X=\begin{bmatrix}UD & L\end{bmatrix}$$ 18 | Using SVD, 19 | $$X=\tilde U\tilde D\tilde V^T$$ 20 | so 21 | $$A+H=\tilde U \tilde D^2 \tilde U^T$$ 22 | Note that $\tilde V\tilde V^T=I$ and thus $\tilde V^T$ is not needed from the SVD. 23 | 24 | ** Another way of adding a Hermitian matrix: 25 | $$A+H=U(D^2+U^TLL^TU)U^T=UYY^TU^T \qquad\text{where}\qquad Y=\begin{bmatrix}D & U^TL\end{bmatrix}$$ 26 | Then using SVD, 27 | $$Y=\hat U\hat D\hat V^T$$ 28 | so 29 | $$A+H=U \hat U \hat D^2 \hat U^T U^T$$ 30 | Again, we don't need to calculate $\hat V^T$. 31 | 32 | * Simple Bayesian models 33 | 34 | These models can be used on their own, but they are meant to be building blocks for Gibbs samplers. 35 | 36 | ** Univariate normal error 37 | 38 | $$\epsilon_i \sim N(0,v), \text{iid}, n=1,\dots,n$$ 39 | where $v=\sigma^2$ is the variance. The likelihood is 40 | $$p(\epsilon \mid v) \propto v^{-n/2} e^{s/(2v)}\qquad\text{where}\qquad s=\sum_i \epsilon_i^2$$ 41 | and with an $\text{inverse-gamma}(\alpha_0,\beta_0)$ conjugate prior, 42 | the posterior is 43 | $$(v\mid\epsilon) \sim \text{inverse-gamma}(\alpha_0+n/2,\beta_0+s/2)$$ 44 | 45 | ** Univariate normal model 46 | 47 | $$\epsilon_i \sim N(m,v), \text{iid}, n=1,\dots,n$$ 48 | The likelihood is 49 | $$ 50 | -------------------------------------------------------------------------------- /src/notused/polynomials.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-bayesian) 2 | 3 | ;;;; Polynomials for time series. 4 | ;;;; 5 | ;;;; Coefficients are in increasing order. These functions are 6 | ;;;; intended for operation on lag polynomials where the first 7 | ;;;; coefficient is 1, which is omitted. 8 | 9 | (deftype polynomial (&optional n) 10 | `(simple-array double-float (,n))) 11 | 12 | (defun make-poly (&rest coefficients) 13 | (make-array (length coefficients) :element-type 'double-float 14 | :initial-contents coefficients)) 15 | 16 | (defun poly* (a b) 17 | "Multiply two polynomials." 18 | (check-type a polynomial) 19 | ;; (check-type b polynomial) 20 | (let* ((a-n (length a)) 21 | (b-n (length b))) 22 | ;; take care of unit polynomials 23 | (when (zerop a-n) 24 | (return-from poly* b)) 25 | (when (zerop b-n) 26 | (return-from poly* a)) 27 | ;; actual multiplication 28 | (let ((c (make-array (+ a-n b-n) :element-type 'double-float))) 29 | ;; 1 30 | (dotimes (a-i a-n) 31 | (setf (aref c a-i) (aref a a-i))) 32 | ;; rest 33 | (dotimes (b-i b-n) 34 | (let ((b-coeff (aref b b-i))) 35 | (incf (aref c b-i) b-coeff) 36 | (iter 37 | (for c-i :from (1+ b-i)) 38 | (for a-coeff :in-vector a) 39 | (incf (aref c c-i) (* a-coeff b-coeff))))) 40 | c))) 41 | 42 | (defun filter (x phi) 43 | "Filter x through the lag polynomial phi." 44 | (check-type phi polynomial) 45 | (check-type x (simple-array double-float (*))) 46 | (let ((x-n (length x)) 47 | (phi-n (length phi))) 48 | (unless (< (1+ phi-n) x-n) 49 | (error "series is too short for filter")) 50 | (when (zerop phi-n) 51 | (return-from filter x)) 52 | (let ((result (make-array (- x-n phi-n) :element-type 'double-float))) 53 | ;; 1 54 | (iter 55 | (for result-i :from 0) 56 | (for x-i :from phi-n :below x-n) 57 | (setf (aref result result-i) 58 | (+ (aref x x-i) 59 | (iter 60 | (for x-elt :in-vector x :downfrom (1- x-i)) 61 | (for phi-elt :in-vector phi) 62 | (summing (* x-elt phi-elt)))))) 63 | result))) 64 | -------------------------------------------------------------------------------- /examples/sine-mcmc.lisp: -------------------------------------------------------------------------------- 1 | ;;; sine example 2 | (in-package :cl-bayesian) 3 | (asdf:load-system :cl-cairo2-x11) 4 | (asdf:load-system :cl-2d) 5 | 6 | (define-mcmc sine () 7 | ((x :parameter (atom :updater metropolis) :reader x :initarg :x))) 8 | 9 | ;; (define-mcmc sinexy () 10 | ;; ((x :parameter (atom :updater metropolis) :reader x :initarg :x) 11 | ;; (y :parameter (vector :updater gibbs)))) 12 | 13 | 14 | (define-metropolis-updater (sine x) () 15 | (flet ((log-likelihood (x) 16 | (if (< 2 x 100) 17 | (log (/ (sin (/ (* 2 pi) x)) (expt x 2))) 18 | nil))) 19 | (let* ((xnext (+ x (rv:draw x-propdist))) 20 | (lp-ratio (calc-lp-ratio x xnext log-likelihood))) 21 | (metropolis-step x xnext lp-ratio x-counter)))) 22 | 23 | (defmethod copy-parameters ((mcmc sine)) 24 | (x mcmc)) 25 | 26 | (defparameter *a* (make-instance 'sine :x 2.5d0 :x-propdist (make-instance 'rv:normal))) 27 | 28 | (defparameter *lambda* (run-mcmc *a* 100000)) 29 | (defparameter *r* (xcollect (length *lambda*) (rv:generator* 'rv:beta :alpha 3d0 :beta 1d0))) 30 | 31 | (defparameter *phi1* (xmap '(array :element-type double-float) 32 | (lambda (r l) 33 | (* 2d0 r (cos (/ (* 2 pi) l)))) 34 | *r* *lambda*)) 35 | (defparameter *phi2* (map 'vector (lambda (r) 36 | (- (expt r 2))) 37 | *r*)) 38 | 39 | 40 | (defparameter *frame* (cl-2d:as-frame (cl-cairo2:create-xlib-image-context 800 600) 41 | :background-color cl-colors:+white+)) 42 | 43 | (cl-2d:plot-function *frame* (lambda (x) (log (/ (sin (/ (* 2 pi) x)) (expt x 2)))) 44 | (cl-2d:interval-of 2 10)) 45 | 46 | (cl-2d:plot-histogram *frame* (cl-numlib:histogram *lambda* :breaks-function 47 | (cl-numlib:histogram-evenly-distributed-breaks 100)) 48 | :x-interval (cl-2d:interval-of 2 8)) 49 | (cl-2d:plot-sequence *frame* *lambda*) 50 | (cl-2d:plot-histogram *frame* (cl-numlib:histogram *r*)) 51 | (cl-2d:plot-histogram *frame* (cl-numlib:histogram *phi1*)) 52 | (cl-2d:plot-histogram *frame* (cl-numlib:histogram *phi2*)) 53 | 54 | (cl-2d:plot-symbols *frame* *phi1* *phi2* 55 | :symbol-drawing-function #'cl-2d:symbol-filled-circle 56 | :size-function (constantly 20) 57 | :color-function (constantly (cl-colors:add-alpha cl-colors:+blue+ 0.01))) 58 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-bayesian 2 | (:nicknames #:mcmc) 3 | (:use #:common-lisp 4 | #:cl-num-utils.statistics 5 | #:alexandria 6 | #:anaphora 7 | #:fare-mop 8 | #:iterate 9 | #:lla 10 | #:let-plus) 11 | (:shadowing-import-from #:cl-num-utils ; also in alexandria 12 | #:mean #:variance #:median 13 | #:sum) 14 | (:export 15 | ;; utilities 16 | #:overdisperse 17 | ;; layout 18 | #:extract 19 | #:layout-length 20 | #:parse-layout 21 | #:flatten-into 22 | #:named-layout 23 | #:scalar-layout 24 | ;; mcmc 25 | #:start-chain 26 | #:scalar-parameters-layout 27 | #:model 28 | #:common-model 29 | #:scalar-parameters 30 | #:draw-chain 31 | ;; slice-sample 32 | #:slice-sample-so 33 | ;; samplers 34 | #:univariate-normal-error 35 | #:univariate-normal-model 36 | #:lr-kv-dummies 37 | #:lr-kv 38 | #:multivariate-normal-model 39 | #:kappa 40 | #:inverse-scale 41 | ;; chains 42 | #:*suggested-minimum-burn-in**default-burn-in-fraction* 43 | #:discard-burn-in 44 | #:calculate-psrf 45 | #:psrf-r 46 | #:psrf-v 47 | #:psrf-w 48 | #:calculate-psrf-ranges 49 | #:mcmc-statistics 50 | #:accumulators 51 | #:autocovariance-accumulators 52 | #:sse-ranges 53 | #:sse-accumulators 54 | #:mcmc-summary 55 | #:psrf 56 | #:accumulators 57 | #:mean-autocorrelations 58 | #:psrf-ranges 59 | #:summarize-mcmc-statistics 60 | #:pool-samples 61 | ;; validation 62 | #:calculate-empirical-ranks 63 | #:calculate-p-statistics 64 | #:calculate-abs-z-statistics 65 | ;; dlm 66 | #:dlm-evolution1 67 | #:dlm-evolution1-G 68 | #:dlm-evolution1-mu 69 | #:dlm-evolution1-W 70 | #:dlm-observation1 71 | #:dlm-observation1-F 72 | #:dlm-observation1-V 73 | #:dlm 74 | #:make-dlm 75 | #:dlm-length 76 | #:sub-dlm 77 | #:uddu 78 | #:uddu-u 79 | #:uddu-d 80 | #:uddu-update 81 | #:uddu-multiply-update 82 | ;; dlm-evolution dlm-evolution-G dlm-evolution-mu dlm-evolution-W 83 | ;; dlm-observation dlm-observation-F dlm-observation-V 84 | #:dlm-forward-filtering 85 | #:dlm-backward-sampling 86 | #:dlm-ff-bs 87 | #:dlm-errors 88 | #:dlm-simulate 89 | ;; NEED TO BE SORTED OUT 90 | #:pack-slots 91 | #:unpack-slots 92 | #:mosaic 93 | #:make-mosaic 94 | #:template-mosaic 95 | #:template-mosaic-symbols 96 | #:make-mosaic-matrix 97 | #:mcmc-mosaic-matrix 98 | #:mosaic-vector 99 | #:make-mosaic-vector 100 | #:mosaic-matrix 101 | #:binomial-model 102 | #:multinomial-model)) 103 | -------------------------------------------------------------------------------- /src/validation.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-bayesian) 4 | 5 | ;;; Validation method of Cook et al (2006). 6 | 7 | (defun calculate-empirical-ranks (parameters draws) 8 | "Return a vector of empirical ranks for each parameter. Note: ranks are 9 | corrected by 0.5 and divided by n+1 to ensure that they are all in (0,1)." 10 | (let+ (((nrow ncol) (array-dimensions draws)) 11 | (counts (make-array ncol :element-type 'fixnum :initial-element 0))) 12 | (assert (= ncol (length parameters))) 13 | (dotimes (row-index nrow) 14 | (dotimes (col-index ncol) 15 | (when (< (aref draws row-index col-index) (aref parameters col-index)) 16 | (incf (aref counts col-index))))) 17 | (map 'vector (lambda (c) (/ (+ c 0.5d0) (1+ nrow))) counts))) 18 | 19 | (defun calculate-p-statistic (ranks) 20 | "Given the RANKS for a single parameter, return a p-value. Note that all 21 | ranks have to be in (0,1)." 22 | (cdf (r-chi-square (length ranks)) 23 | (iter 24 | (for r :in-vector ranks) 25 | (summing (expt (quantile (r-normal) r) 2))))) 26 | 27 | (defun abs-z-transform (p) 28 | "Transform the probability p (in [0,1]) to the absolute value of a standard 29 | normal. For 0 and 1, return NIL." 30 | (if (or (= p 1) (= p 0)) 31 | nil 32 | (abs (quantile (r-normal) p)))) 33 | 34 | (defun calculate-p-statistics (ranks+) 35 | "Calculate the P statistics of a ranks (a vector of vectors, or equal 36 | length)." 37 | (map1 #'calculate-p-statistic 38 | (subarrays 1 (transpose (combine ranks+))))) 39 | 40 | (defun calculate-abs-z-statistics (ranks+) 41 | "Calculate the abs(z) statistics from ranks. " 42 | (map1 #'abs-z-transform (calculate-p-statistics ranks+))) 43 | 44 | ;;; testing the validation with a normal distribution 45 | 46 | ;; (defun simulate-linear-regression-y (prior x) 47 | ;; "Return (valyes y parameters)." 48 | ;; (let+ (((&values beta sigma) (draw prior))) 49 | ;; (values 50 | ;; (e+ (mm x beta) (generate-array (nrow x) 51 | ;; (generator (r-normal 0 (sqrt sigma))))) 52 | ;; (concat 'double-float (vector sigma) beta)))) 53 | 54 | ;; (defun simulate-linear-regression-parameters (n y x prior) 55 | ;; "Given Y, return a matrix of draws." 56 | ;; (let ((lr (linear-regression y x :prior prior))) 57 | ;; (combine (generate-array n (lambda () 58 | ;; (let+ (((&values beta sigma) (draw lr))) 59 | ;; (concat 'double-float (vector sigma) beta)))) 60 | ;; 'double-float))) 61 | 62 | 63 | ;; (defparameter *q* (calculate-empirical-ranks *parameters* *draws*)) 64 | ;; (map1 #'float *q*) 65 | 66 | ;; (defparameter *ranks+* 67 | ;; (let ((n 1000) 68 | ;; (x *x*) 69 | ;; (prior *prior*)) 70 | ;; (generate-array 100 (lambda () 71 | ;; (let+ (((&values y parameters) 72 | ;; (simulate-linear-regression-y prior x)) 73 | ;; (draws (simulate-linear-regression-parameters 74 | ;; n y x prior))) 75 | ;; (calculate-empirical-ranks parameters draws)))))) 76 | 77 | ;; (histogram (sub (map1 #'float (combine *ranks+*)) t 0) 78 | ;; (rcurry #'scott-rule :correction 0.25)) 79 | 80 | ;; (defparameter *r* (sub (map1 #'float (combine *ranks+*)) t 0)) 81 | ;; (range *r*) 82 | 83 | ;; (calculate-empirical-p-statistic (sub (map1 #'float (combine *ranks+*)) t 0)) 84 | 85 | ;; (defparameter *p* (calculate-p-statistics *ranks+*)) 86 | -------------------------------------------------------------------------------- /src/notused/timeseries.lisp: -------------------------------------------------------------------------------- 1 | (in-package :bayesian-inference) 2 | 3 | ;;;; !!! all should be prepended with ts 4 | 5 | (defclass date () 6 | ((main :initarg :main :accessor main) 7 | (sub :initarg :sub :accessor sub :initform 0) 8 | (frequency :initarg :frequency :initform 1 :reader frequency))) 9 | 10 | (defmethod initialize-instance :after ((date date) &key &allow-other-keys) 11 | (with-slots (sub frequency) date 12 | ;; check frequency and sub 13 | (assert (plusp frequency)) 14 | (assert (and (<= 0 sub) (< sub frequency)))) 15 | date) 16 | 17 | (defmethod print-object ((date date) stream) 18 | (print-unreadable-object (date stream :type t) 19 | (with-slots (main sub frequency) date 20 | (format stream "~a ~a/~a" main sub frequency)))) 21 | 22 | (defun date->integer (date) 23 | (with-slots (main sub frequency) date 24 | (+ (* main frequency) sub))) 25 | 26 | (defun integer->date (num frequency) 27 | (multiple-value-bind (main sub) (floor num frequency) 28 | (make-instance 'date :main main :sub sub :frequency frequency))) 29 | 30 | (defun date+ (date offset) 31 | (integer->date (+ (date->integer date) offset) (frequency date))) 32 | 33 | (defun date- (date offset) 34 | (integer->date (+ (date->integer date) offset) (frequency date))) 35 | 36 | (defun frequency= (&rest dates) 37 | (apply #'= (mapcar #'frequency dates))) 38 | 39 | (defun date-diff (date1 date2) 40 | (assert (frequency= date1 date2)) 41 | (- (date->integer date1) (date->integer date2))) 42 | 43 | (defun date-min (&rest dates) 44 | (assert (apply #'frequency= dates)) 45 | (integer->date (apply #'min (mapcar #'date->integer dates)) 46 | (frequency (first dates)))) 47 | 48 | (defun date-max (&rest dates) 49 | (assert (apply #'frequency= dates)) 50 | (integer->date (apply #'max (mapcar #'date->integer dates)) 51 | (frequency (first dates)))) 52 | 53 | ;;;; !! time series 54 | ;;;; !!! document everything 55 | 56 | (defclass ts (date) 57 | ((vec :initarg :vec :accessor vec))) 58 | 59 | (defun end-date (ts) 60 | (date+ ts (1- (length (vec ts))))) 61 | 62 | (defmethod print-object ((ts ts) stream) 63 | (print-unreadable-object (ts stream :type t) 64 | (with-slots (main sub frequency vec) ts 65 | (format stream "~a ~a/~a+~a: ~a" main sub frequency (length vec) vec)))) 66 | 67 | (defun intersect (&rest tss) 68 | (declare (optimize (debug 3))) 69 | (assert (apply #'frequency= tss)) 70 | (let+ (((max-start common-length) 71 | (iter 72 | (for ts :in tss) 73 | (for start := (date->integer ts)) 74 | (maximize start :into max-start) 75 | (minimize (+ start (length (vec ts))) :into min-end) 76 | (finally (return (list max-start (- min-end max-start)))))) 77 | (frequency (frequency (car tss)))) 78 | (with-slots (main sub) (integer->date max-start frequency) 79 | (mapcar (lambda (ts) 80 | (with-slots (vec) ts 81 | (let ((start-index (- max-start (date->integer ts)))) 82 | (make-instance 'ts :main main :sub sub :frequency frequency 83 | :vec (subseq vec start-index 84 | (+ start-index common-length)))))) 85 | tss)))) 86 | 87 | ;; (defparameter *d1* (make-instance 'date :main 2004 :sub 8 :frequency 12)) 88 | ;; (defparameter *d2* (make-instance 'date :main 2003 :sub 4 :frequency 12)) 89 | 90 | ;; (date+ *d1* 16) 91 | ;; (date-diff *d1* *d2*) 92 | 93 | ;; (defparameter *ts1* (make-instance 'ts 94 | ;; :main 2004 :sub 0 :frequency 4 95 | ;; :vec #(0 1 2 3 4 5 6 7 8 9 10 11))) 96 | 97 | ;; (defparameter *ts2* (make-instance 'ts 98 | ;; :main 2005 :sub 2 :frequency 4 99 | ;; :vec #(0 1 2 3 4 5 6 7 8 9 10 11))) 100 | 101 | ;; (intersect *ts1* *ts2*) 102 | -------------------------------------------------------------------------------- /src/slice-sampling.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-bayesian) 4 | 5 | (defun slice-sample-so (x g &key (w 1d0) (max-iter 100) lower upper 6 | (gx (funcall g x))) 7 | "Slice sampling, starting at X, using the stepping out algorithm of 8 | Neal (2003, especially Fig 3 and 5). Return the new sample point and the 9 | value of the log density at that point. G is the log of the probability (+ 10 | constant), and may return NIL when the probability is zero. W is the starting 11 | width. MAX-ITER, LOWER and UPPER define maximum number of iterations, and 12 | lower/upper bounds for X. When NIL, these three are considered as not 13 | applicable and are not used to terminate the algorithm. In particular, when 14 | bounds are given, G is never called outside these." 15 | (assert gx () "p(x) = 0") 16 | (let+ ((log-y (- gx (draw-standard-exponential))) 17 | (u (random 1d0)) 18 | (left (- x (* w u))) 19 | (right (+ left w)) 20 | ((&values j k) (if max-iter 21 | (let* ((j (floor (random (float max-iter 1d0)))) 22 | (k (- max-iter 1 j))) 23 | (values j k)) 24 | (values nil nil))) 25 | ((&flet outside? (z) (awhen (funcall g z) (<= it log-y))))) 26 | ;; extend to the left 27 | (loop 28 | (when (or (and j (<= j 0)) (and lower (<= left lower)) (outside? left)) 29 | (return)) 30 | (decf left w) 31 | (when j (decf j))) 32 | ;; extend to the right 33 | (loop 34 | (when (or (and k (<= k 0)) (and upper (>= right upper)) (outside? right)) 35 | (return)) 36 | (incf right w) 37 | (when k (decf k))) 38 | ;; when bounds are given, shrink 39 | (when upper 40 | (minf right upper)) 41 | (when lower 42 | (maxf left lower)) 43 | ;; sample slice 44 | (loop 45 | (let* ((x1 (+ left (random (- right left)))) 46 | (gx1 (funcall g x1))) 47 | (cond 48 | ;; note: we use <= for termination, following the code of Neal 49 | ;; instead of the paper, to ensure termination if the interval is 50 | ;; shrunk to the original point X 51 | ((and gx1 (<= log-y gx1)) (return (values x1 gx1))) 52 | ;; just shrink interval 53 | ((< x1 x) (setf left x1)) 54 | (t (setf right x1))))))) 55 | 56 | ;; (defun test-slice-sample-so-univariate (g n &key (burn-in 1000) 57 | ;; sampler-params (x 1d0)) 58 | ;; (bind ((g-counter 0) 59 | ;; ((:flet g-c (x)) 60 | ;; (incf g-counter) 61 | ;; (funcall g x)) 62 | ;; ((:flet update ()) 63 | ;; (setf x (apply #'slice-sample-so x #'g-c sampler-params))) 64 | ;; (s (make-array n :element-type 'double-float))) 65 | ;; (loop repeat burn-in do (update)) 66 | ;; (setf g-counter 0) 67 | ;; (loop for i :below n do (setf (aref s i) (update))) 68 | ;; (format t "~A calls/sample~%" (float (/ g-counter n))) 69 | ;; s)) 70 | 71 | ;; (defun test-sso-with-rv (rv &key (n 100000) (burn-in 10000) 72 | ;; sampler-params (x (mean rv))) 73 | ;; (bind (((:flet g (x)) 74 | ;; (log-pdf rv x t)) 75 | ;; (s (test-slice-sample-so-univariate #'g n :x x :burn-in burn-in 76 | ;; :sampler-params sampler-params))) 77 | ;; (d:v (mean s) (mean rv) (variance s) (variance rv)) 78 | ;; (values (/ (- (mean s) (mean rv)) (sqrt (variance rv))) 79 | ;; (/ (variance s) (variance rv))))) 80 | 81 | ;; (test-sso-with-rv (make-instance 'normal :mu 0d0 :sigma 1d0)) 82 | 83 | ;; (test-sso-with-rv (make-instance 'gamma :alpha 9d0 :beta 3d0)) 84 | -------------------------------------------------------------------------------- /src/notused/armodel.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-timeseries) 2 | 3 | (define-mcmc armodel () 4 | (;; data 5 | (x :accessor x :type vector :documentation "time series") 6 | ;; parameters 7 | (real-roots :accessor real-roots :type vector 8 | :documentation "real roots" 9 | :parameter (vector :updater gibbs)) 10 | (complex-roots :accessor complex-roots :type vector 11 | :parameter (vector :updater metropolis) 12 | :documentation 13 | "complex roots, vector of consecutive pairs, stored 14 | as magnitude/period conses.") 15 | (real-probabilities :accessor real-probabilities :type vector 16 | :parameter (atom :updater gibbs) 17 | :documentation "pr-1, pr0, and pr1") 18 | (complex-probabilities :accessor complex-probabilities :type vector 19 | :parameter (atom :updater gibbs) 20 | :documentation "pc0 and pc1") 21 | (variance :accessor variance :type double-float 22 | :parameter (atom :updater gibbs) 23 | :documentation "variance of innovation") 24 | ;; dogmatic parameters 25 | (lambda-upper :accessor lambda-upper :type double-float 26 | :documentation "upper bound for periods"))) 27 | 28 | (defun real-root->poly (real-root) 29 | "Return polynomial for real root." 30 | (make-poly (- real-root))) 31 | 32 | (defun complex-root->poly (complex-root) 33 | "Return polynomial for complex root." 34 | (let+ (((r . lambda) complex-root)) 35 | (make-poly (* -2d0 r (cos (/ (* 2 pi) lambda))) 36 | (expt r 2)))) 37 | 38 | (defun roots->polynomial (roots complex-or-real &optional remove-index) 39 | "Return the polynomial for roots, removing root at remove-index if 40 | non-nil." 41 | (let* ((root->poly (ecase complex-or-real 42 | (:real #'real-root->poly) 43 | (:complex #'complex-root->poly))) 44 | (polynomials (iter 45 | (for i :from 0) 46 | (for r :in-vector roots) 47 | (when (and remove-index (= i remove-index)) 48 | (collecting (funcall root->poly r)))))) 49 | (reduce #'poly* polynomials))) 50 | 51 | (defun draw-real-root (mean var probabilities) 52 | "Draw a real root, with given mean and variance for the likelihood, 53 | and probabilities for mass points (vector of 3 elements)." 54 | (flet ((calculate-p (x p-index) 55 | (* (aref probabilities p-index) (exp (/ (expt (- x mean) 2) var -2d0))))) 56 | (let* ((sd (sqrt var)) 57 | (p-1 (calculate-p -1d0 0)) 58 | (p0 (calculate-p 0d0 1)) 59 | (p1 (calculate-p 1 2)) 60 | (prest (* (- 1 (xsum pi)) 0.5d0 (sqrt (* 2d0 pi var)) 61 | (- (rv:cdf 'rv:normal 1d0) (rv:cdf 'rv:normal -1d0))))) 62 | (ecase (rv:draw* 'discrete :probabilities (vector p-1 p0 p1 prest)) 63 | (0 -1d0) 64 | (1 0d0) 65 | (2 1d0) 66 | (3 (rv:draw* 'truncated-normal :mu mean :sigma sd 67 | :left -1d0 :right 1d0)))))) 68 | 69 | (define-updater (armodel real-roots :vector-index i) 70 | (real-roots complex-roots real-probabilities variance x) 71 | "Updater for real roots." 72 | (let+ ((poly (poly* (roots->polynomial real-roots :real i) 73 | (roots->polynomial complex-roots :complex))) 74 | (w (filter x poly)) 75 | (y (take 'numeric-vector (slice w '(1 -1)))) 76 | (x (take 'numeric-vector (slice w '(0 -2)))) 77 | ((&values beta qr nil) (least-squares y x)) 78 | (var (* variance (xref (least-squares-raw-variance qr) 0 0)))) 79 | (draw-real-root (xref beta 0) var real-probabilities))) 80 | 81 | (define-updater (armodel complex-roots :vector-index i) 82 | (real-roots complex-roots complex-probabilities variance x) 83 | "Updater for complex roots." 84 | (let+ ((poly (poly* (roots->polynomial real-roots :real i) 85 | (roots->polynomial complex-roots :complex))) 86 | (w (filter x poly)) 87 | (y 88 | -------------------------------------------------------------------------------- /tests/samplers.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package :cl-bayesian-tests) 4 | 5 | (deftestsuite samplers-tests (cl-bayesian-tests) 6 | ()) 7 | 8 | (defun 2phase-posterior (n accumulator posterior-function) 9 | "Return two posteriors, the first accumulated in 2 sweeps, the first in 10 | one." 11 | (let* ((v (generate-array (* 2 n) (generator (r-normal)))) 12 | (acc1 (sweep (funcall accumulator) (subseq v 0 n))) 13 | (acc2 (sweep (funcall accumulator) (subseq v n))) 14 | (acc (sweep (funcall accumulator) v)) 15 | (posterior1 (funcall posterior-function acc1)) 16 | (posterior2 (funcall posterior-function acc2 posterior1))) 17 | (values posterior2 (funcall posterior-function acc)))) 18 | 19 | (defun simulate-ranks (prior simulate estimate parameters 20 | &key (n 500) (m 50)) 21 | "Draw a value from PRIOR, call (SIMULATE DRAW) to simulate data, 22 | then (ESTIMATE DATA PRIOR) to estimate the posterior. Obtain N draws from the 23 | latter, and return empirical ranks. PARAMETERS is used to convert 24 | prior/posterior draws to vectors." 25 | (generate-array m 26 | (lambda () 27 | (let+ ((theta0 (draw prior)) 28 | (y (funcall simulate theta0)) 29 | (posterior (funcall estimate y prior)) 30 | (theta+ (generate-array n (generator posterior)))) 31 | (calculate-empirical-ranks (funcall parameters theta0) 32 | (combine 33 | (map1 parameters theta+))))))) 34 | 35 | (addtest (samplers-tests) 36 | univariate-normal-error-2phase 37 | (let+ (((&values p12 p) (2phase-posterior 10 #'mean-sse-accumulator 38 | #'univariate-normal-error)) 39 | (ranks+ 40 | (simulate-ranks (r-inverse-chi-square 9 2d0) 41 | (lambda (v) 42 | (generate-array 50 (generator (r-normal 0 v)))) 43 | (lambda (y prior) 44 | (univariate-normal-error 45 | (sweep (mean-sse-accumulator) y) 46 | prior)) 47 | #'vector)) 48 | (z-statistics (calculate-abs-z-statistics ranks+))) 49 | (ensure-same p12 p :test #'==) 50 | (format t "z-statistics: ~A~%" z-statistics) 51 | (ensure (< (first* z-statistics) 3d0)))) 52 | 53 | (addtest (samplers-tests) 54 | univariate-normal-model-2phase 55 | (let+ (((&values p12 p) (2phase-posterior 10 #'mean-sse-accumulator 56 | #'univariate-normal-model)) 57 | (prior (univariate-normal-model 58 | (sweep (mean-sse-accumulator) (ivec 10)))) 59 | (ranks+ 60 | (simulate-ranks prior 61 | (lambda+ (model-draw) 62 | (generate-array 50 (generator model-draw))) 63 | (lambda (y prior) 64 | (univariate-normal-model 65 | (sweep (mean-sse-accumulator) y) 66 | prior)) 67 | (lambda (p) 68 | (vector (mean p) (variance p))))) 69 | (z-statistics (calculate-abs-z-statistics ranks+))) 70 | (ensure-same p12 p :test #'==) 71 | (format t "z-statistics: ~A~%" z-statistics) 72 | (ensure (< (emax z-statistics) 3d0)))) 73 | 74 | (addtest (samplers-tests) 75 | lr-kv-dummy-2phase 76 | (let+ ((k 2) 77 | (n 10) 78 | ((&values y x) (cl-random-tests:random-y-x (* 2 n) k)) 79 | (variance 7) 80 | ;; single step 81 | (p2 (lr-kv y x variance)) 82 | ;; two steps, first half 83 | (h1 (cons 0 n)) 84 | (p1 (lr-kv (sub y h1) (sub x h1 t) variance)) 85 | ;; second half, using first half as prior 86 | (h2 (cons n nil)) 87 | (p2-1 (lr-kv (sub y h2) (sub x h2 t) variance :prior p1))) 88 | (ensure-same (mean p2) (mean p2-1)) 89 | (ensure-same (variance p2) (variance p2-1)))) 90 | 91 | (addtest (samplers-tests) 92 | lr-kv-small 93 | (let+ ((x (dense 'lla-double 94 | (1 1) 95 | (1 2) 96 | (1 3) 97 | (1 4) 98 | (1 5) 99 | (1 6) 100 | (1 7))) 101 | (y (vec 'lla-double 2 2 3 4 5 6 6)) 102 | (sd 19d0) 103 | (lr (lr-kv y x (expt sd 2))) 104 | ((&accessors-r/o mean variance) lr) 105 | (x-t (e/ x sd)) 106 | (y-t (e/ y sd))) 107 | (ensure-same mean (solve (mm t x-t) (mm (transpose x-t) y-t))) 108 | (ensure-same variance (invert (mm t x-t))))) 109 | 110 | (addtest (samplers-tests) 111 | multivariate-normal-model 112 | (let+ ((*lift-equality-test* #'==) 113 | (k 2) 114 | (n 10) 115 | (y (generate-array (list (* 2 n) k) (curry #'random 10d0) 116 | 'double-float)) 117 | ;; single step 118 | (p2 (multivariate-normal-model y)) 119 | ;; ;; two steps 120 | (p1 (multivariate-normal-model (sub y (cons 0 n) t))) 121 | (p2-1 (multivariate-normal-model (sub y (cons n nil) t) 122 | :prior p1)) 123 | (ranks 124 | (simulate-ranks p2 125 | (lambda+ (model-draw) 126 | (combine (generate-array 50 127 | (generator model-draw)))) 128 | (lambda (y prior) 129 | (multivariate-normal-model y :prior prior)) 130 | (lambda (p) 131 | (concat 'double-float 132 | (mean p) 133 | (flatten-array 134 | (as-array (variance p)))))))) 135 | (ensure-same (mean p2) (mean p2-1)) 136 | (ensure-same (nu p2) (nu p2-1)) 137 | (ensure-same (as-matrix (inverse-scale p2)) (inverse-scale p2-1)) 138 | (ensure-same (kappa p2) (kappa p2-1)) 139 | (ensure (small-zs? (calculate-abs-z-statistics ranks))))) 140 | 141 | -------------------------------------------------------------------------------- /src/samplers.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-bayesian) 4 | 5 | (defun univariate-normal-error (accumulator &optional (prior 0)) 6 | "Univariate normal error model. Sum of squared errors and the tally are 7 | taken from accumulator. The following priors are accepted: 8 | 9 | - r-inverse-gamma distributions 10 | 11 | - real numbers, corresponding to an inverse-gamma(prior,0) distribution in 12 | the limit (which, of course, may not be proper). Eg prior=0 is usually 13 | used as a reference prior." 14 | (let+ (((&values a b) (aetypecase prior 15 | (r-inverse-gamma (values (alpha it) (beta it))) 16 | (real (values it 0))))) 17 | (r-inverse-gamma (+ (/ (tally accumulator) 2d0) a) 18 | (+ (/ (sum-of-squares accumulator) 2d0) b)))) 19 | 20 | ;;;; **************************************************************** 21 | ;;;; Normal-inverse-chi-square distribution. 22 | ;;;; 23 | ;;;; 24 | ;;;; 25 | ;;;; 26 | ;;;; **************************************************************** 27 | 28 | (cl-random::define-rv r-univariate-normal-model (mu kappa alpha beta) 29 | (:documentation "Posterior distributions for univariate normal model -- the 30 | draws themselves are normal distributions, with sigma^2 ~ 31 | inverse-gamma(alpha,beta) and m ~ N(mu,s^2/kappa). This rv is also a 32 | conjugate prior for univariate normal data. See BDA, Section 3.3. The 33 | reparametrization here is alpha=nu/2 and beta=nu*s^2/2." 34 | :==-slots (mu kappa sigma-square)) 35 | ((mu :type double-float :reader t) 36 | (kappa :type double-float :reader t) 37 | (sigma-square :type r-inverse-gamma)) 38 | (cl-random::with-doubles (mu kappa alpha beta) 39 | (cl-random::make :mu mu :kappa kappa 40 | :sigma-square (r-inverse-gamma alpha beta))) 41 | (draw (&key) 42 | (let ((s^2 (draw sigma-square))) 43 | (r-normal (draw (r-normal mu (/ s^2 kappa))) s^2)))) 44 | 45 | (define-indirect-accessors r-univariate-normal-model 46 | r-univariate-normal-model-sigma-square s^2 nu alpha beta) 47 | 48 | (defun univariate-normal-model (accumulator &optional prior) 49 | (let+ (((&accessors-r/o (n tally) mean sse) accumulator) 50 | ((&values mu0 kappa0 alpha0 beta0) 51 | (aetypecase prior 52 | (r-univariate-normal-model 53 | (values (mu it) (kappa it) (alpha it) (beta it))) 54 | (null 55 | (values 0d0 0d0 -0.5d0 0d0)))) 56 | (kappa (+ kappa0 n)) 57 | (mu (/ (+ (* kappa0 mu0) (* n mean)) kappa)) 58 | (alpha (+ alpha0 (/ n 2))) 59 | (beta (+ beta0 (/ (+ sse (/ (* kappa0 n (expt (- mean mu0) 2)) 60 | kappa)) 61 | 2)))) 62 | (r-univariate-normal-model mu kappa alpha beta))) 63 | 64 | 65 | 66 | ;; (defun variance-distribution (ss n prior) 67 | ;; "When residuals ~ NIID(0,variance), return a posterior distribution for the 68 | ;; variance with the given prior. SS is the sum of squared residuals, and N is 69 | ;; the number of observations. Possible priors are: 70 | 71 | ;; :REFERENCE -- p(variance) \propto 1/variance 72 | 73 | ;; :HIERARCHICAL -- p(variance) \propto (variance)^-1/2, recommended by 74 | ;; Gelman (2006) for hierarchical models with at least 3 groups, as a first 75 | ;; attempt. 76 | 77 | ;; :NONE -- no prior, just gives the likelihood (may not be proper)." 78 | ;; (let* ((alpha (+ (/ n 2d0) 79 | ;; (ecase prior 80 | ;; (:none -1d0) 81 | ;; (:hierarchical -0.5d0) 82 | ;; (:reference 0d0))))) 83 | ;; (r-inverse-gamma alpha (/ ss 2d0)))) 84 | 85 | ;;; linear regression with known variance 86 | ;;; 87 | ;;; Not used frequently in practice, but useful for Gibbs sampling. Return a 88 | ;;; multivariate normal, which is the posterior of the coefficients. 89 | 90 | (defun lr-kv-dummies (prior) 91 | "Return dummy observations as (Y . X) for the given prior, for use in a 92 | linear regression with known variance (LR-KV)." 93 | (check-type prior r-multivariate-normal) 94 | (let+ (((&accessors-r/o mean variance-left-sqrt) prior)) 95 | (cons (solve variance-left-sqrt mean) 96 | (invert variance-left-sqrt)))) 97 | 98 | (defun lr-kv (y x variance &key prior) 99 | "Linear regression of Y on X with known VARIANCE for the errors (a single 100 | scalar is accepted, in which case it is used as a diagonal matrix). Use 101 | LR-KV-DUMMIES to generate dummy observations from a prior." 102 | (let+ ((x (as-regression-covariates x)) 103 | ((&values y-transformed x-transformed) (transform-y-x y x variance)) 104 | ((&values y-transformed x-transformed) 105 | (add-regression-dummies y-transformed x-transformed prior 106 | #'lr-kv-dummies)) 107 | ((&values beta &ign &ign qr) 108 | (least-squares y-transformed x-transformed :method :qr))) 109 | (r-multivariate-normal beta (invert-xx qr)))) 110 | 111 | ;;; multivariate normal model 112 | ;;; 113 | ;;; 114 | 115 | (defclass multivariate-normal-model () 116 | ((inverse-scale :accessor inverse-scale :initarg :inverse-scale) 117 | (nu :reader nu :initarg :nu :documentation "Degrees of freedom.") 118 | (kappa :reader kappa :initarg :kappa :documentation "Number of 119 | observations (including dummies from prior, does not have to be an 120 | integer).") 121 | (mean :reader mean :initarg :mean :documentation "Posterior mean.")) 122 | (:documentation "Random variable representing the posterior for a 123 | multivariate normal distribution estimated with unknown variance, reference 124 | or conjugate prior. Second value returned is Sigma, the variance matrix.")) 125 | 126 | (defun multivariate-normal-model (y &key prior) 127 | "Estimate a multivariate normal model. See p85-88 of Bayesian Data 128 | Analysis, 2nd edition. If prior is not given, the reference prior is used." 129 | (declare (optimize debug)) 130 | (let+ (((n nil) (array-dimensions y)) 131 | ((&values sse mean) (matrix-sse y)) 132 | ((&values mu0 kappa0 nu0 inverse-scale0) 133 | (aetypecase prior 134 | (multivariate-normal-model 135 | (values (mean it) (kappa it) (nu it) (inverse-scale it))) 136 | (null 137 | (values nil 0d0 -1 nil)))) 138 | (kappa (+ kappa0 n)) 139 | (nu (+ nu0 n)) 140 | (mu (e+ (e* (/ kappa0 kappa) mu0) (e* (/ n kappa) mean))) 141 | (inverse-scale (e+ inverse-scale0 142 | sse 143 | (outer (e* (e- mean mu0) 144 | (sqrt (/ (* kappa0 n) kappa))) 145 | t)))) 146 | (make-instance 'multivariate-normal-model :inverse-scale inverse-scale 147 | :nu nu :kappa kappa :mean mu))) 148 | 149 | (defmethod draw ((multivariate-normal-model multivariate-normal-model) &key) 150 | (let+ (((&slots-r/o inverse-scale nu kappa mean) multivariate-normal-model) 151 | (sigma (draw (r-inverse-wishart nu inverse-scale))) 152 | (mean (draw (r-multivariate-normal mean sigma) :scale (/ kappa)))) 153 | (r-multivariate-normal mean sigma))) 154 | 155 | ;;; discrete/categorical 156 | 157 | (defun binomial-model (count total &optional prior) 158 | "Simple (conjugate prior) model for binomial counts." 159 | (let+ (((&values alpha beta) 160 | (etypecase prior 161 | (null (values 1 1)) 162 | (r-beta (values (alpha prior) (beta prior)))))) 163 | (r-beta (+ count alpha) (+ (- total count) beta)))) 164 | 165 | (defun multinomial-model (counts &optional prior) 166 | "Simple (conjugate prior) model for multinomial counts." 167 | (let ((alpha 168 | (etypecase prior 169 | (null (make-array (length counts) :initial-element 1d0 170 | :element-type 'double-float)) 171 | (r-dirichlet (aprog1 (alpha prior) 172 | (assert (length= it counts))))))) 173 | (r-dirichlet (e+ alpha counts))) 174 | ) 175 | -------------------------------------------------------------------------------- /tests/dlm.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-bayesian-tests) 4 | 5 | (deftestsuite dlm-tests (cl-bayesian-tests) ()) 6 | 7 | ;; (addtest (dlm-tests) 8 | ;; uddu 9 | ;; (let* ((a (mm t (clo :double 1 2 :/ 3 4))) 10 | ;; (a-uddu (uddu a)) 11 | ;; (h (mm t (clo :double 3 5 :/ 7 11))) 12 | ;; (g (clo :double 9 2 :/ 17 4)) 13 | ;; (*lift-equality-test* #'==)) 14 | ;; (ensure-same (as-matrix a-uddu) a) 15 | ;; (ensure-same (as-array a-uddu) (as-array a)) 16 | ;; (ensure-same (as-matrix (uddu-update a-uddu h)) (e+ a h)) 17 | ;; (ensure-same (as-matrix (uddu-update a-uddu h t)) (e+ a h)) 18 | ;; (ensure-same (as-matrix (uddu-multiply-update a g h)) 19 | ;; (convert-matrix :hermitian (e+ (mmm g a (transpose g)) h))))) 20 | 21 | (addtest (dlm-tests) 22 | dlm1-test1 23 | ;; checked against results from R/dlm, univariate case 24 | (let+ ((n 10) 25 | (W 0.7d0) 26 | (dlm (make-dlm (dlm-evolution1 :W W) (dlm-observation1 :V 0.5d0) 27 | :length n)) 28 | (y (generate-array 10 1d0)) 29 | ((&values mC aR) 30 | (dlm-forward-filtering (r-normal 0d0 W) dlm y)) 31 | (*lift-equality-test* #'==)) 32 | (ensure-same (map1 #'mean mC) 33 | #(0.5833333 0.8603352 0.9544295 0.9851741 0.9951780 34 | 0.9984318 0.9994900 0.9998341 0.9999461 0.9999825)) 35 | (ensure-same (map1 #'mean aR) 36 | #(0.0000000 0.5833333 0.8603352 0.9544295 0.9851741 37 | 0.9951780 0.9984318 0.9994900 0.9998341 0.9999461)) 38 | (ensure-same (map1 #'sd mC) 39 | #(0.5400617 0.5765434 0.5803942 0.5808015 0.5808446 40 | 0.5808491 0.5808496 0.5808497 0.5808497 0.5808497)))) 41 | 42 | ;; (addtest (dlm-tests) 43 | ;; dlm-test1 44 | ;; ;; checked against results from R/dlm, univariate case 45 | ;; (let+ ((n 10) 46 | ;; (W 0.7d0) 47 | ;; (evolution+ (generate-array (1- n) (dlm-evolution1 :W W))) 48 | ;; (parameters (make-dlm-parameters :g 1 :W 0.7 :mu 0 :F 1 :V 0.5)) 49 | ;; (y (make-array 10 :initial-element #(1))) 50 | ;; ((&values m C-inverse a) 51 | ;; (dlm-forward-filtering #(0) (dlm-parameters-W parameters) y 52 | ;; (make-array 10 :initial-element parameters))) 53 | ;; (*lift-equality-test* #'==)) 54 | ;; (ensure-same (map1 #'first* m) 55 | ;; #(0.5833333 0.8603352 0.9544295 0.9851741 0.9951780 56 | ;; 0.9984318 0.9994900 0.9998341 0.9999461 0.9999825)) 57 | ;; (ensure-same (map1 #'first* a) 58 | ;; #(0.0000000 0.5833333 0.8603352 0.9544295 0.9851741 59 | ;; 0.9951780 0.9984318 0.9994900 0.9998341 0.9999461)) 60 | ;; (ensure-same (map1 (compose #'/ #'first* #'elements #'uddu-d) C-inverse) 61 | ;; #(0.5400617 0.5765434 0.5803942 0.5808015 0.5808446 62 | ;; 0.5808491 0.5808496 0.5808497 0.5808497 0.5808497)) 63 | ;; (ensure (every (curry #'== #2A((1d0))) 64 | ;; (map1 #'uddu-u C-inverse))))) 65 | 66 | ;; (addtest (dlm-tests) 67 | ;; dlm-test2 68 | ;; ;; checked against results from R/dlm, bivariate case 69 | ;; (let+ ((parameters (make-dlm-parameters :g (clo 1 1 :/ 70 | ;; 0 1) 71 | ;; :W (clo :diagonal 0.7 0.9) 72 | ;; :mu (clo 0 0) 73 | ;; :F (clo 1 1) 74 | ;; :V 0.5)) 75 | ;; (y (make-array 10 :initial-element #(1))) 76 | ;; ((&values m C-inverse a) 77 | ;; (dlm-forward-filtering #(0 0) (dlm-parameters-W parameters) y 78 | ;; (make-array 10 :initial-element parameters))) 79 | ;; (C (map1 #'invert C-inverse)) 80 | ;; (*lift-equality-test* #'==)) 81 | ;; (ensure-same (combine m) 82 | ;; (clo :double 83 | ;; 0.3333333 0.4285714286 :/ 84 | ;; 0.6898470 0.3379694019 85 | ;; 0.8907515 0.1594623492 86 | ;; 0.9720953 0.0563039370 87 | ;; 0.9968717 0.0145656823 88 | ;; 1.0017594 0.0017499744 89 | ;; 1.0015519 -0.0008421624 90 | ;; 1.0007590 -0.0007769082 91 | ;; 1.0002779 -0.0003851931 92 | ;; 1.0000760 -0.0001424831)) 93 | ;; (ensure-same (combine a) 94 | ;; (clo :double 95 | ;; 0.0000000 0.0000000000 :/ 96 | ;; 0.7619048 0.4285714286 97 | ;; 1.0278164 0.3379694019 98 | ;; 1.0502138 0.1594623492 99 | ;; 1.0283992 0.0563039370 100 | ;; 1.0114373 0.0145656823 101 | ;; 1.0035094 0.0017499744 102 | ;; 1.0007098 -0.0008421624 103 | ;; 0.9999821 -0.0007769082 104 | ;; 0.9998927 -0.0003851931)) 105 | ;; (ensure-same (combine (map1 (compose #'elements #'uddu-d) C)) 106 | ;; (clo :double 107 | ;; 0.4353537 0.8896176 :/ 108 | ;; 0.4612531 1.0088823 109 | ;; 0.4634060 1.0358761 110 | ;; 0.4637999 1.0404274 111 | ;; 0.4638920 1.0409681 112 | ;; 0.4639081 1.0410140 113 | ;; 0.4639101 1.0410177 114 | ;; 0.4639103 1.0410184 115 | ;; 0.4639103 1.0410185 116 | ;; 0.4639103 1.0410186)) 117 | ;; (ensure-same (combine (map1 #'as-array C)) 118 | ;; (reshape '(10 2 2) 119 | ;; #(0.4666667 -0.3000000 120 | ;; -0.3000000 0.5142857 121 | ;; 0.5909597 -0.4018081 122 | ;; -0.4018081 0.6396384 123 | ;; 0.6155682 -0.4282114 124 | ;; -0.4282114 0.6722163 125 | ;; 0.6189444 -0.4326606 126 | ;; -0.4326606 0.6786551 127 | ;; 0.6192684 -0.4331623 128 | ;; -0.4331623 0.6795420 129 | ;; 0.6192930 -0.4332006 130 | ;; -0.4332006 0.6796280 131 | ;; 0.6192960 -0.4332034 132 | ;; -0.4332034 0.6796345 133 | ;; 0.6192967 -0.4332040 134 | ;; -0.4332040 0.6796353 135 | ;; 0.6192969 -0.4332042 136 | ;; -0.4332042 0.6796354 137 | ;; 0.6192969 -0.4332042 138 | ;; -0.4332042 0.6796355))))) 139 | 140 | ;;; auxilirary functions for testing backward sampling 141 | 142 | 143 | (defun dlm-flatten-theta (theta+) 144 | (flatten-array (combine theta+ 'double-float) :copy? t)) 145 | 146 | (defun remove-observations (vector &optional (missing-probability 0.05d0)) 147 | "Return elements, replacing each one with NIL with the given probability. 148 | Used for testing." 149 | (map1 (lambda (v) 150 | (unless (< (random 1d0) missing-probability) 151 | v)) 152 | vector)) 153 | 154 | (defun dlm-simulate-ranks (n aR dlm &key (missing-probability 0.05d0)) 155 | "Return a vector of empirical ranks of simulated data." 156 | (let+ (((&values state+ data+) (dlm-simulate aR dlm)) 157 | (data+ (remove-observations data+ missing-probability)) 158 | (draws (combine 159 | (generate-array n 160 | (lambda () 161 | (dlm-flatten-theta (dlm-ff-bs aR dlm data+))))))) 162 | (calculate-empirical-ranks (dlm-flatten-theta state+) draws))) 163 | 164 | (defun dlm-simulate-ranks+ (n-replications n-draws aR dlm 165 | &key (stream *standard-output*) 166 | (missing-probability 0.05d0)) 167 | "Return a vector of ranks which can be passed to 168 | calculate-abs-z-statistics." 169 | (let ((progress-bar (text-progress-bar stream n-replications))) 170 | (generate-array n-replications 171 | (lambda () 172 | (funcall progress-bar) 173 | (dlm-simulate-ranks n-draws aR dlm 174 | :missing-probability 175 | missing-probability))))) 176 | 177 | (addtest (dlm-tests) 178 | dlm-ff-bs-univariate 179 | (let* ((n 10) 180 | (dlm (make-dlm (dlm-evolution1 :mu 9d0 :W 0.05d0) 181 | (dlm-observation1 :V 0.02d0) 182 | :length n)) 183 | (ranks+ (dlm-simulate-ranks+ 100 200 (r-normal 0 2) dlm)) 184 | (z-statistics (calculate-abs-z-statistics ranks+))) 185 | (ensure (small-zs? z-statistics)))) 186 | 187 | 188 | ;; (addtest (dlm-tests) 189 | ;; dlm1-ff-bs 190 | ;; (let* ((parameters (make-dlm1-parameters :W 0.05d0 :V 0.02d0)) 191 | ;; (ranks+ (dlm-simulate-ranks+ 100 200 192 | ;; 0d0 193 | ;; 2d0 194 | ;; (make-array 10 :initial-element 195 | ;; parameters) 196 | ;; :univariate? t)) 197 | ;; (z-statistics (calculate-abs-z-statistics ranks+))) 198 | ;; (ensure (small-zs? z-statistics)))) 199 | 200 | ;; (addtest (dlm-tests) 201 | ;; dlm-ff-bs-bivariate 202 | ;; (let* ((parameters (make-dlm-parameters 203 | ;; :g (clo :double 204 | ;; 1 1 :/ 205 | ;; 0 1) 206 | ;; :mu (clo :double 0 0) 207 | ;; :w (clo :double :diagonal 0.05 0.03) 208 | ;; :f (clo :double 1 1 :/) 209 | ;; :v (clo :double :diagonal 0.02))) 210 | ;; (ranks+ (dlm-simulate-ranks+ 100 200 211 | ;; (clo :double 2 9) 212 | ;; (clo :diagonal 2 3) 213 | ;; (make-array 10 :initial-element 214 | ;; parameters))) 215 | ;; (z-statistics (calculate-abs-z-statistics ranks+))) 216 | ;; (ensure (small-zs? z-statistics)))) 217 | -------------------------------------------------------------------------------- /tests/chains.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-bayesian-tests) 4 | 5 | (deftestsuite diagnostics-tests (cl-bayesian-tests) ()) 6 | 7 | (addtest (diagnostics-tests) 8 | psrf-test 9 | ;; test the PSRF calculations on a known result (from R) 10 | (let+ ((n 100) 11 | (zeroes (make-array n :initial-element 0d0)) 12 | (ones (make-array n :initial-element 1d0)) 13 | (twos (make-array n :initial-element 2d0)) 14 | (s1 (concat 'double-float zeroes ones)) 15 | (s2 (concat 'double-float zeroes twos)) 16 | (psrf (calculate-psrf (mapcar (curry #'sweep 'sse) 17 | (list s1 s2))))) 18 | (ensure-same (psrf-r psrf) 1.284474) 19 | ;; (ensure-same r-upper 2.190318) 20 | )) 21 | 22 | ;;; We test by calculating the statistics for IID random elements. 23 | 24 | (defstruct iid-model 25 | "For testing MCMC diagnostics." 26 | (n 5) 27 | (generator (generator (r-normal)))) 28 | 29 | (defmethod scalar-parameters-layout ((model iid-model)) 30 | (array-layout (iid-model-n model))) 31 | 32 | (defmethod draw ((model iid-model) &key) 33 | ;; usually we there are no DRAW methods for models, but in the IID case it 34 | ;; makes sense 35 | (let+ (((&structure-r/o iid-model- n generator) model)) 36 | (make-iid-state :model model :elements (generate-array n generator)))) 37 | 38 | (defstruct iid-state 39 | "For testing MCMC diagnostics. Of course not a state in the actual sense." 40 | model 41 | elements) 42 | 43 | (defmethod model ((state iid-state)) 44 | (iid-state-model state)) 45 | 46 | (defmethod draw ((state iid-state) &key) 47 | (let+ (((&structure-r/o iid-state- model) state)) 48 | (draw model))) 49 | 50 | (defmethod scalar-parameters ((state iid-state) &key copy?) 51 | (maybe-copy-array (iid-state-elements state) copy?)) 52 | 53 | (addtest (diagnostics-tests) 54 | mcmc-statistics-test 55 | (let+ ((model (make-iid-model)) 56 | (sample (draw-chain (draw model) 50 :stream nil)) 57 | (burn-in 20) 58 | (columns* (subarrays 1 (transpose 59 | (combine (map1 #'iid-state-elements 60 | sample))))) 61 | (columns (map1 (lambda (c) (subseq c burn-in)) columns*)) 62 | (lags 4) 63 | (accumulator-generator #'mean-sse-accumulator) 64 | (statistics 65 | (mcmc-statistics sample :divisions 3 :minimum-length 0 :lags lags 66 | :accumulator-generator accumulator-generator 67 | :burn-in-fraction (/ burn-in (length sample)))) 68 | ((&slots-r/o sse-ranges) statistics) 69 | (*lift-equality-test* #'==)) 70 | ;; accumulators for columns 71 | (ensure-same (accumulators statistics) 72 | (map1 (lambda (s) (sweep (funcall accumulator-generator) s)) 73 | columns)) 74 | ;; sse accumulators 75 | (iter 76 | (for column :in-vector columns*) 77 | (for sse-accumulator :in-vector (sse-accumulators statistics)) 78 | (let* ((accumulators (map 'vector (lambda+ ((start . end)) 79 | (sweep (mean-sse-accumulator) 80 | (subseq column start end))) 81 | sse-ranges))) 82 | (ensure-same sse-accumulator accumulators))) 83 | ;; autocovariance accumulators 84 | (ensure-same (autocovariance-accumulators statistics) 85 | (map1 (lambda (v) 86 | (sweep (autocovariance-accumulator lags) v)) 87 | columns)))) 88 | 89 | (addtest (diagnostics-tests) 90 | mcmc-statistics-test2 91 | ;; In this test the period after burn-in is not composed of the apparent 92 | ;; sse-ranges, the purpose of this test is to see if the statistics are 93 | ;; calculated correctly. 94 | (let+ ((n-sample 200) 95 | (n-parameters 2) 96 | (model (make-iid-model :n n-parameters)) 97 | (sample (draw-chain (draw model) n-sample :stream nil)) 98 | (burn-in (floor n-sample 3)) 99 | (sse-ranges #((20 . 40) (60 . 120) (100 . 180))) 100 | (lags 5) 101 | ((&slots-r/o (model2 model) (sse-ranges2 sse-ranges) 102 | autocovariance-accumulators sse-accumulators) 103 | (mcmc-statistics sample :sse-ranges sse-ranges :lags lags 104 | :burn-in-fraction (/ burn-in n-sample))) 105 | ((&flet+ sweep-with-accumulators 106 | ((start . end) accumulator-generator) 107 | (let ((acc (generate-array n-parameters accumulator-generator))) 108 | (loop for sample-index from start below end do 109 | (loop for p across (iid-state-elements 110 | (aref sample sample-index)) 111 | for a across acc 112 | do (add a p))) 113 | acc))) 114 | (*lift-equality-test* #'==) 115 | (partial-matrix (combine sse-accumulators))) 116 | (iter 117 | (for sse-range :in-vector sse-ranges :with-index index) 118 | (ensure-same (sub partial-matrix t index) 119 | (sweep-with-accumulators sse-range 120 | #'mean-sse-accumulator))) 121 | (ensure-same model model2 :test #'eq) 122 | (ensure-same sse-ranges sse-ranges2 123 | :test #'equalp) 124 | (ensure-same autocovariance-accumulators 125 | (sweep-with-accumulators (cons burn-in n-sample) 126 | (curry #'autocovariance-accumulator 127 | lags))) 128 | partial-matrix)) 129 | 130 | (addtest (diagnostics-tests) 131 | mcmc-summary-test 132 | ;; testing mcmc summaries for univariate samples built from stencils 133 | (let+ ((burn-in-fraction 0.4) 134 | (lag 10) 135 | (model (make-iid-model :n 1)) 136 | ((&flet make-sample (stencil &key (model model) (n 600)) 137 | "Return a sample of length N by repeating STENCIL." 138 | (iter 139 | (with stencil := (map 'vector #'vector stencil)) 140 | (with stencil-length := (length stencil)) 141 | (for index :below n) 142 | (collect 143 | (make-iid-state :model model 144 | :elements (aref stencil (mod index stencil-length))) 145 | :result-type vector)))) 146 | (samples (mapcar #'make-sample 147 | '((0 -1 0 0) 148 | (1 2 0 0) 149 | (3 5 7 11 13 17)))) 150 | (columns (mapcar (lambda (s) 151 | (map1 (compose #'first* #'iid-state-elements) 152 | (subseq s 153 | (cl-bayesian::calculate-burn-in 154 | (length s) burn-in-fraction)))) 155 | samples)) 156 | (crude-mean (mean (stack* t :v columns))) 157 | (crude-autocorrelations (mean (map1 (rcurry #'autocorrelations lag) 158 | columns))) 159 | (statistics 160 | (mapcar (lambda (s) 161 | (mcmc-statistics s :burn-in-fraction burn-in-fraction)) 162 | samples)) 163 | (summary (summarize-mcmc-statistics statistics)) 164 | ((&flet summarize-incompatible-chains (&rest arguments) 165 | (summarize-mcmc-statistics 166 | (list (first statistics) 167 | (mcmc-statistics (apply #'make-sample '(1) arguments) 168 | :burn-in-fraction burn-in-fraction))))) 169 | (*lift-equality-test* #'==)) 170 | ;; check mean and autocovariance 171 | (ensure-same (map1 #'mean (accumulators summary)) (vector crude-mean)) 172 | (ensure-same (mean-autocorrelations summary) (vector crude-autocorrelations)) 173 | ;; incompatible chains should give errors 174 | (ensure-error (summarize-incompatible-chains :model (make-iid-model :n 2))) 175 | (ensure-error (summarize-incompatible-chains :n 977)))) 176 | 177 | 178 | ;;; old implementation of psrf working directly with sequences saved here for 179 | ;;; comparison and testing purposes 180 | ;;; 181 | ;; (defun psrf-direct (sequences &key (confidence 0.975d0) skip-length-check?) 182 | ;; "Estimate the potential scale reduction factor. Algorithm is from Gelman and 183 | ;; Rubin (1992), but the degrees of freedom correction is according to Brooks and 184 | ;; Gelman (1998)." 185 | ;; ;; !!! should return the upper limit of the confidence interval as the second 186 | ;; ;; value. Since the F distribution is not implemented yet, this functionality 187 | ;; ;; is not available now. 188 | ;; (declare (ignore confidence)) 189 | ;; (let ((m (length sequences)) 190 | ;; (n (length (aref sequences 0)))) 191 | ;; (unless skip-length-check? 192 | ;; (assert (every (lambda (sequence) (= (length sequence) n)) 193 | ;; (subseq sequences 1)))) 194 | ;; (iter 195 | ;; (for sequence :in-vector sequences) 196 | ;; (let ((mean (mean sequence))) 197 | ;; (collecting mean :into means :result-type vector) 198 | ;; (collecting (variance sequence) 199 | ;; :into variances :result-type vector)) 200 | ;; (finally 201 | ;; (let* ((mu (mean means)) 202 | ;; (b (* n (variance means))) 203 | ;; (w (mean variances)) 204 | ;; (var-b (/ (* 2 (expt b 2)) (1- m))) 205 | ;; (var-w (/ (variance variances) m)) 206 | ;; (1+1/m (1+ (/ m))) 207 | ;; (n-1 (1- n)) 208 | ;; (V (/ (+ (* n-1 w) (* 1+1/m b)) n)) 209 | ;; (var-V (/ (+ (* (expt n-1 2) var-w) 210 | ;; (* (expt 1+1/m 2) var-b) 211 | ;; (* 2 1+1/m n-1 (/ n m) 212 | ;; (- (covariance-xy variances (eexpt means 2)) 213 | ;; (* 2 mu (covariance-xy variances means))))) 214 | ;; (expt n 2))) 215 | ;; (df (/ (* 2 (expt V 2)) var-V)) 216 | ;; (df-adj (/ (+ df 3) (1+ df))) 217 | ;; ;; (b-df (1- m)) 218 | ;; ;; (w-df (/ (* 2 (expt w 2)) var-w)) 219 | ;; (R^2-fixed (/ n-1 n)) 220 | ;; (R^2-random (* (/ 1+1/m n) (/ b w)))) 221 | ;; (d:p "we are in PSRF2~%") 222 | ;; (d:v n means variances b var-b var-w var-V df-adj) 223 | ;; (return (sqrt (* df-adj (+ R^2-fixed R^2-random))))))))) 224 | 225 | -------------------------------------------------------------------------------- /src/mosaic.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-bayesian) 4 | 5 | (defgeneric pack-slots (mapping target object) 6 | (:documentation "")) 7 | 8 | (defgeneric unpack-slots (mapping source object) 9 | (:argument-precedence-order object source mapping) 10 | (:documentation "") 11 | (:method (mapping source (class standard-class)) 12 | (unpack-slots mapping source (make-instance class))) 13 | (:method (mapping source (symbol symbol)) 14 | (unpack-slots mapping source (make-instance symbol)))) 15 | 16 | (defstruct (mosaic (:constructor make-mosaic%)) 17 | "A mosaic is a mapping that packs arrays of any dimension into a flat 18 | vector (the size of which can be obtained with MOSAIC-SIZE)." 19 | (keys nil :type vector :read-only t) 20 | (table nil :type hash-table :read-only t) 21 | (size nil :type fixnum :read-only t)) 22 | 23 | (defun make-mosaic (keys-and-dimensions) 24 | "Create a mosaic from a sequence of (cons key dimensions)." 25 | (let* ((table (make-hash-table :test #'equal)) 26 | (offset 0) 27 | (keys (map 'vector 28 | (lambda (key-and-dimensions) 29 | (let+ (((key . dimensions) 30 | (ensure-list key-and-dimensions)) 31 | ((&values nil present?) (gethash key table))) 32 | (assert (not present?) () "Duplicate key ~A." key) 33 | (prog1 key 34 | (setf (gethash key table) (cons offset dimensions)) 35 | (incf offset (product dimensions))))) 36 | keys-and-dimensions))) 37 | (make-mosaic% :keys keys :table table :size offset))) 38 | 39 | (defun template-mosaic (keys-and-objects) 40 | "Create a mosaic using objects as a template." 41 | (make-mosaic (map 'vector (lambda+ ((key . object)) 42 | (cons key 43 | (if (arrayp object) 44 | (array-dimensions object) 45 | nil))) 46 | keys-and-objects))) 47 | 48 | (defmacro template-mosaic-symbols (&rest keys) 49 | "Convenience macro for templating a mosaic on keys or (key variable)." 50 | `(template-mosaic 51 | (list ,@(mapcar (lambda (key) 52 | (let+ (((key &optional (form key)) (ensure-list key))) 53 | `(cons ',key ,form))) 54 | keys)))) 55 | 56 | (defun mosaic-location (mosaic key &optional subscripts) 57 | "Return (CONS OFFSET DIMENSIONS). Read-only, consequences are undefined if 58 | modified." 59 | (let+ (((&values value present?) (gethash key (mosaic-table mosaic)))) 60 | (assert present? () "Key ~A not found." key) 61 | (if subscripts 62 | (let+ (((&values offset dimensions) 63 | (subarray-location (cdr value) subscripts))) 64 | (cons (+ (car value) offset) dimensions)) 65 | value))) 66 | 67 | (defmethod print-object ((mosaic mosaic) stream) 68 | (if *print-readably* 69 | (call-next-method) 70 | (print-unreadable-object (mosaic stream :type t) 71 | (format stream "size: ~A" (mosaic-size mosaic)) 72 | (map nil (lambda (key) 73 | (let+ (((offset . dimensions) 74 | (mosaic-location mosaic key))) 75 | (format stream "~&~4T~A ~:A [~A]" key dimensions offset))) 76 | (mosaic-keys mosaic))))) 77 | 78 | (defun mosaic-displace-vector (mosaic key vector) 79 | (let+ (((offset . dimensions) (mosaic-location mosaic key))) 80 | (displace-array vector dimensions offset))) 81 | 82 | (defmethod pack-slots ((mosaic mosaic) (vector vector) 83 | (object standard-object)) 84 | (assert (length= vector (mosaic-size mosaic))) 85 | (map nil (lambda (key) 86 | (let+ (((offset . dimension) (mosaic-location mosaic key)) 87 | (value (slot-value object key))) 88 | (if dimension 89 | (progn 90 | (assert (equal dimension (array-dimensions value))) 91 | (replace vector (flatten-array value) :start1 offset)) 92 | (setf (aref vector offset) value)))) 93 | (mosaic-keys mosaic)) 94 | object) 95 | 96 | (defun mosaic-unpack-key (mosaic vector key) 97 | (let+ (((offset . dimension) (mosaic-location mosaic key))) 98 | (if dimension 99 | (clnu:maybe-copy-array 100 | (displace-array vector dimension offset) nil) 101 | (aref vector offset)))) 102 | 103 | (defmethod unpack-slots :before ((mosaic mosaic) (vector vector) object) 104 | (assert (length= vector (mosaic-size mosaic)))) 105 | 106 | (defmethod unpack-slots ((mosaic mosaic) (vector vector) 107 | (object standard-object)) 108 | (map nil (lambda (key) 109 | (setf (slot-value object key) 110 | (mosaic-unpack-key mosaic vector key))) 111 | (mosaic-keys mosaic)) 112 | object) 113 | 114 | (defmethod unpack-slots ((mosaic mosaic) (vector vector) 115 | (object (eql :alist))) 116 | (loop for key across (mosaic-keys mosaic) 117 | collect (cons key (mosaic-unpack-key mosaic vector key)))) 118 | 119 | (defgeneric mosaic (object) 120 | (:documentation "Return mosaic of object.")) 121 | 122 | (defclass mosaic-with-elements (simple-print-object-mixin) 123 | ((mosaic :initarg :mosaic :type mosaic :reader mosaic) 124 | (elements :initarg :elements :type matrix :reader elements)) 125 | (:documentation "Base structure for a mosaic and associated elements.")) 126 | 127 | (defclass mosaic-matrix (mosaic-with-elements) 128 | () 129 | (:documentation "A matrix with a mosaic indexing the columns.")) 130 | 131 | (defmethod nrow ((matrix mosaic-matrix)) 132 | (nrow (elements matrix))) 133 | 134 | (defun make-mosaic-matrix (mosaic nrow-or-matrix 135 | &rest make-array-arguments 136 | &key (element-type t element-type?) 137 | (initial-element nil initial-element?)) 138 | "Make a mosaic matrix. Keyword arguments are passed on to make-array. When 139 | the second argument is a matrix, it is used (without copying), but the 140 | consistency with mosaic is checked." 141 | (declare (ignorable initial-element)) 142 | (let ((size (mosaic-size mosaic))) 143 | (make-instance 'mosaic-matrix 144 | :mosaic mosaic 145 | :elements (aetypecase nrow-or-matrix 146 | (array-length 147 | (apply #'make-array 148 | (list it size) 149 | make-array-arguments)) 150 | (matrix 151 | (assert (or (not element-type?) 152 | (equalp (upgraded-array-element-type element-type) 153 | (array-element-type nrow-or-matrix)))) 154 | (assert (not initial-element?)) 155 | it))))) 156 | 157 | (defclass mosaic-vector (mosaic-with-elements) 158 | ((elements :type vector))) 159 | 160 | (defun make-mosaic-vector (mosaic &rest make-array-arguments 161 | &key (element-type t) initial-element 162 | initial-contents) 163 | "Make a mosaic vector. Keyword arguments are passed on to make-array." 164 | (declare (ignorable element-type initial-element initial-contents)) 165 | (make-instance 'mosaic-vector 166 | :mosaic mosaic 167 | ;; FIXME: use semantics like make-mosaic-matrix 168 | :elements (apply #'make-array (mosaic-size mosaic) 169 | make-array-arguments))) 170 | 171 | 172 | (defmethod pack-slots ((mosaic-matrix mosaic-matrix) (row fixnum) object) 173 | (let+ (((&slots-r/o mosaic elements) mosaic-matrix)) 174 | (pack-slots mosaic (subarray elements row) object))) 175 | 176 | (defmethod unpack-slots ((mosaic-matrix mosaic-matrix) (row fixnum) object) 177 | (let+ (((&slots-r/o mosaic elements) mosaic-matrix)) 178 | (unpack-slots mosaic (subarray elements row) object))) 179 | 180 | (defmethod sub ((mosaic-matrix mosaic-matrix) &rest selections) 181 | (let+ (((row-selection key-selection &rest subscripts) selections) 182 | ((&slots-r/o mosaic elements) mosaic-matrix) 183 | ((nrow ncol) (array-dimensions elements)) 184 | (row-selection (sub-resolve-selection row-selection nrow t))) 185 | (if (eq key-selection t) 186 | (let ((elements (sub elements row-selection t))) 187 | (if (vectorp elements) 188 | (make-instance 'mosaic-vector :mosaic mosaic :elements elements) 189 | (make-instance 'mosaic-matrix :mosaic mosaic :elements elements))) 190 | (let+ (((offset . dimensions) 191 | (mosaic-location mosaic key-selection subscripts)) 192 | ((&flet extract (row-index) 193 | (if dimensions 194 | (displace-array elements dimensions 195 | (+ offset (* ncol row-index))) 196 | (aref elements row-index offset))))) 197 | (if (fixnum? row-selection) 198 | (extract row-selection) 199 | (if dimensions 200 | (map 'vector #'extract row-selection) 201 | (sub elements row-selection offset))))))) 202 | 203 | (defmethod sub ((mosaic-vector mosaic-vector) &rest selections) 204 | (let+ (((key-selection &rest subscripts) selections) 205 | ((&slots-r/o mosaic elements) mosaic-vector)) 206 | (if (eq key-selection t) 207 | mosaic-vector 208 | (let+ (((offset . dimensions) 209 | (mosaic-location mosaic key-selection subscripts))) 210 | (if dimensions 211 | (displace-array elements dimensions offset) 212 | (aref elements offset)))))) 213 | 214 | (defmethod map-columns (function (matrix mosaic-matrix) 215 | &key element-type) 216 | (let+ (((&slots-r/o mosaic elements) matrix)) 217 | (make-instance 'mosaic-matrix 218 | :mosaic mosaic 219 | :elements (map-columns function elements 220 | :element-type element-type)))) 221 | 222 | (defmethod map-rows (function (matrix mosaic-matrix) 223 | &key (element-type t) (mosaic nil mosaic?)) 224 | (let+ ((result (map-rows function (elements matrix) 225 | :element-type element-type))) 226 | (when (eq mosaic t) 227 | (setf mosaic (mosaic matrix))) 228 | (if (and (typep result 'matrix) mosaic?) 229 | (make-mosaic-matrix mosaic result) 230 | result))) 231 | 232 | (defmethod quantiles ((matrix mosaic-matrix) qs) 233 | (map-columns (lambda (c) (quantiles c qs)) matrix)) 234 | 235 | ;; (defclass foo () 236 | ;; ((a :accessor a :initarg :a) 237 | ;; (b :accessor b :initarg :b) 238 | ;; (c :accessor c :initarg :c))) 239 | 240 | ;; (defparameter *m* (make-mosaic '((a 1) (b 2 3) c))) 241 | 242 | ;; (defparameter *f* (make-instance 'foo :a #(1) :b #2A((3 5 7) (13 11 19)) :c 9)) 243 | 244 | ;; (defparameter *g* (make-instance 'foo)) 245 | 246 | ;; (defparameter *v* (make-array (mosaic-size *m*))) 247 | 248 | ;; (pack-slots *m* *v* *f*) 249 | ;; (unpack-slots *m* *v* (find-class 'foo)) 250 | ;; (unpack-slots *m* *v* ('foo)) 251 | 252 | ;; (type-of (find-class 'foo)) 253 | 254 | ;; (standard-object) 255 | ;; (standard-class) 256 | 257 | ;; (make-instance 'foo) 258 | -------------------------------------------------------------------------------- /src/chains.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-bayesian) 4 | 5 | (defparameter *suggested-minimum-burn-in* 200 6 | "The suggested minimum number of observations discarded as burn-in. Using 7 | less than this generates a warning.") 8 | 9 | (defparameter *default-burn-in-fraction* 0.5 10 | "The default fraction of observations discarded as burn-in.") 11 | 12 | (defun check-burn-in (burn-in) 13 | "Check that burn-in is above the suggested minimum (when defined). Does not 14 | return a value, called for side effects (conditions)." 15 | (when (and *suggested-minimum-burn-in* 16 | (< burn-in *suggested-minimum-burn-in*)) 17 | (warn "Burn-in ~A is below suggested minimum burn-in (~A)." 18 | burn-in *suggested-minimum-burn-in*)) 19 | (values)) 20 | 21 | (defun calculate-burn-in (n &optional (burn-in-fraction *default-burn-in-fraction*)) 22 | "Calculate burn-in from burn-in fraction and total number of samples. 23 | Note: efined as a separate function for consistency of rounding." 24 | (assert (within? 0 burn-in-fraction 1)) 25 | (ceiling (* n burn-in-fraction))) 26 | 27 | (defgeneric discard-burn-in (sample &optional burn-in-fraction) 28 | (:documentation "Discard the burn-in from the sample.") 29 | (:method ((sample vector) 30 | &optional (burn-in-fraction *default-burn-in-fraction*)) 31 | (subseq sample (calculate-burn-in (length sample) burn-in-fraction))) 32 | (:method ((sample mosaic-matrix) 33 | &optional (burn-in-fraction *default-burn-in-fraction*)) 34 | (sub sample 35 | (cons 0 (calculate-burn-in (nrow sample) burn-in-fraction)) t))) 36 | 37 | ;; (defstruct psrf 38 | ;; "Potential scale reduction factor." 39 | ;; r 40 | ;; v 41 | ;; w) 42 | 43 | ;; (defun calculate-psrf (accumulators &key (confidence 0.975d0)) 44 | ;; "Estimate the potential scale reduction factor. Algorithm is from Gelman 45 | ;; and Rubin (1992), but the degrees of freedom correction is according to Brooks 46 | ;; and Gelman (1998)." 47 | ;; ;; !!! should return the upper limit of the confidence interval as the 48 | ;; ;; second value. Since the F distribution is not implemented yet in 49 | ;; ;; cl-random, this functionality is not available now. 50 | ;; (declare (ignore confidence)) 51 | ;; (let+ ( ;; length and number of chains 52 | ;; (m (length accumulators)) 53 | ;; (n (common accumulators :key #'tally)) 54 | ;; ;; means and variances for each 55 | ;; (means (map1 #'mean accumulators)) 56 | ;; (variances (map1 #'variance accumulators)) 57 | ;; ;; calculate psrf 58 | ;; ((&accessors (mu mean) (var-m variance)) (sweep 'sse means)) 59 | ;; (b (* n var-m)) 60 | ;; ((&accessors (w mean) (var-v variance)) (sweep 'sse variances)) 61 | ;; (var-b (/ (* 2 (expt b 2)) (1- m))) 62 | ;; (var-w (/ var-v m)) 63 | ;; (1+1/m (1+ (/ m))) 64 | ;; (n-1 (1- n)) 65 | ;; (V (/ (+ (* n-1 w) (* 1+1/m b)) n)) 66 | ;; (var-V (/ (+ (* (expt n-1 2) var-w) 67 | ;; (* (expt 1+1/m 2) var-b) 68 | ;; (* 2 1+1/m n-1 (/ n m) 69 | ;; (- (covariance-xy variances (eexpt means 2)) 70 | ;; (* 2 mu (covariance-xy variances means))))) 71 | ;; (expt n 2))) 72 | ;; (df (/ (* 2 (expt V 2)) var-V)) 73 | ;; (df-adj (/ (+ df 3) (1+ df))) 74 | ;; ;; (b-df (1- m)) 75 | ;; ;; (w-df (/ (* 2 (expt w 2)) var-w)) 76 | ;; (R^2-fixed (/ n-1 n)) 77 | ;; (R^2-random (* (/ 1+1/m n) (/ b w)))) 78 | ;; (make-psrf :R (sqrt (* df-adj (+ R^2-fixed R^2-random))) 79 | ;; :V V 80 | ;; :W w))) 81 | 82 | ;; (defun calculate-psrf-ranges (n 83 | ;; &key (divisions 20) 84 | ;; (burn-in-fraction *default-burn-in-fraction*) 85 | ;; (minimum-length 100)) 86 | ;; "Calculate ranges for PSRF. Return as a list of (start . end) values. 87 | ;; Ranges narrower than MINIMUM-LENGTH are discarded." 88 | ;; (iter 89 | ;; (for division from 1 to divisions) 90 | ;; (let* ((end (ceiling (* division n) divisions)) 91 | ;; (start (floor (* end burn-in-fraction)))) 92 | ;; (when (<= (+ start minimum-length) end) 93 | ;; (collect (cons start end)))))) 94 | 95 | ;; (defclass mcmc-statistics () 96 | ;; ((model :accessor model :initarg :model) 97 | ;; (accumulators :accessor accumulators :initarg :accumulators 98 | ;; :documentation "Vector of accumulators for columns of 99 | ;; scalars.") 100 | ;; (autocovariance-accumulators :initarg :autocovariance-accumulators 101 | ;; :accessor autocovariance-accumulators 102 | ;; :documentation "Vector of autocovariance 103 | ;; accumulators for each variable.") 104 | ;; (sse-ranges :initarg :sse-ranges :accessor sse-ranges) 105 | ;; (sse-accumulators :initarg :sse-accumulators :accessor sse-accumulators 106 | ;; :documentation "Vector of partial mean-sse 107 | ;; accumulators for each variable.")) 108 | ;; (:documentation "Statistics for the sample from a single MCMC chain.")) 109 | 110 | ;; (defun mcmc-statistics (sample 111 | ;; &key (divisions 20) (minimum-length 100) 112 | ;; sse-ranges (lags 10) 113 | ;; (accumulator-generator #'mean-sse-accumulator) 114 | ;; (burn-in-fraction *default-burn-in-fraction*)) 115 | ;; "Helper function to calculate an MCMC-STATISTICS object from a sample." 116 | ;; (let+ ((model (model (first* sample))) 117 | ;; (n-parameters (layout-length (scalar-parameters-layout model))) 118 | ;; (n-sample (length sample)) 119 | ;; (accumulators (generate-array n-parameters accumulator-generator)) 120 | ;; (autocovariance-accumulators 121 | ;; (generate-array n-parameters (curry #'autocovariance-accumulator lags))) 122 | ;; (sse-ranges (aif sse-ranges 123 | ;; it 124 | ;; (calculate-psrf-ranges 125 | ;; n-sample 126 | ;; :divisions divisions 127 | ;; :minimum-length minimum-length 128 | ;; :burn-in-fraction burn-in-fraction))) 129 | ;; (burn-in (calculate-burn-in n-sample burn-in-fraction)) 130 | ;; ((&values subranges index-lists) 131 | ;; (subranges sse-ranges :shadow-ranges `((,burn-in . ,n-sample)))) 132 | ;; (sse-accumulators 133 | ;; (combine 134 | ;; (map 'vector 135 | ;; (lambda+ ((start . end)) 136 | ;; (let ((sse-accumulators 137 | ;; (generate-array n-parameters #'mean-sse-accumulator))) 138 | ;; (loop for sample-index from start below end do 139 | ;; (let+ (((&accessors-r/o scalar-parameters) 140 | ;; (aref sample sample-index))) 141 | ;; (iter 142 | ;; (for parameter :in-vector scalar-parameters 143 | ;; :with-index parameter-index) 144 | ;; (for sse-accumulator :in-vector sse-accumulators) 145 | ;; (add sse-accumulator parameter) 146 | ;; (when (<= burn-in sample-index) 147 | ;; (add (aref accumulators parameter-index) 148 | ;; parameter) 149 | ;; (add (aref autocovariance-accumulators 150 | ;; parameter-index) 151 | ;; parameter))))) 152 | ;; sse-accumulators)) 153 | ;; subranges))) 154 | ;; (sse-accumulators 155 | ;; (map1 (lambda (accumulators) 156 | ;; (iter 157 | ;; (for index-list :in-vector index-lists) 158 | ;; (let ((accumulators (sub accumulators 159 | ;; (coerce index-list 'vector)))) 160 | ;; (collect (pool* accumulators) :result-type vector)))) 161 | ;; (subarrays 1 (transpose sse-accumulators))))) 162 | ;; ;; check burn-in 163 | ;; (check-burn-in burn-in) 164 | ;; ;; return results 165 | ;; (make-instance 'mcmc-statistics 166 | ;; :model model 167 | ;; :accumulators accumulators 168 | ;; :autocovariance-accumulators autocovariance-accumulators 169 | ;; :sse-ranges sse-ranges 170 | ;; :sse-accumulators sse-accumulators))) 171 | 172 | ;; (defclass mcmc-summary () 173 | ;; ((model :accessor model :initarg :model) 174 | ;; (psrf :accessor psrf :initarg :psrf) 175 | ;; (psrf-ranges :accessor psrf-ranges :initarg :psrf-ranges) 176 | ;; (accumulators :accessor accumulators :initarg :accumulators) 177 | ;; (mean-autocorrelations :accessor mean-autocorrelations 178 | ;; :initarg :mean-autocorrelations))) 179 | 180 | ;; (defun summarize-mcmc-statistics (mcmc-statistics) 181 | ;; "Calculate summaries of column statistics." 182 | ;; (let+ ((mcmc-statistics (coerce mcmc-statistics 'vector)) 183 | ;; (model (common-model mcmc-statistics)) 184 | ;; (sse-ranges (common mcmc-statistics :key #'sse-ranges :test #'equalp 185 | ;; :error "SSE ranges are not compatible.")) 186 | ;; ((&flet pool-chains (accessor transformation reduction) 187 | ;; ;; Extract vector of statistics from each chain using ACCESSOR, 188 | ;; ;; apply TRANSFORMATION, then pool them using REDUCTION 189 | ;; (map1 190 | ;; reduction 191 | ;; (subarrays 1 192 | ;; (map1 transformation 193 | ;; (transpose 194 | ;; (combine (map1 accessor 195 | ;; mcmc-statistics)))))))) 196 | ;; ;; psrf 197 | ;; (variance-accumulators 198 | ;; (permute 199 | ;; (combine (map1 (compose #'combine #'sse-accumulators) 200 | ;; mcmc-statistics)) 201 | ;; '(1 2 0))) 202 | ;; (psrf (map1 #'calculate-psrf 203 | ;; (subarrays 2 variance-accumulators))) 204 | ;; ;; autocorrelations 205 | ;; (mean-autocorrelations 206 | ;; (pool-chains #'autocovariance-accumulators 207 | ;; #'autocorrelations 208 | ;; #'mean)) 209 | ;; ;; pooled accumulators 210 | ;; (accumulators (pool-chains #'accumulators #'identity #'pool*))) 211 | ;; (assert sse-ranges) 212 | ;; (make-instance 'mcmc-summary 213 | ;; :model model :psrf psrf 214 | ;; :accumulators accumulators 215 | ;; :mean-autocorrelations mean-autocorrelations 216 | ;; :psrf-ranges sse-ranges))) 217 | 218 | ;; (defun pool-samples (samples &key (burn-in-fraction *default-burn-in-fraction*)) 219 | ;; "Pool MCMC samplers, discarding BURN-IN-FRACTION." 220 | ;; ;; does not check model 221 | ;; (stack* t :v 222 | ;; (map 'list 223 | ;; (lambda (sample) 224 | ;; (subseq sample 225 | ;; (calculate-burn-in (length sample) burn-in-fraction))) 226 | ;; samples))) 227 | 228 | ;; (defun psrf-summary-quantiles (mcmc-statistics-summary 229 | ;; &key (quantiles #(0d0 0.025d0 0.25d0 0.5d0 230 | ;; 0.75d0 0.975d0 1d0))) 231 | ;; (let ((r (map1 #'psrf-r (psrf mcmc-statistics-summary))) 232 | ;; (q (combine (map1 (quantile))))) 233 | ;; ) 234 | ;; ) 235 | 236 | ;;; - functions that pool samples should just verify that they point to the 237 | ;;; same model and be done with it 238 | 239 | ;; (defclass mcmc-chains () 240 | ;; ((mcmc-class :accessor mcmc-class :initarg :mcmc-class :documentation 241 | ;; "Class used for creating MCMC instances.") 242 | ;; (initargs :accessor initargs :initarg :initargs :documentation 243 | ;; "Initial arguments used for creating MCMC instances.") 244 | ;; (parameters-ix :accessor parameters-ix :initarg :parameters-ix 245 | ;; :documentation "Index for the parameter vectors.") 246 | ;; (chains :accessor chains :initarg :chains :documentation 247 | ;; "Chains, always holding the current state.") 248 | ;; (chain-results :accessor chain-results :initarg :chain-results 249 | ;; :type simple-vector 250 | ;; :documentation "Matrices holding the chain-results.") 251 | ;; (burn-in :accessor burn-in :initarg :burn-in 252 | ;; :documentation "Burn-in, used to discard start of the sequence 253 | ;; before inference.") 254 | ;; (pooled-parameters :accessor pooled-parameters :documentation 255 | ;; "Pooled parameters."))) 256 | 257 | ;; (defun run-mcmc-chains (m n mcmc-class initargs &key (burn-in (floor n 2)) 258 | ;; (thin 1)) 259 | ;; "Run M MCMC chains, each of length N, with given class and initargs." 260 | ;; (iter 261 | ;; (with parameters-ix) 262 | ;; (for chain-index :below m) 263 | ;; (format t "Running chain ~A/~A~%" chain-index (1- m)) 264 | ;; (let ((mcmc (apply #'make-instance mcmc-class initargs))) 265 | ;; (collecting (run-mcmc mcmc n :burn-in 0 :thin thin) 266 | ;; :result-type vector :into chain-results) 267 | ;; (collecting mcmc :result-type vector :into chains) 268 | ;; (when (first-iteration-p) 269 | ;; (setf parameters-ix (parameters-ix mcmc))) 270 | ;; (finally 271 | ;; (return 272 | ;; (make-instance 'mcmc-chains 273 | ;; :chains chains 274 | ;; :chain-results chain-results 275 | ;; :initargs initargs 276 | ;; :parameters-ix parameters-ix 277 | ;; :mcmc-class mcmc-class 278 | ;; :burn-in burn-in)))))) 279 | 280 | 281 | 282 | 283 | ;; (defun chains-psrf (mcmc-chains &key (divisions 20) (burn-in-fraction 2)) 284 | ;; "Calculate the potential scale reduction factor for " 285 | ;; (let+ (((&slots-r/o chain-results) mcmc-chains) 286 | ;; ((n k) (array-dimensions (aref chain-results 0))) 287 | ;; (limits (iter 288 | ;; (for index :from 1 :to divisions) 289 | ;; (collecting (ceiling (* n index) divisions) 290 | ;; :result-type vector))) 291 | ;; (psrf-matrix (make-array (list divisions k)))) 292 | ;; (dotimes (param-index k) 293 | ;; (let ((sequences (map 'vector (lambda (chain) (sub chain t param-index)) 294 | ;; chain-results))) 295 | ;; (iter 296 | ;; (for limit :in-vector limits :with-index limit-index) 297 | ;; (let* ((start (floor limit burn-in-fraction)) 298 | ;; (sequences (map 'vector (lambda (sequence) 299 | ;; (subseq sequence start limit)) 300 | ;; sequences))) 301 | ;; (setf (aref psrf-matrix limit-index param-index) 302 | ;; (psrf sequences)))))) 303 | ;; (values limits psrf-matrix))) 304 | 305 | ;; (defun calculate-pooled-parameters (mcmc-chains &key (start (burn-in mcmc-chains)) 306 | ;; (end (nrow (aref (chain-results mcmc-chains) 0)))) 307 | ;; "Combine MCMC chains into a single matrix, preserving column structure. 308 | ;; START and END mark the iterations used." 309 | ;; (let+ ((chain-length (- end start)) 310 | ;; ((&slots-r/o chain-results) mcmc-chains) 311 | ;; (m (length chain-results)) 312 | ;; (first-chain (aref chain-results 0)) 313 | ;; (pooled (make-array 314 | ;; (list (* chain-length m) (ncol first-chain)) 315 | ;; :element-type (array-element-type first-chain)))) 316 | ;; (iter 317 | ;; (for chain :in-vector chain-results) 318 | ;; (for end-row :from chain-length :by chain-length) 319 | ;; (for start-row :previous end-row :initially 0) 320 | ;; (setf (sub pooled (si start-row end-row) t) 321 | ;; (sub chain (si start end) t))) 322 | ;; pooled)) 323 | 324 | ;; (defmethod slot-unbound (class (instance mcmc-chains) 325 | ;; (slot-name (eql 'pooled-parameters))) 326 | ;; (setf (slot-value instance 'pooled-parameters) 327 | ;; (calculate-pooled-parameters instance))) 328 | -------------------------------------------------------------------------------- /src/dlm.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-bayesian) 4 | 5 | ;;;; DLM specification 6 | 7 | (defstruct (dlm-evolution1 (:constructor dlm-evolution1)) 8 | "Evolution equation for DLM, univariate case. state' ~ N(G*state+mu,W)." 9 | (G 1d0 :type double-float) 10 | (mu 0d0 :type double-float) 11 | (W 1d0 :type double-float)) 12 | 13 | (defstruct (dlm-observation1 (:constructor dlm-observation1)) 14 | "Observation equation for DLM, univariate case. data ~ N(F*state,V)." 15 | (F 1d0 :type double-float) 16 | (V 1d0 :type double-float)) 17 | 18 | (defstruct (dlm (:constructor make-dlm%)) 19 | "Specification for a dynamic linear model." 20 | evolution+ observation+) 21 | 22 | (defun dlm-length (dlm) 23 | "Return the length of a DLM." 24 | (length (dlm-observation+ dlm))) 25 | 26 | (defun checked-dlm-length (dlm &rest vectors) 27 | "Return the length of a DLM, checking consistency." 28 | (let ((n (dlm-length dlm))) 29 | (loop for v in vectors do 30 | (check-type v vector) 31 | (assert (= n (length v)))) 32 | n)) 33 | 34 | (defun make-dlm (evolution+ observation+ 35 | &key (length 36 | (cond 37 | ((vectorp evolution+) (1+ (length evolution+))) 38 | ((vectorp observation+) (length observation+)) 39 | (t (error "Can't infer length when the other ~ 40 | arguments are not vectors."))))) 41 | "Create a dynamic linear model. Objects other than vectors are accepted and 42 | will be recycled appropriately. LENGTH should be specified when none of the 43 | other arguments are vectors." 44 | (flet ((ensure-vector (object length) 45 | (if (vectorp object) 46 | (prog1 object 47 | (assert (= length (length object)))) 48 | (make-array length :initial-element object)))) 49 | (make-dlm% :evolution+ (ensure-vector evolution+ (1- length)) 50 | :observation+ (ensure-vector observation+ length)))) 51 | 52 | (defun sub-dlm (dlm start &optional (end (dlm-length dlm))) 53 | "Return a contiguous part of a DLM." 54 | (let+ (((&structure-r/o dlm- evolution+ observation+) dlm)) 55 | (make-dlm% :evolution+ (subseq evolution+ start (1- end)) 56 | :observation+ (subseq observation+ start end)))) 57 | 58 | ;;;; single-step building blocks for recursive methods 59 | 60 | (defgeneric dlm-step (mC evolution) 61 | (:documentation "Return the updated distribution.") 62 | (:method ((mc r-normal) (evolution dlm-evolution1)) 63 | (let+ (((&accessors-r/o (m mean) (C variance)) mC) 64 | ((&structure-r/o dlm-evolution1- G mu W) evolution)) 65 | (r-normal (+ (* G m) mu) 66 | (+ W (* (expt G 2) C)))))) 67 | 68 | (defgeneric dlm-filter (aR observation data) 69 | (:documentation "Given a prior, an observation (equation) and the 70 | corresponding data point, return the posterior.") 71 | (:method ((aR r-normal) (observation dlm-observation1) (data real)) 72 | (let+ ((data (coerce data 'double-float)) 73 | ((&structure-r/o dlm-observation1- F V) observation) 74 | ((&accessors-r/o (a mean) (R variance)) aR) 75 | (forecast (* F a)) 76 | (F/V (/ F V)) 77 | (C (/ (+ (/ R) (* F F/V)))) 78 | (gain (* F/V C))) 79 | (r-normal (+ a (* gain (- data forecast))) C))) 80 | (:method (prior observation (data null)) 81 | prior)) 82 | 83 | (defgeneric dlm-sample (mC evolution next-draw next-aR) 84 | (:documentation "Sample backward, returning a draw.") 85 | (:method ((mC r-normal) (evolution dlm-evolution1) (next-draw real) 86 | (next-aR r-normal)) 87 | (let+ (((&structure-r/o dlm-evolution1- G W) evolution) 88 | ((&accessors-r/o (m mean) (C variance)) mC) 89 | ((&accessors-r/o (next-a mean)) next-aR) 90 | (G/W (/ G W)) 91 | (H (/ (+ (/ C) (* G G/W)))) 92 | (B (* G/W H))) 93 | (draw (r-normal (+ m (* B (- next-draw next-a))) H))))) 94 | 95 | ;;;; user interface 96 | ;;; 97 | ;;; The convention for argument order should be 98 | ;;;; aR evolution+ observation+ data+ theta+ 99 | 100 | (defun dlm-forward-filtering (initial-distribution dlm data+) 101 | "Forward filtering for univariate dynamic linear models." 102 | (let+ (((&structure-r/o dlm- evolution+ observation+) dlm) 103 | (n (checked-dlm-length dlm data+)) 104 | (distribution initial-distribution) 105 | (aR+ (make-array n)) 106 | (mC+ (make-array n))) 107 | (iter 108 | (for observation :in-vector observation+ :with-index index) 109 | (for data :in-vector data+) 110 | (when (plusp index) 111 | (setf distribution (dlm-step distribution 112 | (aref evolution+ (1- index))))) 113 | (setf (aref aR+ index) distribution 114 | distribution (dlm-filter distribution observation data) 115 | (aref mC+ index) distribution)) 116 | (values mC+ aR+))) 117 | 118 | (defun dlm-backward-sampling (dlm mC+ aR+) 119 | "Backward sampling. Requires the output of dlm-forward-filtering and the 120 | parameters. Returns a vector of draws. For univariate DLMs." 121 | (let+ (((&structure-r/o dlm- evolution+) dlm) 122 | (n (checked-dlm-length dlm mC+ aR+)) 123 | (theta+ (make-array n)) 124 | (last (1- n)) 125 | (theta (draw (aref mC+ last)))) 126 | (setf (aref theta+ last) theta) 127 | (iter 128 | (for evolution :in-vector evolution+ :from (1- last) :downto 0 129 | :with-index index) 130 | (setf theta (dlm-sample (aref mC+ index) evolution theta 131 | (aref aR+ (1+ index))) 132 | (aref theta+ index) theta)) 133 | theta+)) 134 | 135 | (defun dlm-ff-bs (initial-distribution dlm data+) 136 | "Forward filtering and backward sampling. Return (values theta+ m+ 137 | C-inverse+ a+)." 138 | (let+ (((&values mC+ aR+) 139 | (dlm-forward-filtering initial-distribution dlm data+))) 140 | (values (dlm-backward-sampling dlm mc+ ar+) mC+ aR+))) 141 | 142 | (defgeneric dlm-evolution-error (evolution state next-state) 143 | (:documentation "Calculate the evolution error (incudes MU).") 144 | (:method ((evolution dlm-evolution1) (state real) (next-state real)) 145 | (- next-state (* (dlm-evolution1-G evolution) state)))) 146 | 147 | (defgeneric dlm-observation-error (observation state data) 148 | (:documentation "Calculate the observation error.") 149 | (:method ((observation dlm-observation1) (state real) (data real)) 150 | (- data (* (dlm-observation1-F observation) state))) 151 | (:method (observation state (data null)) 152 | nil)) 153 | 154 | (defun dlm-errors (dlm data+ theta+) 155 | "Return vectors of the errors of the state equation (omega, with the mean mu 156 | which is *not* subtracted) and the observation equation (nu) as two values." 157 | (let+ (((&structure-r/o dlm- evolution+ observation+) dlm) 158 | (n (checked-dlm-length dlm data+ theta+)) 159 | (omega+ (make-array (1- n))) 160 | (nu+ (make-array n))) 161 | (iter 162 | (for theta :in-vector theta+ :with-index index) 163 | (for theta-p :previous theta) 164 | (for observation :in-vector observation+) 165 | (for data :in-vector data+) 166 | (unless (zerop index) 167 | (let ((index-p (1- index))) 168 | (setf (aref omega+ index-p) 169 | (dlm-evolution-error (aref evolution+ index-p) 170 | theta-p theta)))) 171 | (setf (aref nu+ index) (dlm-observation-error observation theta data))) 172 | (values omega+ nu+))) 173 | 174 | (defmethod draw ((evolution dlm-evolution1) &key state) 175 | (let+ (((&structure-r/o dlm-evolution1- G mu W) evolution)) 176 | (draw (r-normal (+ mu (* G state)) W)))) 177 | 178 | (defmethod draw ((observation dlm-observation1) &key state) 179 | (let+ (((&structure-r/o dlm-observation1- F V) observation)) 180 | (draw (r-normal (+ (* F state)) V)))) 181 | 182 | (defun dlm-simulate (aR dlm) 183 | "Generate a sample for a DLM with given parametes, drawing the first state 184 | from N(a,R). Return (values state+ data+). For univariate DLMs." 185 | (let+ (((&structure-r/o dlm- evolution+ observation+) dlm) 186 | (n (dlm-length dlm)) 187 | (state (draw aR)) 188 | (state+ (make-array n :element-type 'double-float)) 189 | (data+ (make-array n :element-type 'double-float))) 190 | (dotimes (index n) 191 | (unless (zerop index) 192 | (setf state (draw (aref evolution+ (1- index)) :state state))) 193 | (setf (aref state+ index) state 194 | (aref data+ index) (draw (aref observation+ index) :state state))) 195 | (values state+ data+))) 196 | 197 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 198 | ;;; multivariate dlm 199 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 200 | 201 | ;; (defstruct uddu 202 | ;; "Decomposition UD^2U^T where D is a diagonal and U is a unitary matrix." 203 | ;; u d) 204 | 205 | ;; (defun uddu (a) 206 | ;; "UDDU decomposition of hermitian matrix." 207 | ;; (check-type a hermitian-matrix) 208 | ;; (let+ (((&structure-r/o spectral-factorization- z w) 209 | ;; (spectral-factorization a))) 210 | ;; (make-uddu :u z :d (esqrt w)))) 211 | 212 | ;; (defmethod left-square-root ((a uddu)) 213 | ;; (mm (uddu-u a) (uddu-d a))) 214 | 215 | ;; (defmethod as-matrix ((a uddu)) 216 | ;; (mm (left-square-root a) t)) 217 | 218 | ;; (defmethod as-array ((a uddu) &key copy?) 219 | ;; (declare (ignore copy?)) 220 | ;; (as-array (as-matrix a))) 221 | 222 | ;; (defmethod invert ((a uddu) &key) 223 | ;; (let+ (((&structure-r/o uddu- u d) a)) 224 | ;; (make-uddu :u u :d (invert d)))) 225 | 226 | ;; (defun uddu-left-svd (l) 227 | ;; "Helper function to calculate the UDDU decomposition of LL^T, where L is not 228 | ;; necessarily square." 229 | ;; (let+ (((&structure-r/o svd- u d) (svd l :thin))) 230 | ;; (make-uddu :u u :d d))) 231 | 232 | ;; (defun uddu-update (a h &optional factorize?) 233 | ;; "Return the UDDU decomposition of A+H, where H is a Hermitian matrix (or 234 | ;; anything else with a representation that yields a left square root)." 235 | ;; (if factorize? 236 | ;; ;; method which first factorizes out U 237 | ;; (let+ (((&structure-r/o uddu- u d) a) 238 | ;; ((&structure-r/o svd- (u+ u) (d+ d)) 239 | ;; (svd (stack 'double-float :h 240 | ;; d (mm (transpose u) (left-square-root h))) :thin))) 241 | ;; (make-uddu :u (mm u u+) :d d+)) 242 | ;; ;; direct method 243 | ;; (uddu-left-svd (stack 'double-float :h 244 | ;; (left-square-root a) (left-square-root h))))) 245 | 246 | ;; (defun uddu-multiply-update (a g h) 247 | ;; "Return the UDDU decomposition of GAG^T+H, where A is an UDDU decomposition 248 | ;; and H is a hermitian matrix (in any representation that can yield a left 249 | ;; square root)." 250 | ;; (uddu-left-svd (stack 'double-float :h 251 | ;; (mm g (left-square-root a)) (left-square-root h)))) 252 | 253 | ;; (defstruct (dlm-parameters (:constructor make-dlm-parameters%)) 254 | ;; "We follow the notation of the Harrison and West (1997) book: 255 | 256 | ;; theta_t = G_t theta_{t-1} + omega_t, where omega_t ~ N(mu_t, W_t) 257 | 258 | ;; Y_t = F theta_t + nu_t, where nu_t ~ N(0,V_t) 259 | 260 | ;; W and V can be factorizations." 261 | ;; G mu W F V) 262 | 263 | ;; (defun make-dlm-parameters (&key G mu W F V) 264 | ;; "Create a DLM parameters structure, checking dimensions. Scalars are 265 | ;; converted to appropriate 1x1 matrices, and F may be a vector, interpeted as a 266 | ;; row matrix." 267 | ;; (let+ (((&flet ensure-variance (m) 268 | ;; (if (numberp m) 269 | ;; (clo :diagonal m) 270 | ;; m))) 271 | ;; (G (ensure-matrix G)) 272 | ;; (mu (ensure-vector mu)) 273 | ;; (W (ensure-variance W)) 274 | ;; (F (ensure-matrix F :row)) 275 | ;; (V (ensure-variance V))) 276 | ;; (assert (and (= (nrow G) (length mu) (nrow W) (ncol F)) 277 | ;; (= (nrow F) (nrow V)) 278 | ;; (square? G) (square? W) (square? V))) 279 | ;; (make-dlm-parameters% :g G :mu mu :w W :F F :V V))) 280 | 281 | ;; (defun dlm-filter (a R Y parameters) 282 | ;; "Given the prior N(a,R), the observation Y and the DLM parameters at that 283 | ;; point, calculate the posterior N(m,C). Return (values m C-inverse)." 284 | ;; (let+ (((&structure-r/o dlm-parameters- F V) parameters) 285 | ;; (F-transpose (transpose F)) 286 | ;; (forecast (mm F a)) ; mean forecast 287 | ;; (V-inverse (invert V)) 288 | ;; (C-inverse (uddu-update (invert R) 289 | ;; (xx (mm F-transpose 290 | ;; (left-square-root V-inverse))))) 291 | ;; (gain (mmm (invert C-inverse) F-transpose V-inverse))) 292 | ;; (values (e+ a (mm gain (e- Y forecast))) 293 | ;; C-inverse))) 294 | 295 | ;; (defun dlm-step (m C-inverse parameters) 296 | ;; "Given the posterior N(m,C), calculate the prior N(a,R) for the next step. 297 | ;; Return (values a R). This step should be called each point in time, before 298 | ;; incorporating observations (if any)." 299 | ;; (let+ (((&structure-r/o dlm-parameters- G mu W) parameters)) 300 | ;; (values (e+ (mm G m) mu) 301 | ;; (uddu-multiply-update (invert C-inverse) G W)))) 302 | 303 | ;; (defun dlm-sample (m C-inverse next-theta next-a next-parameters) 304 | ;; "Sample backward for DLM. Return a draw." 305 | ;; (let+ (((&structure-r/o dlm-parameters- G W) next-parameters) 306 | ;; (H-inverse (uddu-update C-inverse 307 | ;; (xx (mm (transpose G) 308 | ;; (left-square-root (invert W)))))) 309 | ;; (H (invert H-inverse)) 310 | ;; (B (mmm H (transpose G) (invert W)))) 311 | ;; (draw (r-multivariate-normal (e+ m (mm B (e- next-theta next-a))) 312 | ;; H)))) 313 | 314 | ;; (defun dlm-forward-filtering (a0 R0 y+ parameters+) 315 | ;; "Forward filtering for dynamic linear models. 316 | ;; Prior on the state is N(a,R), Y+ is a vector of observations, PARAMETERS is a 317 | ;; vector of DLM-PARAMETERs. Return the following values: 318 | 319 | ;; - m+, a vector of means 320 | ;; - C-inverse+, a vector of UDDU decompositions of C^{-1} 321 | ;; - a+, the predicted means" 322 | ;; (let* ((n (length y+)) 323 | ;; (m+ (make-array n)) 324 | ;; (C-inverse+ (make-array n)) 325 | ;; (a+ (make-array n))) 326 | ;; ;; forward filtering 327 | ;; (iter 328 | ;; (for parameters :in-vector parameters+ :with-index index) 329 | ;; (let+ (((&values a R) (if (zerop index) 330 | ;; (values a0 R0) 331 | ;; (let ((m (aref m+ (1- index))) 332 | ;; (C-inverse (aref C-inverse+ 333 | ;; (1- index)))) 334 | ;; (dlm-step m C-inverse parameters))))) 335 | ;; (setf (values (aref m+ index) (aref C-inverse+ index)) 336 | ;; (aif (aref y+ index) 337 | ;; (dlm-filter a R it parameters) 338 | ;; (values a (invert R))) 339 | ;; (aref a+ index) a))) 340 | ;; (values m+ C-inverse+ a+))) 341 | 342 | ;; (defun dlm-backward-sampling (m+ a+ C-inverse+ parameters+) 343 | ;; "Backward sampling. Requires the output of dlm-forward-filtering and the 344 | ;; parameters. Returns a vector of draws." 345 | ;; (let* ((n (length m+)) 346 | ;; (theta+ (make-array n)) 347 | ;; (last (1- n))) 348 | ;; (setf (aref theta+ last) 349 | ;; (draw (r-multivariate-normal (aref m+ last) 350 | ;; (invert (aref C-inverse+ last))))) 351 | ;; (iter 352 | ;; (for parameters :in-vector parameters+ :downto 1 :with-index index) 353 | ;; (setf (aref theta+ (1- index)) 354 | ;; (dlm-sample (aref m+ (1- index)) (aref C-inverse+ (1- index)) 355 | ;; (aref theta+ index) (aref a+ index) parameters))) 356 | ;; theta+)) 357 | 358 | ;; (defun dlm-ff-bs (a0 R0 y+ parameters+) 359 | ;; "Forward filtering and backward sampling. Return (values theta+ m+ 360 | ;; C-inverse+ a+)." 361 | ;; (let+ (((&values m+ C-inverse+ a+) 362 | ;; (dlm-forward-filtering a0 R0 y+ parameters+))) 363 | ;; (values (dlm-backward-sampling m+ a+ c-inverse+ parameters+) 364 | ;; m+ C-inverse+ a+))) 365 | 366 | ;; (defun dlm-errors (theta+ y+ parameters+) 367 | ;; "Return vectors of the errors of the state equation (omega, mean included) 368 | ;; and the observation equation (nu) as two values. Note that the first element 369 | ;; of OMEGA is NIL as it is not identified." 370 | ;; (let+ ((n (common-length theta+ y+ parameters+)) 371 | ;; ((&assert n)) 372 | ;; (omega (make-array n :initial-element nil)) 373 | ;; (nu (make-array n :initial-element nil))) 374 | ;; (iter 375 | ;; (for theta :in-vector theta+ :with-index index) 376 | ;; (for theta-p :previous theta) 377 | ;; (for parameters :in-vector parameters+) 378 | ;; (for y :in-vector y+) 379 | ;; (let+ (((&structure-r/o dlm-parameters- G F) parameters)) 380 | ;; (unless (zerop index) 381 | ;; (setf (aref omega index) (e- theta (mm G theta-p)))) 382 | ;; (when y 383 | ;; (setf (aref nu index) (e- y (mm F theta)))))) 384 | ;; (values omega nu))) 385 | 386 | ;; (defun dlm-simulate (a R parameters+) 387 | ;; "Generate a sample for a DLM with given parametes, drawing the first state 388 | ;; from N(a,R). Return (values theta+ y+)." 389 | ;; (let* ((n (length parameters+)) 390 | ;; (theta+ (make-array n)) 391 | ;; (y+ (make-array n))) 392 | ;; (dotimes (index n) 393 | ;; (let+ (((&structure-r/o dlm-parameters- G W mu F V) 394 | ;; (aref parameters+ index)) 395 | ;; (theta (if (zerop index) 396 | ;; (draw (r-multivariate-normal a R)) 397 | ;; (e+ (mm G (aref theta+ (1- index))) 398 | ;; (draw (r-multivariate-normal mu W)))))) 399 | ;; (setf (aref y+ index) 400 | ;; (draw (r-multivariate-normal (mm F theta) V)) 401 | ;; (aref theta+ index) theta))) 402 | ;; (values theta+ y+))) 403 | -------------------------------------------------------------------------------- /src/mcmc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-bayesian) 2 | 3 | ;;; general MCMC interface 4 | ;;; 5 | ;;; 6 | 7 | ;;; model 8 | 9 | (defgeneric start-chain (model &key &allow-other-keys) 10 | (:documentation "Initialize a Markov chain for drawing from MODEL, not 11 | necessarily in a deterministic manner; other arguments may be used to 12 | specify initial points or overdispersion.")) 13 | 14 | (defgeneric scalar-parameters-layout (model) 15 | (:documentation "Return a layout specification for scalar parameters. Has 16 | to be constant for the same model, regardless of the state or the chain.")) 17 | 18 | (defgeneric model (object) 19 | (:documentation "Return the corresponding model")) 20 | 21 | (defun common-model (objects) 22 | "Find the common model." 23 | (common objects :key #'model :test #'eq 24 | :error "Objects don't refer to the same model.")) 25 | 26 | (defgeneric scalar-parameters (state &key copy?) 27 | (:documentation "Return all scalar parameters as a vector. Element type, 28 | length and layout (see SCALAR-PARAMETERS-LAYOUT) have to be consistent for 29 | chains initialized from the same model. Does not necessarily contain all 30 | parameters, only those that make sense as scalars.")) 31 | 32 | ;;; default implementation, using a flat matrix 33 | 34 | (defmethod draw-chain (state n &key (stream *standard-output*) 35 | (progress-bar-length 80)) 36 | "Sample a vector of N draws the Markov chain defined by state. STREAM and 37 | PROGRESS-BAR-LENGTH govern the output of the progress bar (if not desired, set 38 | STREAM to NIL). Return the updated STATE as the second value. 39 | 40 | The sampling works via the method DRAW, which should be defined for the 41 | states." 42 | (let+ (((&fwrap progress) 43 | (text-progress-bar stream n 44 | :character #\* :length progress-bar-length)) 45 | (draws (make-array n))) 46 | (dotimes (index n) 47 | (setf (aref draws index) state 48 | state (draw state)) 49 | (progress)) 50 | (values draws state))) 51 | 52 | (defgeneric mosaic (object) 53 | (:documentation "")) 54 | 55 | (defun mcmc-mosaic-matrix (state n &key (stream *standard-output*) 56 | (progress-bar-length 80) 57 | (mosaic (mosaic state)) 58 | (element-type t)) 59 | ;; "Sample N draws the Markov chain defined by state. STREAM and 60 | ;; PROGRESS-BAR-LENGTH govern the output of the progress bar (if not desired, set 61 | ;; STREAM to NIL). Return the updated STATE as the second value. 62 | 63 | ;; The sampling works via the method DRAW, which should be defined for the 64 | ;; states." 65 | (let+ (((&fwrap progress) 66 | (text-progress-bar stream n 67 | :character #\* :length progress-bar-length)) 68 | (draws (make-mosaic-matrix mosaic n :element-type element-type))) 69 | (dotimes (index n) 70 | (pack-slots draws index state) 71 | (setf state (draw state)) 72 | (progress)) 73 | (values draws state))) 74 | 75 | 76 | ;;; Counter for Metropolis (and Metropolis-Hastings) steps. 77 | ;;; 78 | ;;; Counts the TOTAL and ACCEPTED number of steps. To reset the 79 | ;;; counter, simply create a new one. 80 | 81 | ;; (defclass acceptance-counter () 82 | ;; ((total :accessor total :initform 0) 83 | ;; (accepted :accessor accepted :initform 0))) 84 | 85 | ;; (defun acceptance-ratio (counter) 86 | ;; (with-slots (accepted total) counter 87 | ;; (if (zerop total) 88 | ;; nil 89 | ;; (coerce (/ accepted total) 'double-float)))) 90 | 91 | ;; (defmethod print-object ((counter acceptance-counter) stream) 92 | ;; (print-unreadable-object (counter stream :type t) 93 | ;; (with-slots (total accepted) counter 94 | ;; (format stream "~A/~A=~A" accepted total (acceptance-ratio counter))))) 95 | 96 | 97 | ;; (defun increment-counter (counter accepted-p) 98 | ;; (when accepted-p 99 | ;; (incf (accepted counter))) 100 | ;; (incf (total counter)) 101 | ;; (values)) 102 | 103 | ;;; MCMC macros. 104 | ;;; 105 | ;;; DEFINE-MCMC defines a class with the given parameter names, and 106 | ;;; also methods for generic functions RESET-COUNTERS, 107 | ;;; CURRENT-PARAMETERS (returns parameters for later processing) and 108 | ;;; UPDATE, which performs an updating step on all variables. 109 | ;;; 110 | ;;; The user needs to define (update-parameter class 'name) methods, 111 | ;;; which return the updated parameter value. Update calls these in 112 | ;;; turn, and takes care of assigning this to the slots. 113 | ;;; 114 | ;;; Slots can be atoms and vectors. The difference is that atoms are 115 | ;;; treated as an opaque object and updated as a block, while vectors 116 | ;;; are updated elementwise. 117 | 118 | 119 | ;; (define-abstract-class mcmc () 120 | ;; ()) 121 | 122 | ;; (defgeneric reset-counters (mcmc) 123 | ;; (:documentation "reset all the counters in an MCMC object")) 124 | 125 | ;; (defgeneric update (mcmc) 126 | ;; (:documentation "update parameters in an MCMC object")) 127 | 128 | ;; (defgeneric update-parameter (mcmc parameter) 129 | ;; (:documentation "return the updated parameter in an MCMC object")) 130 | 131 | ;; ;; (defgeneric update-parameter-in-vector (mcmc parameter index) 132 | ;; ;; (:documentation "return the updated parameter for index i in an MCMC object")) 133 | 134 | ;; (defgeneric current-parameters (mcmc) 135 | ;; (:documentation "Return the parameters, usually as a vector.")) 136 | 137 | ;; (defgeneric parameters-ix (mcmc) 138 | ;; (:documentation "Return the index corresponding to the parameter vector.")) 139 | 140 | ;; (defun conforming-ix (instance &rest slots) 141 | ;; "Return an index conforming to the slots of INSTANCE." 142 | ;; (labels ((sub-ix-spec (object) 143 | ;; (typecase object 144 | ;; (sequence (if (some (lambda (elt) (typep elt 'sequence)) object) 145 | ;; (map 'list #'sub-ix-spec object) 146 | ;; (length object))) 147 | ;; (array (coerce (array-dimensions object) 'vector)) 148 | ;; (otherwise nil)))) 149 | ;; (make-ix (mapcar (lambda (slot) 150 | ;; (cons slot (sub-ix-spec (slot-value instance slot)))) 151 | ;; slots)))) 152 | 153 | ;; (defmacro define-current-parameters (class &rest slots) 154 | ;; "Define CURRENT-PARAMETERS and PARAMETERS-IX methods, collecting the content 155 | ;; of the given slots as a (flat) vector." 156 | ;; `(progn 157 | ;; (defmethod current-parameters ((mcmc ,class)) 158 | ;; (labels ((c (vectors) 159 | ;; ;; concatenates vectors recursively 160 | ;; (apply #'concat 161 | ;; (map 'list (lambda (v) 162 | ;; (typecase v 163 | ;; (vector (c v)) 164 | ;; (array (displace-array 165 | ;; v (array-total-size v))) 166 | ;; (otherwise (vector v)))) 167 | ;; vectors)))) 168 | ;; (bind (((:slots-r/o ,@slots) mcmc)) 169 | ;; (c (vector ,@slots))))) 170 | ;; (defmethod parameters-ix ((mcmc ,class)) 171 | ;; (apply #'conforming-ix mcmc ',slots)))) 172 | 173 | ;; ;; (defmacro define-mcmc (class-name direct-superclasses slots &rest options) 174 | ;; ;; "Example: 175 | ;; ;; (define-mcmc model () 176 | ;; ;; ((x :parameter (atom :updater gibbs)) 177 | ;; ;; (y :parameter (atom :updater metropolis))))" 178 | ;; ;; ;; NOTES: currently, metropolis vector updaters are sharing a counter 179 | ;; ;; (let (parameters ; symbols 180 | ;; ;; vector-parameters ; symbols 181 | ;; ;; counters ; slot name, original var name pairs 182 | ;; ;; propdists) ; slot name, original var name pairs 183 | ;; ;; (labels ((process-parameter-specifier (name parameter-specifier) 184 | ;; ;; "Process parameter specifier." 185 | ;; ;; (bind (((type &key (updater :gibbs) 186 | ;; ;; (counter 'counter counter-supplied-p) 187 | ;; ;; (propdist 'propdist propdist-supplied-p)) 188 | ;; ;; (if (atom parameter-specifier) 189 | ;; ;; (list parameter-specifier) 190 | ;; ;; parameter-specifier))) 191 | ;; ;; (case type 192 | ;; ;; (atom) 193 | ;; ;; (vector 194 | ;; ;; (push name vector-parameters)) 195 | ;; ;; (otherwise (error "parameter type ~a not recognized" type))) 196 | ;; ;; (push name parameters) 197 | ;; ;; (case updater 198 | ;; ;; ;; Gibbs: nothing needs to be done, just some sanity checks 199 | ;; ;; ((:gibbs :deterministic) 200 | ;; ;; (when (or counter-supplied-p propdist-supplied-p) 201 | ;; ;; (error "Deterministic and Gibbs updaters don't ~ 202 | ;; ;; need a counter and/or updater-parameters"))) 203 | ;; ;; ;; Metropolis 204 | ;; ;; (:metropolis 205 | ;; ;; (push (cons (make-symbol* name '- counter) name) counters) 206 | ;; ;; (push (cons (make-symbol* name '- propdist) name) propdists)) 207 | ;; ;; (otherwise 208 | ;; ;; (error "updater ~a not recognized" updater))))) 209 | ;; ;; (process-slot-specifier (slot-specifier) 210 | ;; ;; "Extract parameter definitions, return filtered slot 211 | ;; ;; specifier with MCMC-specific keyword pairs removed." 212 | ;; ;; (bind (((slot-name &rest options) slot-specifier) 213 | ;; ;; (pairs (group options 2)) 214 | ;; ;; (parameter (find :parameter pairs :key #'first))) 215 | ;; ;; (awhen (has-duplicates? pairs :key #'first) 216 | ;; ;; (error "Key ~A occurs multiple times in slot specifier ~A." 217 | ;; ;; (first pairs) slot-specifier)) 218 | ;; ;; (when parameter 219 | ;; ;; (process-parameter-specifier slot-name (second parameter))) 220 | ;; ;; (cons slot-name (mapcan (lambda (pair) 221 | ;; ;; (if (eq (first pair) :parameter) 222 | ;; ;; nil 223 | ;; ;; pair)) 224 | ;; ;; pairs)))) 225 | ;; ;; (generate-counter-slot (counter) 226 | ;; ;; "Generate the slot definition for a counter." 227 | ;; ;; (let ((name (car counter)) 228 | ;; ;; (documentation (format nil "counter for ~A" (cdr counter)))) 229 | ;; ;; `(,name :accessor ,name :documentation ,documentation 230 | ;; ;; :initform (make-instance 'acceptance-counter)))) 231 | ;; ;; (generate-propdist-slot (propdist) 232 | ;; ;; "Generate the slot definition for a proposal distribution." 233 | ;; ;; (let ((name (car propdist)) 234 | ;; ;; (documentation (format nil "parameter(s) of the proposal ~ 235 | ;; ;; distribution for ~A" 236 | ;; ;; (cdr propdist)))) 237 | ;; ;; `(,name :accessor ,name :documentation ,documentation 238 | ;; ;; :initarg ,(make-keyword name))))) 239 | ;; ;; (check-type class-name symbol) 240 | ;; ;; `(progn 241 | ;; ;; ;; class definition 242 | ;; ;; (defclass ,class-name (mcmc ,@direct-superclasses) 243 | ;; ;; ,(concatenate 'list 244 | ;; ;; (mapcar #'process-slot-specifier (reverse slots)) 245 | ;; ;; (mapcar #'generate-counter-slot counters) 246 | ;; ;; (mapcar #'generate-propdist-slot propdists)) 247 | ;; ;; ,@options) 248 | ;; ;; ;; reset 249 | ;; ;; (defmethod reset-counters ((mcmc ,class-name)) 250 | ;; ;; ,@(mapcar (lambda (counter) 251 | ;; ;; `(setf (,(car counter) mcmc) 252 | ;; ;; (make-instance 'acceptance-counter))) 253 | ;; ;; counters) 254 | ;; ;; (values)) 255 | ;; ;; ;; update all variables 256 | ;; ;; (defmethod update ((mcmc ,class-name)) 257 | ;; ;; (dolist (parameter ',parameters) 258 | ;; ;; (update-parameter mcmc parameter)) 259 | ;; ;; (values)) 260 | ;; ;; ;; updaters for vectors 261 | ;; ;; ,@(mapcar (lambda (name) 262 | ;; ;; `(defmethod update-parameter ((mcmc ,class-name) 263 | ;; ;; (parameter (eql ',name))) 264 | ;; ;; (bind (((:slots-read-only ,name) mcmc)) 265 | ;; ;; (dotimes (i (length ,name)) 266 | ;; ;; (setf (aref ,name i) 267 | ;; ;; (update-parameter-in-vector mcmc ',name i))) 268 | ;; ;; ,name))) 269 | ;; ;; vector-parameters))))) 270 | 271 | 272 | ;; (defmacro define-mcmc (class-name direct-superclasses slots &rest options) 273 | ;; "Example: 274 | ;; (define-mcmc model () 275 | ;; ((x :parameter t) 276 | ;; (y :parameter t)))" 277 | ;; (check-type class-name symbol) 278 | ;; (iter 279 | ;; (for slot :in slots) 280 | ;; (bind (((slot-name &rest slot-spec) slot)) 281 | ;; (aif (getf slot-spec :parameter) 282 | ;; (progn 283 | ;; (collect (cons slot-name it) :into parameters) 284 | ;; (collect (cons slot-name (remove-from-plist slot-spec :parameter)) 285 | ;; :into filtered-slots)) 286 | ;; (collect slot :into filtered-slots))) 287 | ;; (finally 288 | ;; (return 289 | ;; `(progn 290 | ;; ;; class definition 291 | ;; (defclass ,class-name (mcmc ,@direct-superclasses) 292 | ;; ,filtered-slots 293 | ;; ,@options) 294 | ;; ;; updater 295 | ;; (defmethod update ((mcmc ,class-name)) 296 | ;; (dolist (parameter ',(mapcar #'car parameters)) 297 | ;; (update-parameter mcmc parameter)) 298 | ;; (values)) 299 | ;; (defmethod reset-counters ((mcmc ,class-name)))))))) 300 | 301 | ;; ;;;; 302 | ;; ;;;; Utility functions for defining updaters. 303 | ;; ;;;; 304 | 305 | ;; (defun instance-and-class (instance-and-maybe-class) 306 | ;; "Return list (instance class). If an atom or a single element is 307 | ;; given, it is used as both the instance and class name, otherwise a 308 | ;; two-element list is expected. Arguments are checked to be symbols." 309 | ;; (bind (((instance &optional (class instance)) (mklist instance-and-maybe-class))) 310 | ;; (check-type instance symbol) 311 | ;; (check-type class symbol) 312 | ;; (list instance class))) 313 | 314 | ;; (defmacro define-updater ((instance-and-maybe-class 315 | ;; parameter &key (vector-index nil)) 316 | ;; &body body) 317 | ;; "Define an update-parameter (or update-parameter-in-vector, if 318 | ;; vector-index) method specialized to class and parameter. The method will 319 | ;; be called with the given instance name. Slots are expanded with bind 320 | ;; using :slots-read-only. If vector-index, it will be used to index the vector." 321 | ;; (bind (((instance class) (instance-and-class instance-and-maybe-class))) 322 | ;; (check-type parameter symbol) 323 | ;; (check-type vector-index symbol) ; nil is a symbol, too 324 | ;; `(defmethod ,@(if vector-index 325 | ;; `(update-parameter-in-vector 326 | ;; ((,instance ,class) (parameter (eql ',parameter)) 327 | ;; ,vector-index)) 328 | ;; `(update-parameter 329 | ;; ((,instance ,class) (parameter (eql ',parameter))))) 330 | ;; (setf (slot-value ,instance ',parameter) 331 | ;; (locally ,@body))))) 332 | 333 | ;; (defmacro define-metropolis-updater ((instance-and-maybe-class 334 | ;; parameter &key 335 | ;; (vector-index nil) 336 | ;; (counter (make-symbol* parameter 337 | ;; '-counter)) 338 | ;; (propdist (make-symbol* parameter 339 | ;; '-propdist))) 340 | ;; &body body) 341 | ;; "Like define-updater, but with counter and proposal distribution 342 | ;; available with the given slot names (can be slot-name 343 | ;; or (variable-name slot-name)." 344 | ;; (bind (((instance class) (instance-and-class instance-and-maybe-class))) 345 | ;; `(define-updater ((,instance ,class) ,parameter 346 | ;; :vector-index ,vector-index) 347 | ;; (bind (((:slots ,counter ,propdist) ,instance)) 348 | ;; ,@body)))) 349 | 350 | ;; (defun log-posterior-ratio (x xnext log-posterior/proposal) 351 | ;; "Calculate the log posterior ratio by calling the 352 | ;; log-posterior/proposal function at x and xnext. NIL is interpreted as 353 | ;; minus infinity, and evaluation is lazy." 354 | ;; (let ((p-xnext (funcall log-posterior/proposal xnext))) 355 | ;; (if p-xnext 356 | ;; (let ((p-x (funcall log-posterior/proposal x))) 357 | ;; (if p-x 358 | ;; (- p-xnext p-x) 359 | ;; (error "current point has zero likelihood: this should never happen"))) 360 | ;; nil))) 361 | 362 | ;; (defun metropolis-step* (x x-proposal l-p-ratio) 363 | ;; "Return (values X-NEXT PROPOSAL-ACCEPTED-P). X-NEXT is X or 364 | ;; X-PROPOSAL, based on L-P-RATIO (the log posterior-ratio)." 365 | ;; (let ((accept-p (cond 366 | ;; ((null l-p-ratio) nil) 367 | ;; ((<= 0 l-p-ratio) t) 368 | ;; (t (< (random 1d0) (exp l-p-ratio)))))) 369 | ;; (if accept-p 370 | ;; (values x-proposal t) 371 | ;; (values x nil)))) 372 | 373 | ;; (defun metropolis-step (x x-proposal log-posterior/proposal counter) 374 | ;; "Perform a Metropolis(-Hastings) step, incrementing the counter if necessary. 375 | ;; Return the new value, and ACCEPTED? as the second value." 376 | ;; (bind ((l-p-ratio (log-posterior-ratio x x-proposal log-posterior/proposal)) 377 | ;; ((:values x-next accepted?) (metropolis-step* x x-proposal l-p-ratio))) 378 | ;; (increment-counter counter accepted?) 379 | ;; (values x-next accepted?))) 380 | 381 | 382 | 383 | --------------------------------------------------------------------------------