commit 7c0df4efdb90e88688760fb18cad3fffd13b62fa parent 2bb381165c2f8cfe2d288ade99d0cb315693341d Author: Jared Tobin <jared@jtobin.ca> Date: Tue, 15 Mar 2016 22:55:42 +1300 Reorg (R is annoying). Diffstat:
17 files changed, 312 insertions(+), 304 deletions(-)
diff --git a/finite-gaussian-mixture/demo/sim_fmm_1d.r b/finite-gaussian-mixture/demo/sim_fmm_1d.r @@ -1,18 +0,0 @@ -require(ggplot2) -require(reshape2) - -source('../src/fmm_generative.r') - -config = list( - k = 4 - , n = 10000 - ) - -set.seed(42) - -d = model(config$k, config$n) -melted = melt(d) - -p = ggplot(melted, aes(value, colour = factor(L1), fill = factor(L1))) + - geom_density(alpha = 0.5) - diff --git a/finite-gaussian-mixture/demo/sim_fmm_1d_conditional.r b/finite-gaussian-mixture/demo/sim_fmm_1d_conditional.r @@ -1,74 +0,0 @@ -require(ggplot2) -require(gridExtra) -require(reshape2) - -source('../src/fmm_conditional.r') - -config = list( - k = 3 - , a = 1 - , l = 0 - , r = 0.01 - , b = 1 - , w = 1 - , n = 500 - ) - -origin = list( - p = mixing_model(config$k, config$a) - , m = location_model(config$k, config$l, config$r) - , s = precision_model(config$k, config$b, config$w) - ) - -set.seed(990909) - -d = data.frame( - value = c(rnorm(250, -3, 0.25), rnorm(500, 0, 0.25), rnorm(250, 3, 0.25))) - -set.seed(990909) - -params = inverse_model( - config$n, config$k, d$value - , config$a, config$l, config$r - , config$b, config$w - ) - -dp = melt(as.data.frame(params$p)) -dm = melt(as.data.frame(params$m)) -ds = melt(as.data.frame(params$s)) -dl = melt(as.data.frame(params$l)) - -py = ggplot(d, aes(value)) + geom_histogram(alpha = 0.5, fill = 'darkblue') - -pp = ggplot(dp, aes(x = seq_along(value), y = value, colour = variable)) + - geom_line() - -pm = ggplot(dm, aes(x = seq_along(value), y = value, colour = variable)) + - geom_line() - -ps = ggplot(ds, aes(x = seq_along(value), y = log(value), colour = variable)) + - geom_line() - -pl = ggplot(dl, aes(x = seq_along(value), y = value)) + - geom_line(colour = 'darkblue') - -early = data.frame(value = d$value, variable = params$z[1,]) -mid = data.frame(value = d$value, variable = params$z[round(config$n / 2),]) -late = data.frame(value = d$value, variable = params$z[config$n - 1,]) - -p_early = - ggplot(early, aes(value, colour = factor(variable), fill = factor(variable))) + - geom_histogram(alpha = 0.5) - -p_mid = - ggplot(mid, aes(value, colour = factor(variable), fill = factor(variable))) + - geom_histogram(alpha = 0.5) - -p_late = - ggplot(late, aes(value, colour = factor(variable), fill = factor(variable))) + - geom_histogram(alpha = 0.5) - -chain_plots = grid.arrange(py, pp, pm, ps, nrow = 2, ncol = 2) - -inferred_plots = grid.arrange(py, p_early, p_mid, p_late, nrow = 2, ncol = 2) - diff --git a/finite-gaussian-mixture/demo/sim_fmm_2d.r b/finite-gaussian-mixture/demo/sim_fmm_2d.r @@ -1,28 +0,0 @@ -require(ggplot2) -require(reshape2) - -source('../src/fmm_multivariate_generative.r') - -dimension = 2 - -config = list( - k = 4 - , l = rep(0, dimension) - , r = diag(0.05, dimension) - , b = dimension - , w = diag(1, dimension) - , n = 10000 - ) - -set.seed(42) - -d = model( - config$k, config$l, config$r - , config$b, config$w, config$n - ) - -framed = lapply(d, function(mat) { data.frame(x = mat[,1], y = mat[,2]) }) -melted = melt(framed, id.vars = c('x', 'y')) - -p = ggplot(melted, aes(x, y, colour = factor(L1))) + geom_point(alpha = 0.2) - diff --git a/finite-gaussian-mixture/demo/sim_fmm_2d_conditional.r b/finite-gaussian-mixture/demo/sim_fmm_2d_conditional.r @@ -1,72 +0,0 @@ -require(ggplot2) -require(gridExtra) -require(reshape2) - -source('../src/fmm_multivariate_conditional.r') - -dimension = 2 - -config = list( - k = 3 - , m = dimension - , a = 1 - , l = rep(0, dimension) - , r = diag(0.05, dimension) - , b = 2 - , w = diag(1, dimension) - , n = 1000 - ) - -set.seed(222) - -d = list( - t(replicate(250, rnorm(2, c(5, 5)))) - , t(replicate(250, rnorm(2, c(-5, -5)))) - , t(replicate(500, rnorm(2)))) -dn = lapply(d, function(j) { data.frame(x = j[,1], y = j[,2]) }) -m = melt(dn, id.vars = c('x', 'y')) - -set.seed(990909) - -params = inverse_model( - config$n, config$k, m[, c('x', 'y')] - , config$a - , config$l, config$r - , config$b, config$w - ) - -dp = melt(data.frame(params$p)) -dm = melt(lapply(params$m, data.frame), id.vars = c('x', 'y')) - -py = ggplot(m, aes(x, y)) + geom_point() - -pp = ggplot(dp, aes(seq_along(value), value, colour = variable)) + - geom_line() + facet_grid(. ~ variable) - -pm = ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) + - geom_point(alpha = 0.5) - -early = data.frame(x = m$x, y = m$y, variable = params$z[1,]) -mid = data.frame(x = m$x, y = m$y, variable = params$z[round(config$n / 2),]) -late = data.frame(x = m$x, y = m$y, variable = params$z[config$n - 1,]) - -p_early = - ggplot(early, aes(x, y, colour = factor(variable), fill = factor(variable))) + - geom_point(alpha = 0.5) - -p_mid = - ggplot(mid, aes(x, y, colour = factor(variable), fill = factor(variable))) + - geom_point(alpha = 0.5) - -p_late = - ggplot(late, aes(x, y, value, colour = factor(variable), fill = factor(variable))) + - geom_point(alpha = 0.5) - -mean_convergence_plots = - ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) + - geom_point(alpha = 0.2) + facet_grid(. ~ L1) - -chain_plots = grid.arrange(pp, mean_convergence_plots, nrow = 2) - -inferred_plots = grid.arrange(py, p_early, p_mid, p_late, nrow = 2, ncol = 2) - diff --git a/finite-gaussian-mixture/demo/sim_fmm_3d.r b/finite-gaussian-mixture/demo/sim_fmm_3d.r @@ -1,29 +0,0 @@ -require(reshape2) -require(scatterplot3d) - -source('../src/fmm_multivariate_generative.r') - -dimension = 3 - -config_3d = list( - k = 4 - , l = rep(0, dimension) - , r = diag(0.05, dimension) - , b = dimension - , w = diag(1, dimension) - , n = 10000 - ) - -set.seed(42) - -d_3d = model( - config_3d$k, config_3d$l, config_3d$r - , config_3d$b, config_3d$w, config_3d$n - ) - -framed_3d = lapply(d_3d, - function(mat) { data.frame(x = mat[,1], y = mat[,2], z = mat[,3]) }) -melted_3d = do.call(rbind, framed_3d) - -scatterplot3d(melted_3d, highlight.3d = T, pch = 19) - diff --git a/finite-gaussian-mixture/demo/sim_fmm_3d_conditional.r b/finite-gaussian-mixture/demo/sim_fmm_3d_conditional.r @@ -1,73 +0,0 @@ -require(ggplot2) -require(gridExtra) -require(reshape2) - -source('../src/fmm_multivariate_conditional.r') - -dimension = 3 - -config = list( - k = 3 - , m = dimension - , a = 1 - , l = rep(0, dimension) - , r = diag(0.05, dimension) - , b = dimension - , w = diag(1, dimension) - , n = 5000 - ) - -set.seed(222) - -d = list( - t(replicate(250, rnorm(config$m, c(5, 5)))) - , t(replicate(250, rnorm(config$m, c(-5, -5)))) - , t(replicate(500, rnorm(config$m)))) -dn = lapply(d, function(j) { data.frame(x = j[,1], y = j[,2], z = j[,3]) }) -m = melt(dn, id.vars = c('x', 'y', 'z')) - -set.seed(990909) - -params = inverse_model( - config$n, config$k, m[, c('x', 'y', 'z')] - , config$a - , config$l, config$r - , config$b, config$w - ) - -dp = melt(data.frame(params$p)) - -dm = melt(lapply(params$m, data.frame), id.vars = c('x', 'y', 'z')) - -py = ggplot(m, aes(x, y)) + geom_point() - -pp = ggplot(dp, aes(seq_along(value), value, colour = variable)) + - geom_line() + facet_grid(. ~ variable) - -pm = ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) + - geom_point(alpha = 0.5) - -early = data.frame(x = m$x, y = m$y, variable = params$z[1,]) -mid = data.frame(x = m$x, y = m$y, variable = params$z[round(config$n / 2),]) -late = data.frame(x = m$x, y = m$y, variable = params$z[config$n - 1,]) - -p_early = - ggplot(early, aes(x, y, colour = factor(variable), fill = factor(variable))) + - geom_point(alpha = 0.5) - -p_mid = - ggplot(mid, aes(x, y, colour = factor(variable), fill = factor(variable))) + - geom_point(alpha = 0.5) - -p_late = - ggplot(late, aes(x, y, value, colour = factor(variable), fill = factor(variable))) + - geom_point(alpha = 0.5) - -mean_convergence_plots = - ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) + - geom_point(alpha = 0.2) + facet_grid(. ~ L1) - -chain_plots = grid.arrange(pp, mean_convergence_plots, nrow = 2) - -inferred_plots = grid.arrange(py, p_early, p_mid, p_late, nrow = 2, ncol = 2) - diff --git a/finite-gaussian-mixture/src/fmm_conditional.r b/finite-gaussian-mixture/src/fmm_conditional.r @@ -1,7 +1,7 @@ require(dplyr) -require(gtools) source('fmm_generative.r') +source('fmm_utils.r') conditional_mixing_model = function(y, k, z, a) { labelled = data.frame(value = y, L1 = z) diff --git a/finite-gaussian-mixture/src/fmm_generative.r b/finite-gaussian-mixture/src/fmm_generative.r @@ -1,5 +1,4 @@ -require(gtools) -require(magrittr) +source('fmm_utils.r') mixing_model = function(k, a) drop(rdirichlet(1, (rep(a, k)))) label_model = function(n, p) drop(rmultinom(1, size = n, prob = p)) @@ -19,7 +18,10 @@ data_model = function(config) { mapply(sampler, config[[1]], config[[2]], config[[3]]) } -model = function(k, n) parameter_model(k, n) %>% data_model +model = function(k, n) { + params = parameter_model(k, n) + data_model(params) +} lmodel = function(y, p, m, s) { score = function(pr, mu, prec) { pr * dnorm(y, mu, sqrt(1 / prec)) } diff --git a/finite-gaussian-mixture/src/fmm_multivariate_conditional.r b/finite-gaussian-mixture/src/fmm_multivariate_conditional.r @@ -1,7 +1,7 @@ -require(gtools) require(mvtnorm) source('fmm_multivariate_generative.r') +source('fmm_utils.r') # NOTE (jtobin): must load dplyr after plyr require(dplyr) diff --git a/finite-gaussian-mixture/src/fmm_multivariate_generative.r b/finite-gaussian-mixture/src/fmm_multivariate_generative.r @@ -1,7 +1,6 @@ -require(gtools) -require(magrittr) require(mvtnorm) -require(plyr) + +source('fmm_utils.r') # Cluster probabilities via a symmetric Dirichlet distribution. # @@ -32,7 +31,7 @@ label_model = function(n, p) { # Returns a list of 'k' locations, each having same dimension as 'l'. location_model = function(k, l, r) { vals = rmvnorm(k, l, solve(r)) - alply(vals, 1) + unlist(apply(vals, MARGIN = 1, list), recursive = F) } # Precision matrix, by cluster. @@ -82,7 +81,8 @@ data_model = function(params) { # The finite Gaussian mixture model. model = function(k, l, r, b, w, n) { - parameter_model(k, l, r, b, w, n) %>% data_model + params = parameter_model(k, l, r, b, w, n) + data_model(params) } # Log-likelihood for the finite Gaussian mixture model. diff --git a/finite-gaussian-mixture/src/fmm_utils.r b/finite-gaussian-mixture/src/fmm_utils.r @@ -0,0 +1,6 @@ +rdirichlet = function(n, a) { + l = length(a) + x = matrix(rgamma(n * l, a), ncol = l, byrow = T) + s = x %*% rep(1, l) + x / as.vector(s) +} diff --git a/finite-gaussian-mixture/src/sim_fmm_1d.r b/finite-gaussian-mixture/src/sim_fmm_1d.r @@ -0,0 +1,18 @@ +require(ggplot2) +require(reshape2) + +source('fmm_generative.r') + +config = list( + k = 4 + , n = 10000 + ) + +set.seed(42) + +d = model(config$k, config$n) +melted = melt(d) + +p = ggplot(melted, aes(value, colour = factor(L1), fill = factor(L1))) + + geom_density(alpha = 0.5) + diff --git a/finite-gaussian-mixture/src/sim_fmm_1d_conditional.r b/finite-gaussian-mixture/src/sim_fmm_1d_conditional.r @@ -0,0 +1,74 @@ +require(ggplot2) +require(gridExtra) +require(reshape2) + +source('fmm_conditional.r') + +config = list( + k = 3 + , a = 1 + , l = 0 + , r = 0.01 + , b = 1 + , w = 1 + , n = 500 + ) + +origin = list( + p = mixing_model(config$k, config$a) + , m = location_model(config$k, config$l, config$r) + , s = precision_model(config$k, config$b, config$w) + ) + +set.seed(990909) + +d = data.frame( + value = c(rnorm(250, -3, 0.25), rnorm(500, 0, 0.25), rnorm(250, 3, 0.25))) + +set.seed(990909) + +params = inverse_model( + config$n, config$k, d$value + , config$a, config$l, config$r + , config$b, config$w + ) + +dp = melt(as.data.frame(params$p)) +dm = melt(as.data.frame(params$m)) +ds = melt(as.data.frame(params$s)) +dl = melt(as.data.frame(params$l)) + +py = ggplot(d, aes(value)) + geom_histogram(alpha = 0.5, fill = 'darkblue') + +pp = ggplot(dp, aes(x = seq_along(value), y = value, colour = variable)) + + geom_line() + +pm = ggplot(dm, aes(x = seq_along(value), y = value, colour = variable)) + + geom_line() + +ps = ggplot(ds, aes(x = seq_along(value), y = log(value), colour = variable)) + + geom_line() + +pl = ggplot(dl, aes(x = seq_along(value), y = value)) + + geom_line(colour = 'darkblue') + +early = data.frame(value = d$value, variable = params$z[1,]) +mid = data.frame(value = d$value, variable = params$z[round(config$n / 2),]) +late = data.frame(value = d$value, variable = params$z[config$n - 1,]) + +p_early = + ggplot(early, aes(value, colour = factor(variable), fill = factor(variable))) + + geom_histogram(alpha = 0.5) + +p_mid = + ggplot(mid, aes(value, colour = factor(variable), fill = factor(variable))) + + geom_histogram(alpha = 0.5) + +p_late = + ggplot(late, aes(value, colour = factor(variable), fill = factor(variable))) + + geom_histogram(alpha = 0.5) + +chain_plots = grid.arrange(py, pp, pm, ps, nrow = 2, ncol = 2) + +inferred_plots = grid.arrange(py, p_early, p_mid, p_late, nrow = 2, ncol = 2) + diff --git a/finite-gaussian-mixture/src/sim_fmm_2d.r b/finite-gaussian-mixture/src/sim_fmm_2d.r @@ -0,0 +1,28 @@ +require(ggplot2) +require(reshape2) + +source('fmm_multivariate_generative.r') + +dimension = 2 + +config = list( + k = 4 + , l = rep(0, dimension) + , r = diag(0.05, dimension) + , b = dimension + , w = diag(1, dimension) + , n = 10000 + ) + +set.seed(42) + +d = model( + config$k, config$l, config$r + , config$b, config$w, config$n + ) + +framed = lapply(d, function(mat) { data.frame(x = mat[,1], y = mat[,2]) }) +melted = melt(framed, id.vars = c('x', 'y')) + +p = ggplot(melted, aes(x, y, colour = factor(L1))) + geom_point(alpha = 0.2) + diff --git a/finite-gaussian-mixture/src/sim_fmm_2d_conditional.r b/finite-gaussian-mixture/src/sim_fmm_2d_conditional.r @@ -0,0 +1,72 @@ +require(ggplot2) +require(gridExtra) +require(reshape2) + +source('fmm_multivariate_conditional.r') + +dimension = 2 + +config = list( + k = 3 + , m = dimension + , a = 1 + , l = rep(0, dimension) + , r = diag(0.05, dimension) + , b = 2 + , w = diag(1, dimension) + , n = 1000 + ) + +set.seed(222) + +d = list( + t(replicate(250, rnorm(2, c(5, 5)))) + , t(replicate(250, rnorm(2, c(-5, -5)))) + , t(replicate(500, rnorm(2)))) +dn = lapply(d, function(j) { data.frame(x = j[,1], y = j[,2]) }) +m = melt(dn, id.vars = c('x', 'y')) + +set.seed(990909) + +params = inverse_model( + config$n, config$k, m[, c('x', 'y')] + , config$a + , config$l, config$r + , config$b, config$w + ) + +dp = melt(data.frame(params$p)) +dm = melt(lapply(params$m, data.frame), id.vars = c('x', 'y')) + +py = ggplot(m, aes(x, y)) + geom_point() + +pp = ggplot(dp, aes(seq_along(value), value, colour = variable)) + + geom_line() + facet_grid(. ~ variable) + +pm = ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) + + geom_point(alpha = 0.5) + +early = data.frame(x = m$x, y = m$y, variable = params$z[1,]) +mid = data.frame(x = m$x, y = m$y, variable = params$z[round(config$n / 2),]) +late = data.frame(x = m$x, y = m$y, variable = params$z[config$n - 1,]) + +p_early = + ggplot(early, aes(x, y, colour = factor(variable), fill = factor(variable))) + + geom_point(alpha = 0.5) + +p_mid = + ggplot(mid, aes(x, y, colour = factor(variable), fill = factor(variable))) + + geom_point(alpha = 0.5) + +p_late = + ggplot(late, aes(x, y, value, colour = factor(variable), fill = factor(variable))) + + geom_point(alpha = 0.5) + +mean_convergence_plots = + ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) + + geom_point(alpha = 0.2) + facet_grid(. ~ L1) + +chain_plots = grid.arrange(pp, mean_convergence_plots, nrow = 2) + +inferred_plots = grid.arrange(py, p_early, p_mid, p_late, nrow = 2, ncol = 2) + diff --git a/finite-gaussian-mixture/src/sim_fmm_3d.r b/finite-gaussian-mixture/src/sim_fmm_3d.r @@ -0,0 +1,29 @@ +require(reshape2) +require(scatterplot3d) + +source('fmm_multivariate_generative.r') + +dimension = 3 + +config_3d = list( + k = 4 + , l = rep(0, dimension) + , r = diag(0.05, dimension) + , b = dimension + , w = diag(1, dimension) + , n = 10000 + ) + +set.seed(42) + +d_3d = model( + config_3d$k, config_3d$l, config_3d$r + , config_3d$b, config_3d$w, config_3d$n + ) + +framed_3d = lapply(d_3d, + function(mat) { data.frame(x = mat[,1], y = mat[,2], z = mat[,3]) }) +melted_3d = do.call(rbind, framed_3d) + +scatterplot3d(melted_3d, highlight.3d = T, pch = 19) + diff --git a/finite-gaussian-mixture/src/sim_fmm_3d_conditional.r b/finite-gaussian-mixture/src/sim_fmm_3d_conditional.r @@ -0,0 +1,73 @@ +require(ggplot2) +require(gridExtra) +require(reshape2) + +source('fmm_multivariate_conditional.r') + +dimension = 3 + +config = list( + k = 3 + , m = dimension + , a = 1 + , l = rep(0, dimension) + , r = diag(0.05, dimension) + , b = dimension + , w = diag(1, dimension) + , n = 5000 + ) + +set.seed(222) + +d = list( + t(replicate(250, rnorm(config$m, c(5, 5)))) + , t(replicate(250, rnorm(config$m, c(-5, -5)))) + , t(replicate(500, rnorm(config$m)))) +dn = lapply(d, function(j) { data.frame(x = j[,1], y = j[,2], z = j[,3]) }) +m = melt(dn, id.vars = c('x', 'y', 'z')) + +set.seed(990909) + +params = inverse_model( + config$n, config$k, m[, c('x', 'y', 'z')] + , config$a + , config$l, config$r + , config$b, config$w + ) + +dp = melt(data.frame(params$p)) + +dm = melt(lapply(params$m, data.frame), id.vars = c('x', 'y', 'z')) + +py = ggplot(m, aes(x, y)) + geom_point() + +pp = ggplot(dp, aes(seq_along(value), value, colour = variable)) + + geom_line() + facet_grid(. ~ variable) + +pm = ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) + + geom_point(alpha = 0.5) + +early = data.frame(x = m$x, y = m$y, variable = params$z[1,]) +mid = data.frame(x = m$x, y = m$y, variable = params$z[round(config$n / 2),]) +late = data.frame(x = m$x, y = m$y, variable = params$z[config$n - 1,]) + +p_early = + ggplot(early, aes(x, y, colour = factor(variable), fill = factor(variable))) + + geom_point(alpha = 0.5) + +p_mid = + ggplot(mid, aes(x, y, colour = factor(variable), fill = factor(variable))) + + geom_point(alpha = 0.5) + +p_late = + ggplot(late, aes(x, y, value, colour = factor(variable), fill = factor(variable))) + + geom_point(alpha = 0.5) + +mean_convergence_plots = + ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) + + geom_point(alpha = 0.2) + facet_grid(. ~ L1) + +chain_plots = grid.arrange(pp, mean_convergence_plots, nrow = 2) + +inferred_plots = grid.arrange(py, p_early, p_mid, p_late, nrow = 2, ncol = 2) +