R/RcppExports.R

Defines functions metropolis_hastings_rho metropolis_hastings_aug_ranking metropolis_hastings_alpha smc_mallows_new_users smc_mallows_new_item_rank leap_and_shift_probs get_sample_probabilities get_exponent_sum correction_kernel_pseudo correction_kernel calculate_forward_probability calculate_backward_probability run_mcmc rmallows asymptotic_partition_function get_partition_function log_expected_dist compute_importance_sampling_estimate rank_dist_vec rank_dist_sum get_rank_distance

Documented in asymptotic_partition_function calculate_backward_probability calculate_forward_probability compute_importance_sampling_estimate correction_kernel correction_kernel_pseudo get_rank_distance rmallows run_mcmc smc_mallows_new_item_rank smc_mallows_new_users

# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

#' Compute the Distance between two rankings
#'
#' @description Compute the distance between two rankings according to several metrics.
#' @param r1 A vector of ranks.
#' @param r2 A vector of ranks.
#' @param metric A string. Available options are \code{"footrule"},
#' \code{"kendall"}, \code{"cayley"}, \code{"hamming"}, \code{"spearman"}, and \code{"ulam"}.
#' @return A scalar.
#' @details Note that the Spearman distance is the squared L2 norm, whereas
#' the footrule distance is the L1 norm.
#'
#' The Ulam distance uses the SUBSET library developed by John Burkardt, available at http://people.sc.fsu.edu/~jburkardt/cpp_src/subset/subset.html.
#'
#' The implementation of Cayley distance is based on a \code{C++} translation of \code{Rankcluster::distCayley} \insertCite{Grimonprez2016}{BayesMallows}.
#'
#'
#' @references \insertAllCited{}
#' @keywords internal
get_rank_distance <- function(r1, r2, metric) {
    .Call(`_BayesMallows_get_rank_distance`, r1, r2, metric)
}

rank_dist_sum <- function(rankings, rho, metric, obs_freq) {
    .Call(`_BayesMallows_rank_dist_sum`, rankings, rho, metric, obs_freq)
}

rank_dist_vec <- function(rankings, rho, metric, obs_freq) {
    .Call(`_BayesMallows_rank_dist_vec`, rankings, rho, metric, obs_freq)
}

#' Compute importance sampling estimates of log partition function
#' for footrule and Spearman distances.
#'
#' @param alpha_vector Vector of alpha values at which to compute partition function.
#' @param n_items Integer specifying the number of ranked items.
#' @param metric Distance measure of the target Mallows distribution. Defaults to \code{footrule}.
#' @param nmc Number of Monte Carlo samples. Defaults to \code{1e4}.
#'
#' @keywords internal
#'
compute_importance_sampling_estimate <- function(alpha_vector, n_items, metric = "footrule", nmc = 1e4L) {
    .Call(`_BayesMallows_compute_importance_sampling_estimate`, alpha_vector, n_items, metric, nmc)
}

#' Compute the logarithm of the expected distance of metrics for a Mallows rank model
#'
#' @param n_items Number of items.
#' @param alpha The value of the alpha parameter.
#' @param cardinalities Number of occurrences for each unique distance.
#' Applicable for Footrule and Spearman distance.
#' @param metric A string. Available options are \code{"ulam"}, \code{"footrule"} and \code{"spearman"}.
#' @return A scalar, the logarithm of the partition function.
#' @noRd
#'
log_expected_dist <- function(alpha, n_items, cardinalities, metric) {
    .Call(`_BayesMallows_log_expected_dist`, alpha, n_items, cardinalities, metric)
}

#' Compute the logarithm of the partition function for a Mallows rank model
#'
#' @param n_items Number of items.
#' @param alpha The value of the alpha parameter.
#' @param cardinalities Number of occurrences for each unique distance.
#' Applicable for Footrule and Spearman distance. Defaults to \code{R_NilValue}.
#' @param logz_estimate Precomputed importance sampling fit.
#' @param metric A string. Available options are \code{"footrule"},
#' \code{"kendall"}, \code{"spearman"}, \code{"cayley"}, \code{"hamming"}, and \code{"ulam"}.
#' Defaults to \code{"footrule"}.
#' @return A scalar, the logarithm of the partition function.
#' @noRd
#'
#' @references \insertAllCited{}
#'
get_partition_function <- function(n_items, alpha, cardinalities = NULL, logz_estimate = NULL, metric = "footrule") {
    .Call(`_BayesMallows_get_partition_function`, n_items, alpha, cardinalities, logz_estimate, metric)
}

