R/jps_sample.R

Defines functions jps_sample

Documented in jps_sample

#' Generate JPS sampling on the provided population.
#'
#' @param pop Population that will be sampled.
#' @param n Sample size.
#' @param H Set size for each ranking group.
#' @param K Number of rankers.
#' @param tau A parameter which controls ranking quality.
#' @param replace A boolean which specifies whether to sample with replacement or not.
#' @param with_index A boolean which specifies whether to return the index of the sampled population.
#'
#' @return A matrix with ranks from each ranker.
#' @export
#'
#' @examples
#' set.seed(112)
#' population_size <- 600
#' # the number of samples to be ranked in each set
#' H <- 3
#'
#' with_replacement <- FALSE
#' sigma <- 4
#' mu <- 10
#' n_rankers <- 3
#' # sample size
#' n <- 10
#'
#' rhos <- rep(0.75, n_rankers)
#' taus <- sigma * sqrt(1 / rhos^2 - 1)
#'
#' population <- qnorm((1:population_size) / (population_size + 1), mu, sigma)
#' jps_sample(population, n, H, taus, n_rankers, with_replacement)
#' #>               Y R1 R2 R3
#' #>  [1,]  6.384461  1  2  2
#' #>  [2,]  1.485141  1  1  1
#' #>  [3,] 13.640711  2  3  2
#' #>  [4,] 15.809136  3  3  2
#' #>  [5,]  6.769463  2  2  1
#' #>  [6,] 14.355524  3  3  3
#' #>  [7,] 10.729740  2  1  3
#' #>  [8,]  6.152453  1  1  1
#' #>  [9,]  8.701285  2  1  2
#' #> [10,] 13.323884  3  3  3
#'
jps_sample <- function(pop, n, H, tau, K, replace = FALSE, with_index = FALSE) {
  verify_jps_params(pop, n, H, tau, K, replace, with_index)

  sampling_indices <- sample(seq_along(pop), n * H, replace = replace)
  sampling_matrix <- matrix(pop[sampling_indices], ncol = H, nrow = n)

  # rank each SRS unit post experimentally
  jps_matrix <- matrix(0, ncol = K + 1, nrow = n)
  for (i in (1:n)) {
    comparison_set <- sampling_matrix[i, ]
    ranks <- rep(0, K)
    for (k in (1:K)) {
      # adjust for ranking, Dell and Clutter
      adjusted_set <- comparison_set + tau[k] * rnorm(H, 0, 1)
      ranks[k] <- rank(adjusted_set)[1]
    }
    jps_matrix[i, ] <- c(comparison_set[1], ranks)
  }

  colnames(jps_matrix) <- c("Y", paste0("R", 1:K))
  if (with_index) {
    jps_matrix <- cbind(sampling_indices[1:n], jps_matrix)
    colnames(jps_matrix)[1] <- "i"
  }

  return(jps_matrix)
}
biometryhub/RSS_package documentation built on Feb. 18, 2025, 11:56 p.m.