fixed a bug in pairwise preferences

R/compute_mallows.R

@@ -85,7 +85,6 @@ compute_mallows <- function(
   validate_preferences(data, model)
   validate_initial_values(initial_values, data)
 
-  data <- update_data(data, model)
   logz_list <- prepare_partition_function(logz_estimate, model$metric, data$n_items)
   prompt_save_files(compute_options)
 
@@ -133,23 +132,3 @@ compute_mallows <- function(
 
   return(fit)
 }
-
-update_data <- function(data, model) {
-  if (any(is.na(data$rankings))) {
-    dn <- dimnames(data$rankings)
-    data$rankings <- lapply(
-      split(data$rankings, f = seq_len(nrow(data$rankings))),
-      function(x) {
-        if (sum(is.na(x)) == 1) x[is.na(x)] <- setdiff(seq_along(x), x)
-        return(x)
-      }
-    )
-    data$rankings <- do.call(rbind, data$rankings)
-    dimnames(data$rankings) <- dn
-  }
-
-  data$constraints <- generate_constraints(data)
-  if (is.null(data$observation_frequency)) data$observation_frequency <- rep(1, nrow(data$rankings))
-
-  data
-}

R/generate_constraints.R

@@ -1,19 +1,19 @@
-generate_constraints <- function(data, cl = NULL) {
-  if (is.null(data$preferences)) {
+generate_constraints <- function(preferences, n_items, cl = NULL) {
+  if (is.null(preferences)) {
     return(list())
   }
   stopifnot(is.null(cl) || inherits(cl, "cluster"))
 
   # Turn the preferences dataframe into a list of dataframes,
   # one list element per assessor
   constraints <- split(
-    data$preferences[, c("bottom_item", "top_item"), drop = FALSE],
-    data$preferences$assessor
+    preferences[, c("bottom_item", "top_item"), drop = FALSE],
+    preferences$assessor
   )
   if (is.null(cl)) {
-    lapply(constraints, constraint_fun, data$n_items)
+    lapply(constraints, constraint_fun, n_items)
   } else {
-    parallel::parLapply(cl = cl, X = constraints, fun = constraint_fun, data$n_items)
+    parallel::parLapply(cl = cl, X = constraints, fun = constraint_fun, n_items)
   }
 }
 

R/generate_initial_ranking.R

@@ -1,80 +1,15 @@
-#' Generate Initial Ranking
-#'
-#' Given a consistent set of pairwise preferences, generate a complete ranking
-#' of items which is consistent with the preferences.
-#'
-#' @param preferences Pairwise preferences returned from [generative_transitive_closure()].
-#'
-#' @param n_items The total number of items.
-#'
-#' @param cl Optional computing cluster used for parallelization, returned from
-#'   [parallel::makeCluster()]. Defaults to `NULL`.
-#'
-#' @param shuffle_unranked Logical specifying whether or not to randomly
-#'   permuted unranked items in the initial ranking. When
-#'   `shuffle_unranked=TRUE` and `random=FALSE`, all unranked items
-#'   for each assessor are randomly permuted. Otherwise, the first ordering
-#'   returned by `igraph::topo_sort()` is returned.
-#'
-#' @param random Logical specifying whether or not to use a random initial
-#'   ranking. Defaults to `FALSE`. Setting this to `TRUE` means that
-#'   all possible orderings consistent with the stated pairwise preferences are
-#'   generated for each assessor, and one of them is picked at random.
-#'
-#' @param random_limit Integer specifying the maximum number of items allowed
-#'   when all possible orderings are computed, i.e., when `random=TRUE`.
-#'   Defaults to `8L`.
-#'
-#'
-#' @return A matrix of rankings which can be given in the `rankings`
-#'   argument to [compute_mallows()].
-#'
-#' @note Setting `random=TRUE` means that all possible orderings of each
-#'   assessor's preferences are generated, and one of them is picked at random.
-#'   This can be useful when experiencing convergence issues, e.g., if the MCMC
-#'   algorithm does not mix properly. However, finding all possible orderings
-#'   is a combinatorial problem, which may be computationally very hard. The
-#'   result may not even be possible to fit in memory, which may cause the R
-#'   session to crash. When using this option, please try to increase the size
-#'   of the problem incrementally, by starting with smaller subsets of the
-#'   complete data. An example is given below.
-#'
-#'   As detailed in the documentation to [generate_transitive_closure()],
-#'   it is assumed that the items are labeled starting from 1. For example, if a single
-#'   comparison of the following form is provided, it is assumed that there is a total
-#'   of 30 items (`n_items=30`), and the initial ranking is a permutation of these 30
-#'   items consistent with the preference 29<30.
-#'
-#' \tabular{rrr}{
-#' **assessor** \tab **bottom_item** \tab **top_item**\cr
-#' 1 \tab 29 \tab 30\cr
-#' }
-#'
-#' If in reality there are only two items, they should be relabeled to 1 and 2, as follows:
-#'
-#' \tabular{rrr}{
-#' **assessor** \tab **bottom_item** \tab **top_item**\cr
-#' 1 \tab 1 \tab 2\cr
-#' }
-#'
-#'
-#' @noRd
-#'
-#' @family preprocessing
-#'
+
 generate_initial_ranking <- function(
     preferences, n_items, cl = NULL, shuffle_unranked = FALSE,
     random = FALSE, random_limit = 8L) {
   UseMethod("generate_initial_ranking")
 }
 
-
 generate_initial_ranking.BayesMallowsTransitiveClosure <- function(
     preferences, n_items, cl = NULL, shuffle_unranked = FALSE, random = FALSE,
     random_limit = 8L) {
   stopifnot(is.null(cl) || inherits(cl, "cluster"))
 
-
   if (n_items > random_limit && random) {
     stop(paste(
       "Number of items exceeds the limit for generation of random permutations,\n",
@@ -102,6 +37,9 @@ generate_initial_ranking.BayesMallowsTransitiveClosure <- function(
 }
 
 
+.S3method("generate_initial_ranking", "BayesMallowsTransitiveClosure",
+          generate_initial_ranking.BayesMallowsTransitiveClosure)
+
 generate_initial_ranking.BayesMallowsIntransitive <- function(
     preferences, n_items, cl = NULL, shuffle_unranked = FALSE,
     random = FALSE, random_limit = 8L) {
@@ -112,7 +50,8 @@ generate_initial_ranking.BayesMallowsIntransitive <- function(
   rankings <- matrix(rankings, ncol = n_items, nrow = n_assessors, byrow = TRUE)
 }
 
-
+.S3method("generate_initial_ranking", "BayesMallowsIntransitive",
+          generate_initial_ranking.BayesMallowsIntransitive)
 
 create_ranks <- function(mat, n_items, shuffle_unranked, random) {
   if (!random) {

R/generate_transitive_closure.R

@@ -5,7 +5,6 @@ generate_transitive_closure <- function(preferences, cl = NULL) {
   stopifnot(is.null(cl) || inherits(cl, "cluster"))
   prefs <- split(preferences[, c("bottom_item", "top_item"), drop = FALSE], preferences$assessor)
 
-  #fun <- function(x, y) cbind(y, .generate_transitive_closure(cbind(x$bottom_item, x$top_item)))
   if (is.null(cl)) {
     lapplyfun <- lapply
   } else {
@@ -14,7 +13,7 @@ generate_transitive_closure <- function(preferences, cl = NULL) {
     }
   }
   prefs <- lapplyfun(seq_along(prefs), function(i) {
-    cbind(assessor = names(prefs)[[i]],
+    cbind(assessor = as.numeric(names(prefs)[[i]]),
           .generate_transitive_closure(as.matrix(prefs[[i]])))
   })
 

R/setup_rank_data.R

@@ -170,6 +170,8 @@ setup_rank_data <- function(
     if (nrow(rankings) != length(observation_frequency)) {
       stop("observation_frequency must be of same length as the number of rows in rankings")
     }
+  } else {
+    observation_frequency <- rep(1, nrow(rankings))
   }
 
   # Check that all rows of rankings are proper permutations
@@ -178,6 +180,10 @@ setup_rank_data <- function(
     stop("invalid permutations provided in rankings matrix")
   }
 
+  constraints <- generate_constraints(preferences, n_items, cl)
+
+  #####
+
   ret <- as.list(environment())
   class(ret) <- "BayesMallowsData"
   ret

work-docs/preferences.R

@@ -0,0 +1,5 @@
+devtools::load_all()
+data <- setup_rank_data(
+  preferences = beach_preferences
+)
+