#' Asymptotic Approximation of Partition Function
#'
#' Compute the asymptotic approximation of the logarithm of the partition function,
#' using the iteration algorithm of \insertCite{mukherjee2016;textual}{BayesMallows}.
#'
#' @param alpha_vector A numeric vector of alpha values.
#' @param n_items Integer specifying the number of items.
#' @param metric One of \code{"footrule"} and \code{"spearman"}.
#' @param K Integer.
#' @param n_iterations Integer specifying the number of iterations.
#' @param tol Stopping criterion for algorithm. The previous matrix is subtracted
#' from the updated, and if the maximum absolute relative difference is below \code{tol},
#' the iteration stops.
#'
#' @return A vector, containing the partition function at each value of alpha.
#' @keywords internal
#'
#' @references \insertAllCited{}
#'
asymptotic_partition_function <- function(alpha_vector, n_items, metric, K, n_iterations = 1000L, tol = 1e-9) {
    .Call(`_BayesMallows_asymptotic_partition_function`, alpha_vector, n_items, metric, K, n_iterations, tol)
}

#' Sample from the Mallows distribution.
#'
#' Sample from the Mallows distribution with arbitrary distance metric using
#' a Metropolis-Hastings algorithm.
#'
#' @param rho0 Vector specifying the latent consensus ranking.
#' @param alpha0 Scalar specifying the scale parameter.
#' @param n_samples Integer specifying the number of random samples to generate.
#' @param burnin Integer specifying the number of iterations to discard as burn-in.
#' @param thinning Integer specifying the number of MCMC iterations to perform
#' between each time a random rank vector is sampled.
#' @param leap_size Integer specifying the step size of the leap-and-shift proposal distribution.
#' @param metric Character string specifying the distance measure to use. Available
#' options are \code{"footrule"} (default), \code{"spearman"}, \code{"cayley"}, \code{"hamming"},
#' \code{"kendall"}, and \code{"ulam"}.
#'
#' @keywords internal
#'
#' @references \insertAllCited{}
#'
rmallows <- function(rho0, alpha0, n_samples, burnin, thinning, leap_size = 1L, metric = "footrule") {
    .Call(`_BayesMallows_rmallows`, rho0, alpha0, n_samples, burnin, thinning, leap_size, metric)
}

