fixed cluster thinning bug (#424)

ocbe-uio · Jan 6, 2025 · 198a8dc · 198a8dc
1 parent 771fa30
commit 198a8dc
Show file tree

Hide file tree

Showing 5 changed files with 34 additions and 3 deletions.
diff --git a/BayesMallows.Rproj b/BayesMallows.Rproj
@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: 6e0ef04a-160c-463b-bc1b-40b5326f6cb9
 
 RestoreWorkspace: No
 SaveWorkspace: No

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: BayesMallows
 Type: Package
 Title: Bayesian Preference Learning with the Mallows Rank Model
-Version: 2.2.2
+Version: 2.2.2.9000
 Authors@R: c(person("Oystein", "Sorensen",
                     email = "oystein.sorensen.1985@gmail.com",
                     role = c("aut", "cre"),

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,8 @@
+# BayesMallows (development versions)
+
+* Fixed bug, clus_thinning argument did not work in the case of a single 
+  cluster. Thanks to Timothy Lee for pointing this out. Issue #423 on GitHub.
+
 # BayesMallows 2.2.2
 
 * An error in compute_mallows_loglik when the number of clusters is more than

diff --git a/R/tidy_mcmc.R b/R/tidy_mcmc.R
@@ -25,14 +25,14 @@ tidy_mcmc <- function(fits, data, model_options, compute_options) {
   fit$cluster_assignment <- do.call(rbind, lapply(seq_along(fits), function(i) {
     tidy_cluster_assignment(
       fits[[i]]$cluster_assignment, i, model_options$n_clusters, data$n_assessors,
-      compute_options$nmc
+      floor(compute_options$nmc / compute_options$clus_thinning)
     )
   }))
 
   fit$cluster_probs <- do.call(rbind, lapply(seq_along(fits), function(i) {
     tidy_cluster_probabilities(
       fits[[i]]$cluster_probs, i, model_options$n_clusters,
-      compute_options$nmc
+      floor(compute_options$nmc / compute_options$clus_thinning)
     )
   }))
 

diff --git a/tests/testthat/test-assign_cluster.R b/tests/testthat/test-assign_cluster.R
@@ -43,3 +43,28 @@ test_that("assign_cluster works", {
   expect_equal(dim(assign_cluster(mod)), c(60, 4))
   expect_equal(dim(assign_cluster(mod, expand = TRUE)), c(180, 4))
 })
+
+test_that("cluster thinning works", {
+  model_fit1 <- compute_mallows(
+    data = setup_rank_data(preferences = beach_preferences),
+    model_options = set_model_options(n_clusters = 1),
+    compute_options = set_compute_options(nmc = 100, clus_thinning = 10)
+  )
+
+  expect_equal(range(model_fit1$cluster_assignment$iteration), c(1, 10))
+  expect_equal(unique(model_fit1$cluster_assignment$iteration), 1:10)
+  expect_equal(range(model_fit1$cluster_probs$iteration), c(1, 10))
+  expect_equal(unique(model_fit1$cluster_probs$iteration), 1:10)
+
+  model_fit2 <- compute_mallows(
+    data = setup_rank_data(preferences = beach_preferences),
+    model_options = set_model_options(n_clusters = 2),
+    compute_options = set_compute_options(nmc = 100, clus_thinning = 10)
+  )
+
+  expect_equal(range(model_fit2$cluster_assignment$iteration), c(1, 10))
+  expect_equal(unique(model_fit2$cluster_assignment$iteration), 1:10)
+  expect_equal(range(model_fit2$cluster_probs$iteration), c(1, 10))
+  expect_equal(unique(model_fit2$cluster_probs$iteration), 1:10)
+
+})