tests/testthat/test_V_dimensionality.R

In multinomineq: Bayesian Inference for Multinomial Models with Inequality Constraints

### ternary choice (Regenwetter & Davis-Stober, 2012)
# choice options:  {prefer_a, indifferent, prefer_b}
library("testthat")
# column order:    (a>b,b>a,  a>c,c>a,  b>c,c>b)
# with:            i>j = 1  <=> utility(i) > utility(j)
V <- matrix(c(
  # strict weak orders
  0, 1, 0, 0, 1, 0, 0, 1, 0, # a < b < c
  1, 0, 0, 0, 1, 0, 0, 1, 0, # b < a < c
  0, 1, 0, 0, 1, 0, 1, 0, 0, # a < c < b
  0, 1, 0, 1, 0, 0, 1, 0, 0, # c < a < b
  1, 0, 0, 1, 0, 0, 1, 0, 0, # c < b < a
  1, 0, 0, 1, 0, 0, 0, 1, 0, # b < c < a

  0, 0, 1, 0, 1, 0, 0, 1, 0, # a ~ b < c
  0, 1, 0, 0, 0, 1, 1, 0, 0, # a ~ c < b
  1, 0, 0, 1, 0, 0, 0, 0, 1, # c ~ b < a
  0, 1, 0, 0, 1, 0, 0, 0, 1, # a < b ~ c
  1, 0, 0, 0, 0, 1, 0, 1, 0, # b < a ~ c
  0, 0, 1, 1, 0, 0, 1, 0, 0, # c < a ~ b

  0, 0, 1, 0, 0, 1, 0, 0, 1 # a ~ b ~ c
), byrow = TRUE, ncol = 9)
options <- rep(3, 3)

test_that("dimensionality of V works", {
  expect_silent(V_free <- drop_fixed(V, options))
  expect_is(V_free, "matrix")
  expect_equal(dim(V_free), c(nrow(V), sum(options - 1)))

  # only with Porta:
  # V_to_Ab(V_free)

  expect_silent(p <- find_inside(V = V, random = TRUE))
  expect_true(inside(p, V = V))
  expect_true(inside(drop_fixed(p, options), V = V_free))
  expect_silent(p_free <- find_inside(V = V_free, random = TRUE))
  expect_true(inside(p_free, V = V_free))
  expect_true(inside(add_fixed(p_free, options), V = V))


  # undebug(multinomineq:::sampling_V)
  expect_silent(pp <- sampling_multinom(
    k = c(4, 2, 3, 19, 4, 2, 2, 15, 10),
    options = c(3, 3, 3), V = V_free,
    M = 100, progress = FALSE
  ))
  expect_true(all(inside(pp, V = V_free)))
  expect_true(all(inside(add_fixed(pp, options), V = V)))

  ################### here: V with fixed dimensions!
  # library(Rglpk)
  # d <- c(1,0,0, 0,0,0, 0,0,0)
  # # variables: c(lambda, alpha_1, ..., alpha_M)
  # obj <- c(1, rep(0, nrow(V)))
  #
  # mat <- rbind(rep(c(0, 1), c(1, nrow(V))), # sum(alpha) = 1
  #              cbind(d, - t(V)))            # intersection p+lambda*d = sum(alpha*V)
  # dir <- c(rep("==", 1 + ncol(V)))
  # rhs <- c(1, - p)
  # lp <- Rglpk_solve_LP(obj, mat, dir, rhs, max = TRUE)
  # target <- p + (lp$optimum+.000000001) * d
  # inside(target, V = V)
  # p[d] + lp$optimum
  # target
  # p

  ####  alpha >= 0 by default in Rglpk!
  # M <- nrow(V)
  # alpha.sum <- rep(c(0, 1), c(1, M))
  # line.intersect <- cbind(d, - t(V))
  # alpha.pos <- cbind(0, diag(M))
  # dir <- c(rep(">=", M), rep("==", 1 + ncol(V)))
  # rhs <- c(rep(0, M), 1, p)
  # mat <- rbind(alpha.pos, alpha.sum, intersect)
})