#' Worker function for computing the posterior distribution.
#'
#' @param rankings A set of complete rankings, with one sample per column.
#' With n_assessors samples and n_items items, rankings is n_items x n_assessors.
#' @param obs_freq  A vector of observation frequencies (weights) to apply to the rankings.
#' @param nmc Number of Monte Carlo samples.
#' @param constraints List of lists of lists, returned from `generate_constraints`.
#' @param cardinalities Used when metric equals \code{"footrule"} or
#' \code{"spearman"} for computing the partition function. Defaults to
#' \code{R_NilValue}.
#' @param logz_estimate Estimate of the log partition function.
#' @param metric The distance metric to use. One of \code{"spearman"},
#' \code{"footrule"}, \code{"kendall"}, \code{"cayley"}, or
#' \code{"hamming"}.
#' @param error_model Error model to use.
#' @param Lswap Swap parameter used by Swap proposal for proposing rank augmentations in the case of non-transitive pairwise comparisons.
#' @param n_clusters Number of clusters. Defaults to 1.
#' @param include_wcd Boolean defining whether or
#' not to store the within-cluster distance.
#' @param leap_size Leap-and-shift step size.
#' @param alpha_prop_sd Standard deviation of proposal distribution for alpha.
#' @param alpha_init Initial value of alpha.
#' @param alpha_jump How many times should we sample \code{rho} between
#' each time we sample \code{alpha}. Setting \code{alpha_jump} to a high
#' number can significantly speed up computation time, since we then do not
#' have to do expensive computation of the partition function.
#' @param lambda Parameter of the prior distribution.
#' @param alpha_max Maximum value of \code{alpha}, used for truncating the exponential prior distribution.
#' @param psi Hyperparameter for the Dirichlet prior distribution used in clustering.
#' @param rho_thinning Thinning parameter. Keep only every \code{rho_thinning} rank
#' sample from the posterior distribution.
#' @param aug_thinning Integer specifying the thinning for data augmentation.
#' @param clus_thin Integer specifying the thinning for saving cluster assignments.
#' @param save_aug Whether or not to save the augmented data every
#' \code{aug_thinning}th iteration.
#' @param verbose Logical specifying whether to print out the progress of the
#' Metropolis-Hastings algorithm. If \code{TRUE}, a notification is printed every
#' 1000th iteration.
#' @param kappa_1 Hyperparameter for \eqn{theta} in the Bernoulli error model. Defaults to 1.0.
#' @param kappa_2 Hyperparameter for \eqn{theta} in the Bernoulli error model. Defaults to 1.0.
#' @param save_ind_clus Whether or not to save the individual cluster probabilities in each step,
#' thinned as specified in argument \code{clus_thin}. This results in csv files \code{cluster_probs1.csv},
#' \code{cluster_probs2.csv}, ..., being saved in the calling directory. This option may slow down the code
#' considerably, but is necessary for detecting label switching using Stephen's algorithm.
#' @keywords internal
#'
run_mcmc <- function(rankings, obs_freq, nmc, constraints, cardinalities, logz_estimate, rho_init, metric = "footrule", error_model = "none", Lswap = 1L, n_clusters = 1L, include_wcd = FALSE, leap_size = 1L, alpha_prop_sd = 0.5, alpha_init = 5, alpha_jump = 1L, lambda = 0.1, alpha_max = 1e6, psi = 10L, rho_thinning = 1L, aug_thinning = 1L, clus_thin = 1L, save_aug = FALSE, verbose = FALSE, kappa_1 = 1.0, kappa_2 = 1.0, save_ind_clus = FALSE) {
    .Call(`_BayesMallows_run_mcmc`, rankings, obs_freq, nmc, constraints, cardinalities, logz_estimate, rho_init, metric, error_model, Lswap, n_clusters, include_wcd, leap_size, alpha_prop_sd, alpha_init, alpha_jump, lambda, alpha_max, psi, rho_thinning, aug_thinning, clus_thin, save_aug, verbose, kappa_1, kappa_2, save_ind_clus)
}

#' @title Calculate Backward Probability
#' @description Function to calculate probability of assigning a set of specific ranks to an specific item
#' given its rank in the consensus ranking
#'
#' @param item_ordering A vector of integer values to represent the specified queue of which unranked item to assign a rank for the proposed augmented ranking
#' @param partial_ranking An incomplete rank sequence vector of the original observed incomplete ranking which contains NAs
#' @param current_ranking An complete rank sequence vector of  the proposed augmented ranking obtained from calculate_forward_probability function
#' @param remaining_set A vector of integer values to represent the elements (ranks) missing from original observed ranking
#' @param rho Numeric vector specifying the consensus ranking
#' @param alpha Numeric value of the scale parameter
#' @param n_items Integer is the number of items in a ranking
#' @param metric A character string specifying the distance metric to use in the
#'   Bayesian Mallows Model. Available options are \code{"footrule"},
#'   \code{"spearman"}, \code{"cayley"}, \code{"hamming"}, \code{"kendall"}, and
#'   \code{"ulam"}.
#' @return backward_auxiliary_ranking_probability A numerical value of creating the previous augmented ranking using the same item ordering used to create the
#' new augmented ranking in calculate_forward_probability function.
#' @export
#' @keywords internal
calculate_backward_probability <- function(item_ordering, partial_ranking, current_ranking, remaining_set, rho, alpha, n_items, metric = "footrule") {
    .Call(`_BayesMallows_calculate_backward_probability`, item_ordering, partial_ranking, current_ranking, remaining_set, rho, alpha, n_items, metric)
}

