bnp

commit 3ce82bb59dacf0260fa2d458dec263a472c901b1
parent caa45daffad2af967aedee4eaf5832601a401483
Author: Jared Tobin <jared@jtobin.ca>
Date:   Fri, 12 Feb 2016 22:45:19 +1300

Add multivariate generative FMM.

Diffstat:
M
finite-gaussian-mixture/src/fmm_generative.r
 | 
2
+-
A
finite-gaussian-mixture/src/fmm_multivariate_generative.r
 | 
35
+++++++++++++++++++++++++++++++++++

2 files changed, 36 insertions(+), 1 deletion(-)
diff --git a/finite-gaussian-mixture/src/fmm_generative.r b/finite-gaussian-mixture/src/fmm_generative.r
@@ -16,7 +16,7 @@ parameter_model = function(k, n) {
   }
 
 data_model = function(config) {
-  sampler = function(y, m, s) rnorm(y, m, 1 / s)
+  sampler = function(y, m, s) rnorm(y, m, 1 / s) # FIXME this may not do what i expect
   mapply(sampler, config[[1]], config[[2]], config[[3]])
   }
 
diff --git a/finite-gaussian-mixture/src/fmm_multivariate_generative.r b/finite-gaussian-mixture/src/fmm_multivariate_generative.r
@@ -0,0 +1,35 @@
+set.seed(42)
+
+require(gtools)
+require(mvtnorm)
+
+mixing_model    = function(k, a) drop(rdirichlet(1, (rep(a, k))))
+label_model     = function(n, p) drop(rmultinom(1, size = n, prob = p))
+location_model  = function(k, l, r) rmvnorm(k, l, solve(r))
+precision_model = function(k, b, w) rinvwishart(k, b, solve(w))
+
+parameter_model = function(k, n) {
+  p  = mixing_model(k, 1)
+  c  = lapply(label_model(n, p), list)
+  mu = apply(location_model(k, rep(0, k), diag(10, k)), MARGIN = 1, list)
+  s  = precision_model(k, 10, diag(1, k))
+  list(c, mu, s)
+  }
+
+# FIXME mapply not working here
+data_model = function(config) {
+  sampler = function(c, m, s) rmvnorm(c, m, solve(s))
+  mapply(sampler, config[[1]], config[[2]], config[[3]])
+  }
+
+model = function(k, n) {
+  config = parameter_model(k, n)
+  data_model(config)
+  }
+
+rinvwishart = function(n, v, S) {
+  wishes = rWishart(n, v, solve(S))
+  invs   = apply(wishes, MARGIN = 3, function(x) list(solve(x)))
+  delabel(invs)
+  }
+