Consistency checks with pairwise preferences

DESCRIPTION

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

NEWS.md

@@ -1,5 +1,7 @@
 # BayesMallows (development versions)
 
+* The SMC function now check for consistency with previous latent ranks for 
+  existing users also when data arrive in the form of pairwise preferences.
 * A function compute_exact_partition_function() is now added, which returns the
   logarithm of the exact partition function for Cayley, Hamming, and Kendall
   distance.

src/particles.cpp

@@ -105,7 +105,20 @@ std::vector<Particle> augment_particles(
       }
     } else if (dat.augpair) {
       for(auto index : dat.updated_match) {
-        pvec[i].consistent(index) = 0;
+        pvec[i].consistent(index) = 1;
+        vec augmented = pvec[i].augmented_data(span::all, span(index));
+        auto items_above_for_user = dat.items_above[index];
+        size_t j{};
+        while(pvec[i].consistent(index) == 1 && j < items_above_for_user.size()) {
+          size_t k{};
+          while(pvec[i].consistent(index) == 1 && k < items_above_for_user[j].size()) {
+            if(augmented(items_above_for_user[j][k] - 1) > augmented(j)) {
+              pvec[i].consistent(index) = 0;
+            }
+            k++;
+          }
+          j++;
+        }
       }
 
       pvec[i].augmented_data.resize(dat.n_items, dat.rankings.n_cols);

src/smc_data_class.cpp

@@ -46,14 +46,17 @@ void SMCData::update(
 
   for(auto index : updated_indices) {
     rankings.col(updated_match[index]) = new_dat.rankings.col(updated_new[index]);
-    missing_indicator.col(updated_match[index]) = new_dat.missing_indicator.col(updated_new[index]);
+
     if(augpair) {
       items_above[updated_match[index]] = new_dat.items_above[updated_new[index]];
       items_below[updated_match[index]] = new_dat.items_below[updated_new[index]];
       uvec indices_to_keep = find(preferences.col(0) != updated_users[index]);
       preferences = preferences.rows(indices_to_keep);
       uvec indices_to_add = find(new_dat.preferences.col(0) == updated_users[index]);
       preferences = join_cols(preferences, new_dat.preferences.rows(indices_to_add));
+    } else if(any_missing) {
+      missing_indicator.col(updated_match[index]) =
+        new_dat.missing_indicator.col(updated_new[index]);
     }
   }
 

tests/testthat/test-smc_pairwise.R

@@ -39,3 +39,76 @@ test_that("update_mallows works with pairwise preferences", {
   expect_equal(mean(mod$alpha_samples), 3.03458072249661)
   expect_equal(sd(mod$alpha_samples), 0.670792690537946)
 })
+
+test_that("update_mallows works with existing users updating their data", {
+  set.seed(22)
+  m0 <- compute_mallows(
+    data = setup_rank_data(preferences = subset(beach_preferences, assessor == 2)),
+    compute_options = set_compute_options(nmc = 2000, burnin = 500)
+  )
+
+  m1 <- update_mallows(
+    model = m0,
+    new_data = setup_rank_data(
+      preferences = beach_preferences[1:10, ],
+      user_ids = 1,
+      n_items = 15
+    )
+  )
+
+  expect_equal(
+    mean(m1$alpha_samples),
+    2.75891148770247
+  )
+
+  expect_equal(
+    order(apply(m1$augmented_rankings, 1, mean)),
+    c(1L, 6L, 9L, 3L, 7L, 4L, 10L, 11L, 8L, 12L, 15L, 13L, 14L, 2L, 5L)
+  )
+
+  m2 <- update_mallows(
+    model = m1,
+    new_data = setup_rank_data(
+      preferences = beach_preferences[11:20, ],
+      user_ids = 1
+    )
+  )
+
+  expect_equal(
+    mean(m2$alpha_samples),
+    2.79625839950885
+  )
+
+  expect_equal(
+    order(apply(m2$augmented_rankings, 1, mean)),
+    c(6L, 4L, 10L, 1L, 2L, 7L, 8L, 11L, 5L, 3L, 12L, 9L, 13L, 15L, 14L)
+  )
+})
+
+test_that("update_mallows works with both new and updated users", {
+  set.seed(22)
+  m0 <- compute_mallows(
+    data = setup_rank_data(preferences = subset(beach_preferences, assessor == 2)),
+    compute_options = set_compute_options(nmc = 2000, burnin = 500)
+  )
+
+  m1 <- update_mallows(
+    model = m0,
+    new_data = setup_rank_data(
+      preferences = beach_preferences[c(1:10, 51:60), ],
+      user_ids = c(1, 3),
+      n_items = 15
+    )
+  )
+
+  m2 <- update_mallows(
+    model = m1,
+    new_data = setup_rank_data(
+      preferences = subset(beach_preferences, assessor %in% c(1, 3, 4)),
+      user_ids = c(1, 3, 4)
+    )
+  )
+
+  expect_equal(m1$data$user_ids, c(1, 3))
+  expect_equal(m2$data$user_ids, c(1, 3, 4))
+})

work-docs/pairwise_smc.R

@@ -1,27 +1,34 @@
 library(BayesMallows)
-library(tidyverse)
-library(patchwork)
+m0 <- compute_mallows(
+  data = setup_rank_data(preferences = subset(beach_preferences, assessor == 2 & bottom_item < 5 & top_item < 5),
+                         n_items = 5),
+  compute_options = set_compute_options(nmc = 2000, burnin = 500)
+)
 
-find_data <- function(k) {
-  dat <- sushi_rankings[1:300, ]
-  dat[dat > k] <- NA
-  dat
-}
+m1 <- update_mallows(
+  model = m0,
+  new_data = setup_rank_data(
+    preferences = data.frame(
+      assessor = 1,
+      bottom_item = c(5, 4, 3, 2),
+      top_item = c(4, 3, 2, 1)
+    ),
+    user_ids = 1,
+    n_items = 5
+  ),
+  smc_options = set_smc_options(n_particles = 2)
+)
 
-mod <- compute_mallows(
-  setup_rank_data(find_data(3)),
-  compute_options = set_compute_options(burnin = 500))
-
-plots <- list(plot(mod) + ggtitle(paste("k =", 3)))
-
-
-for(i in 4:10) {
-  print(i)
-  mod <- update_mallows(
-    model = mod,
-    new_data = setup_rank_data(find_data(i))
-  )
-  plots <- c(plots, list(plot(mod) + ggtitle(paste("k = ", i))))
-}
-
-wrap_plots(plots)
+m2 <- update_mallows(
+  model = m1,
+  setup_rank_data(
+    preferences = data.frame(
+      assessor = 1,
+      bottom_item = c(5, 4, 3, 2, 5),
+      top_item = c(4, 3, 2, 1, 3)
+    ),
+    user_ids = 1,
+    n_items = 5
+  ),
+  smc_options = set_smc_options(n_particles = 2)
+)