#' @title Calculate Forward Probability
#' @description Function to calculate probability of assigning a set of
#'   specific ranks to an specific item
#' given its rank in the consensus ranking
#' @export
#'
#' @param item_ordering A vector of integer values to represent the specified
#'   queue of which unranked item to assign a rank for the proposed augmented
#'   ranking
#' @param partial_ranking An incomplete rank sequence vector of the original
#'   observed incomplete ranking which contains NAs
#' @param remaining_set A vector of integer values to represent the elements
#'   (ranks) missing from original observed ranking
#' @param rho Numeric vector specifying the consensus ranking
#' @param alpha Numeric value of the scale parameter
#' @param n_items Integer is the number of items in a ranking
#' @param metric A character string specifying the distance metric to use in
#'   the Bayesian Mallows Model. Available options are \code{"footrule"},
#'   \code{"spearman"}, \code{"cayley"}, \code{"hamming"}, \code{"kendall"},
#'   and \code{"ulam"}.
#' @return List containing aug_ranking, a ranking sequence vector of the
#'   proposed augmented ranking and forward_prob a numerical value of the
#'   probability of creating the augmented ranking using the pseudolikelihood
#'   augmentation.
#' @keywords internal
calculate_forward_probability <- function(item_ordering, partial_ranking, remaining_set, rho, alpha, n_items, metric = "footrule") {
    .Call(`_BayesMallows_calculate_forward_probability`, item_ordering, partial_ranking, remaining_set, rho, alpha, n_items, metric)
}

#' @title Correction Kernel
#' @description Function to determine if the augmented ranking is compatible
#' with the new observed partial ranking. If it is not, the we create a new
#' augmentation using the random sampling approach and calculate the
#' augmentation probability.
#'
#' @param current_ranking A ranking sequence vector of the current augmented
#' ranking (no missing values)
#' @param observed_ranking A ranking sequence vector of the observed partial
#' ranking (no missing values) The original incomplete partial ranking
#' is in the rankings data set.
#' @param n_items Integer is the number of items in a ranking
#'
#' @return List containing the proposed 'corrected' augmented ranking
#' that is compatible with the new observed ranking for a user
#' @keywords internal
correction_kernel <- function(observed_ranking, current_ranking, n_items) {
    .Call(`_BayesMallows_correction_kernel`, observed_ranking, current_ranking, n_items)
}

#' @title Correction Kernel (pseudolikelihood)
#' @description Function to determine if the augmented ranking is compatible with the new observed partial ranking.
#' If it is not, the we create a new augmentation using the pseudolikelihood approach and calculate the augmentation probability.
#'
#' @param observed_ranking An incomplete rank sequence vector of the original observed incomplete ranking which contains NAs
#' @param current_ranking An complete rank sequence vector of  the proposed augmented ranking obtained from calculate_forward_probability function
#' @param rho Numeric vector specifying the consensus ranking
#' @param alpha Numeric value of the scale parameter
#' @param n_items Integer is the number of items in a ranking
#' @param metric A character string specifying the distance metric to use in the
#'   Bayesian Mallows Model. Available options are \code{"footrule"},
#'   \code{"spearman"}, \code{"cayley"}, \code{"hamming"}, \code{"kendall"}, and
#'   \code{"ulam"}.
#' @return list containing R_obs, the proposed 'corrected' augmented ranking that is compatible with the new observed ranking for a user, and
#'         forward_auxiliary_ranking_probability, a numerical value for the probability of correcting the ranking to be compatible with R_obs.
#' @keywords internal
correction_kernel_pseudo <- function(current_ranking, observed_ranking, rho, alpha, n_items, metric = "footrule") {
    .Call(`_BayesMallows_correction_kernel_pseudo`, current_ranking, observed_ranking, rho, alpha, n_items, metric)
}

#' @title Get exponent in Mallows log-likelihood
#' @description Calculates the exponent Mallows log-likelihood given a set of rankings
#' and a given rank sequence.
#' @param alpha Numeric value of the scale parameter
#' @param rho A ranking sequence
#' @param n_items Integer is the number of items in a ranking
#' A matrix of size \eqn{N }\eqn{\times}{x}\eqn{ n_items} of
#' rankings in each row. Alternatively, if \eqn{N} equals 1, \code{rankings}
#' can be a vector.
#' @param rankings A matrix of size \eqn{N }\eqn{\times}{x}\eqn{ n_items} of
#' rankings in each row. Alternatively, if \eqn{N} equals 1, \code{rankings}
#' can be a vector.
#' @param metric Character string specifying the distance measure to use.
#' Available options are \code{"kendall"}, \code{"cayley"}, \code{"hamming"},
#' \code{"ulam"}, \code{"footrule"} and \code{"spearman"}.
#' @return Exponent in the Mallows log likelihood. Note that it does not include
#' the partition function, and since the partition function depends on \code{alpha},
#' this is not a likelihood per se.
#' @noRd
#' @examples
#' set.seed(101)
#' rho <- t(c(1, 2, 3, 4, 5, 6))
#' alpha <- 2
#' metric <- "footrule"
#' n_items <- 6
#' get_exponent_sum(
#'   alpha = alpha, rho = rho, n_items = length(rho), rankings = rho,
#'   metric = metric
#' )
#'
#' # return 0 because you are comparing the consensus ranking with itself
#' # if you change alpha or metric, then the result shall remain as 0
#'
#' rankings <- sample_mallows(
#'   rho0 = rho, alpha0 = alpha, n_samples = 10, burnin = 1000, thinning = 500
#' )
#'
#' # depending on your seed, you will get a different collection of rankings in R and C++
#'
#' get_exponent_sum(
#'   alpha = alpha, rho = rho,  n_items = n_items, rankings = rankings ,
#'   metric = metric
#' )
get_exponent_sum <- function(alpha, rho, n_items, rankings, metric = "footrule") {
    .Call(`_BayesMallows_get_exponent_sum`, alpha, rho, n_items, rankings, metric)
}

#' @title Get Sample Probabilities
#' @description Calculate probability of assigning a set of specific ranks to an specific item
#' given its rank in the consensus ranking
#'
#' @param rho_item_rank An integer value rank of an item in the current consensus ranking
#' @param alpha Numeric value of the scale parameter
#' @param remaining_set_ranks A sequence of integer values of the set of possible ranks that we can assign the item
#' @param metric A character string specifying the distance metric to use in the
#'   Bayesian Mallows Model. Available options are \code{"footrule"},
#'   \code{"spearman"}, \code{"cayley"}, \code{"hamming"}, \code{"kendall"}, and
#'   \code{"ulam"}.
#' @param n_items Integer is the number of items in the consensus ranking
#' @return sample_prob_list A numeric sequence of sample probabilities for selecting a specific rank given the current
#'         rho_item_rank
#' @noRd
#'
get_sample_probabilities <- function(rho_item_rank, alpha, remaining_set_ranks, n_items, metric = "footrule") {
    .Call(`_BayesMallows_get_sample_probabilities`, rho_item_rank, alpha, remaining_set_ranks, n_items, metric)
}

#' @title Leap and Shift Probabilities
#' @description Calculates transition probabilities for proposing a new rho
#' @param rho A ranking sequence
#' @param leap_size Integer specifying the step size of the leap-and-shift
#' proposal distribution.
#' @param n_items Integer is the number of items in a ranking
#' @return A list containing:
#' \itemize{
#' \item \code{rho_prime} A ranking sequence proposed consensus ranking
#' \item \code{forwards_prob} Numeric value to account for transition probability from rho to rho_prime
#' \item \code{backwards_prob} Numeric Value to account for the transition probability from \code{rho_prime} to \code{rho}
#' }
#'
#' @noRd
#' @examples
#' rho <- c(1, 2, 3, 4, 5, 6)
#' n_items <- 6
#'
#' leap_and_shift_probs(rho, n_items, 1)
#' leap_and_shift_probs(rho, n_items, 2)
#' leap_and_shift_probs(rho, n_items, 3)
#'
leap_and_shift_probs <- function(rho, n_items, leap_size = 1L) {
    .Call(`_BayesMallows_leap_and_shift_probs`, rho, n_items, leap_size)
}

#' @title SMC-Mallows new item rank
#' @description Function to perform resample-move SMC algorithm where we receive a new item ranks from an existing user
#' at each time step. Each correction and augmentation is done by filling in the missing item ranks using pseudolikelihood augmentation.
#' @param n_items Integer is the number of items in a ranking
#' @param R_obs 3D matrix of size n_assessors by n_items by Time containing a set of observed rankings of Time time steps
#' @param metric A character string specifying the distance metric to use in the
#' Bayesian Mallows Model. Available options are \code{"footrule"},
#' \code{"spearman"}, \code{"cayley"}, \code{"hamming"}, \code{"kendall"}, and
#' \code{"ulam"}.
#' @param leap_size leap_size Integer specifying the step size of the leap-and-shift
#' proposal distribution
#' @param N Integer specifying the number of particles
#' @param Time Integer specifying the number of time steps in the SMC algorithm
#' @param logz_estimate Estimate of the partition function, computed with
#' \code{\link{estimate_partition_function}}.
#' @param cardinalities Cardinalities for exact computation of partition function,
#' returned from \code{\link{prepare_partition_function}}.
#' @param mcmc_kernel_app Integer value for the number of applications we apply the MCMC move kernel
#' @param alpha_prop_sd Numeric value of the standard deviation of the prior distribution for alpha
#' @param lambda Strictly positive numeric value specifying the rate parameter
#' of the truncated exponential prior distribution of alpha.
#' @param alpha_max  Maximum value of alpha in the truncated exponential
#' prior distribution.
#' @param aug_method A character string specifying the approach for filling in the missing data, options are "pseudolikelihood" or "random"
#' @param verbose Logical specifying whether to print out the progress of the
#' SMC-Mallows algorithm. Defaults to \code{FALSE}.
#' @param alpha_fixed Logical indicating whether to sample \code{alpha} or not.
#' @param alpha numeric value of the scale parameter.
#' @param aug_rankings_init Initial values for augmented rankings.
#' @param rho_samples_init Initial values for rho samples.
#' @param alpha_samples_init Initial values for alpha samples.
#'
#' @return a 3d matrix containing: the samples of: rho, alpha and the augmented rankings, and the effective sample size at each iteration of the SMC algorithm.
#'
#' @export
#'
#' @family modeling
#'
smc_mallows_new_item_rank <- function(n_items, R_obs, N, Time, logz_estimate, cardinalities, mcmc_kernel_app, aug_rankings_init = NULL, rho_samples_init = NULL, alpha_samples_init = 0L, alpha = 0, alpha_prop_sd = 0.5, lambda = 0.1, alpha_max = 1e6, aug_method = "random", verbose = FALSE, alpha_fixed = FALSE, metric = "footrule", leap_size = 1L) {
    .Call(`_BayesMallows_smc_mallows_new_item_rank`, n_items, R_obs, N, Time, logz_estimate, cardinalities, mcmc_kernel_app, aug_rankings_init, rho_samples_init, alpha_samples_init, alpha, alpha_prop_sd, lambda, alpha_max, aug_method, verbose, alpha_fixed, metric, leap_size)
}

#' @title SMC-Mallows New Users
#' @description Function to perform resample-move SMC algorithm where we
#' receive new users with complete rankings at each time step. See Chapter 4
#' of \insertCite{steinSequentialInferenceMallows2023}{BayesMallows}
#'
#' @param R_obs Matrix containing the full set of observed rankings of size
#' n_assessors by n_items
#' @param type One of \code{"complete"}, \code{"partial"}, or
#' \code{"partial_alpha_fixed"}.
#' @param n_items Integer is the number of items in a ranking
#' @param metric A character string specifying the distance metric to use
#' in the Bayesian Mallows Model. Available options are \code{"footrule"},
#' \code{"spearman"}, \code{"cayley"}, \code{"hamming"}, \code{"kendall"}, and
#' \code{"ulam"}.
#' @param leap_size leap_size Integer specifying the step size of the
#' leap-and-shift proposal distribution
#' @param N Integer specifying the number of particles
#' @param Time Integer specifying the number of time steps in the SMC algorithm
#' @param logz_estimate Estimate of the partition function, computed with
#' \code{\link{estimate_partition_function}}.
#' @param cardinalities Cardinalities for exact evaluation of partition function,
#' returned from \code{\link{prepare_partition_function}}.
#' @param mcmc_kernel_app Integer value for the number of applications we
#' apply the MCMC move kernel
#' @param num_new_obs Integer value for the number of new observations
#' (complete rankings) for each time step
#' @param alpha_prop_sd Numeric value specifying the standard deviation of the
#'   lognormal proposal distribution used for \eqn{\alpha} in the
#'   Metropolis-Hastings algorithm. Defaults to \code{0.1}.
#' @param lambda Strictly positive numeric value specifying the rate parameter
#'   of the truncated exponential prior distribution of \eqn{\alpha}. Defaults
#'   to \code{0.1}. When \code{n_cluster > 1}, each mixture component
#'   \eqn{\alpha_{c}} has the same prior distribution.
#' @param alpha_max Maximum value of \code{alpha} in the truncated exponential
#'   prior distribution.
#' @param alpha A numeric value of the scale parameter which is known and fixed.
#' @param aug_method A character string specifying the approach for filling
#' in the missing data, options are "pseudolikelihood" or "random".
#' @param verbose Logical specifying whether to print out the progress of the
#' SMC-Mallows algorithm. Defaults to \code{FALSE}.
#'
#' @return a set of particles each containing a value of rho and alpha
#'
#' @export
#'
#' @example inst/examples/smc_mallows_new_users_complete_example.R
#'
#' @family modeling
#'
smc_mallows_new_users <- function(R_obs, type, n_items, N, Time, mcmc_kernel_app, num_new_obs, alpha_prop_sd = 0.5, lambda = 0.1, alpha_max = 1e6, alpha = 0, aug_method = "random", logz_estimate = NULL, cardinalities = NULL, verbose = FALSE, metric = "footnote", leap_size = 1L) {
    .Call(`_BayesMallows_smc_mallows_new_users`, R_obs, type, n_items, N, Time, mcmc_kernel_app, num_new_obs, alpha_prop_sd, lambda, alpha_max, alpha, aug_method, logz_estimate, cardinalities, verbose, metric, leap_size)
}

#' @title Metropolis-Hastings Alpha
#' @description Function to perform Metropolis-Hastings for new rho under
#'   the Mallows model with footrule distance metric!
#' @param alpha Numeric value of the scale parameter
#' @param n_items Integer is the number of items in a ranking
#' @param rankings the observed rankings, i.e, preference data
#' @details \code{rankings} is a matrix of size
#'   \eqn{N }\eqn{\times}{x}\eqn{ n_items} of rankings in each row.
#'   Alternatively, if \eqn{N} equals 1, \code{rankings} can be a vector.
#' @param metric A character string specifying the distance metric to use
#'   in the Bayesian Mallows Model. Available options are \code{"footrule"},
#'   \code{"spearman"}, \code{"cayley"}, \code{"hamming"}, \code{"kendall"},
#'   and \code{"ulam"}.
#' @param rho Numeric vector specifying the current consensus ranking
#' @param logz_estimate Estimate  grid of log of partition function,
#'   computed with \code{\link{estimate_partition_function}}.
#' @param cardinalities Cardinalities for exact computation of partition function,
#' returned from \code{\link{prepare_partition_function}}.
#' @param alpha_prop_sd Numeric value specifying the standard deviation of the
#'   lognormal proposal distribution used for \eqn{\alpha} in the
#'   Metropolis-Hastings algorithm. Defaults to \code{0.1}.
#' @return \code{alpha} or \code{alpha_prime}: Numeric value to be used
#'   as the proposal of a new alpha
#' @param lambda Strictly positive numeric value specifying the rate parameter
#'   of the truncated exponential prior distribution of \eqn{\alpha}. Defaults
#'   to \code{0.1}. When \code{n_cluster > 1}, each mixture component
#'   \eqn{\alpha_{c}} has the same prior distribution.
#' @param alpha_max Maximum value of \code{alpha} in the truncated exponential
#'   prior distribution.
#' @example /inst/examples/metropolis_hastings_alpha_example.R
#' @noRd
metropolis_hastings_alpha <- function(alpha, n_items, rankings, rho, logz_estimate, cardinalities, metric = "footrule", alpha_prop_sd = 0.5, alpha_max = 1e6, lambda = 0.1) {
    .Call(`_BayesMallows_metropolis_hastings_alpha`, alpha, n_items, rankings, rho, logz_estimate, cardinalities, metric, alpha_prop_sd, alpha_max, lambda)
}

#' @title Metropolis-Hastings Augmented Ranking
#' @description Function to perform Metropolis-Hastings for new augmented ranking
#'
#' @param alpha Numeric value of the scale parameter
#' @param rho Numeric vector specifying the consensus ranking
#' @param n_items Integer is the number of items in a ranking
#' @param partial_ranking An incomplete rank sequence vector of the original observed incomplete ranking which contains NAs
#' @param current_ranking An complete rank sequence vector of  the proposed augmented ranking obtained from calculate_forward_probability function
#' @param metric A character string specifying the distance metric to use in the
#'   Bayesian Mallows Model. Available options are \code{"footrule"},
#'   \code{"spearman"}, \code{"cayley"}, \code{"hamming"}, \code{"kendall"}, and
#'   \code{"ulam"}.
#' @param pseudo Boolean specifying whether to use pseudo proposal or not.s
#' @return R_curr or R_obs A ranking sequence vector representing proposed augmented ranking for next iteration of MCMC chain
#' @noRd
metropolis_hastings_aug_ranking <- function(alpha, rho, n_items, partial_ranking, current_ranking, pseudo, metric = "footnote") {
    .Call(`_BayesMallows_metropolis_hastings_aug_ranking`, alpha, rho, n_items, partial_ranking, current_ranking, pseudo, metric)
}

#' @title Metropolis-Hastings Rho
#' @description Function to perform Metropolis-Hastings for new rho under the Mallows model with footrule distance metric!
#' @inheritParams get_exponent_sum
#' @param leap_size Integer specifying the step size of the leap-and-shift
#' proposal distribution.
#' @noRd
#' @examples
#' rho <- t(c(1,2,3,4,5,6))
#' alpha <- 2
#' metric <- "footrule"
#' n_items <- 6
#'
#' metropolis_hastings_rho(
#' 	alpha = alpha, n_items = n_items, rankings = rho, metric = metric,
#' 	rho = rho, leap_size = 1
#' )
#'
#' metropolis_hastings_rho(
#' 	alpha = alpha, n_items = n_items, rankings = rho, metric = metric,
#' 	rho = rho, leap_size = 2
#' )
#'
#' metropolis_hastings_rho(
#' 	alpha = alpha, n_items = n_items, rankings = rho, metric = metric,
#' 	rho = rho, leap_size = 3
#' )
#'
#' rankings <- sample_mallows(
#'  rho0 = rho, alpha0 = alpha, n_samples = 10, burnin = 1000, thinning = 500
#' )
#' metropolis_hastings_rho(
#' 	alpha = alpha, n_items = n_items, rankings = rankings, metric = metric,
#' 	rho = rho, leap_size = 1
#' )
#'
metropolis_hastings_rho <- function(alpha, n_items, rankings, rho, metric = "footnote", leap_size = 1L) {
    .Call(`_BayesMallows_metropolis_hastings_rho`, alpha, n_items, rankings, rho, metric, leap_size)
}

Try the BayesMallows package in your browser

Any scripts or data that you put into this service are public.

BayesMallows documentation built on Nov. 25, 2023, 5:09 p.m.