tests/testthat/test.solve_reg_fm_prob.R

In optmatch: Functions for Optimal Matching

################################################################################
# Tests for solve_reg_fm_prob, which wraps fmatch and provides some useful statistics
################################################################################

context("solve_reg_fm_prob")

### Commented out because matched.distances = TRUE not implemented yet.
### test_that("Matched Distances", {
###   d <- matrix(c(1,2,3,4), nrow = 2, dimnames = list(c(1,2), c(3,4)))
###   # these values were generated by debugging the fullmatch function on:
###   #   fullmatch(d)
###   # and then saving the call to solve_reg_fm_prob
###   max.cpt <- 2
###   min.cpt <- 0.5
###   tolerance <- 0.004
###   # omit.fraction is NULL
###
###   res <- solve_reg_fm_prob(rownames = rownames(d), colnames = colnames(d),
###                      distmat = d, max.cpt = max.cpt, min.cpt = min.cpt,
###                      tolerance = tolerance, omit.fraction = NULL)
###
###   # result from .fullmatch
###   # cells
###   # 1 2 3 4
###   # 1 2 1 2
###   #
###   # $err
###   # [1] -0.008
###   #
###   # $match.distance
###   # [1] 0
###
###   # if the pairs are 1-3, 2-4, the matched distances are c(1,4)
###
###   expect_equivalent(res$match.distance, c(1,4))
###
### })

test_that("nodes_shell_fmatch() helper",{
    expect_is(nodes_shell_fmatch(c(1,2), c(3,4)), "NodeInfo")
})

test_that("No Warnings", {
  d <- matrix(c(1,2,3,4), nrow = 2, dimnames = list(c(1,2), c(3,4)))
  d  <- new("DenseMatrix", d)
  # these values were generated by debugging the fullmatch function on:
  #   fullmatch(d)
  # and then saving the call to solve_reg_fm_prob
  max.cpt <- 2
  min.cpt <- 0.5
  tolerance <- 0.004
  # omit.fraction is NULL

  if (requireNamespace("rrelaxiv", quietly = TRUE)) {
    expect_silent(
    res <- solve_reg_fm_prob(node_info = nodes_shell_fmatch(rownames(d), colnames(d)),
                       distspec = d, max.cpt = max.cpt, min.cpt = min.cpt,
                       tolerance = tolerance, omit.fraction = NULL, solver = "RELAX-IV")
  )
    slvr <- "RELAX-IV"
  }
  expect_silent(
    res <- solve_reg_fm_prob(node_info = nodes_shell_fmatch(rownames(d), colnames(d)),
                       distspec = d, max.cpt = max.cpt, min.cpt = min.cpt,
                       tolerance = tolerance, omit.fraction = NULL, solver = "LEMON")
  )
})

test_that("NA for unmatched items", {
  d <- matrix(c(1,2, 3,4, Inf, Inf), nrow = 2, dimnames = list(c(1,2), c(3,4, "U")))
  d  <- new("DenseMatrix", d)
  max.cpt <- 3
  min.cpt <- 0.5
  tolerance <- 0.005

  if (requireNamespace("rrelaxiv", quietly = TRUE)) {
    slvr <- "RELAX-IV"
    res <- solve_reg_fm_prob(node_info = nodes_shell_fmatch(rownames(d), colnames(d)),
                     distspec = d, max.cpt = max.cpt, min.cpt = min.cpt,
                     tolerance = tolerance, omit.fraction = NULL, solver = "RELAX-IV")

    expect_equal(length(res$cells), 5)

  }
  res <- solve_reg_fm_prob(node_info = nodes_shell_fmatch(rownames(d), colnames(d)),
                     distspec = d, max.cpt = max.cpt, min.cpt = min.cpt,
                     tolerance = tolerance, omit.fraction = NULL, solver = "LEMON")

  expect_equal(length(res$cells), 5)

})

test_that("NA is true, not string", {
  expect_warning(f1 <- fullmatch(pr ~ cost, min = 10, data = nuclearplants,
                                 within = exactMatch(pr ~ pt, data = nuclearplants)))
  expect_true(all(is.na(f1)))
})
test_that("tolerance relaxed if provided distances get too big",{
### Example thanks to Noah Greifer. 
d <- match_on(pr ~ cost, data = nuclearplants)
d@.Data[1]  <- 3e14
expect_silent(fullmatch(d, data=nuclearplants))
### Based on a matching problem that was incorrectly marked infeasible.
### This subproblem errored instead, but same general concept.   
    mdat  <-
        data.frame(z=c(rep(F, 5), rep(T, 14), rep(F, 9)),
                   x=c(-3.645e+15, -2.962e+15, 7.199e+14,
                       3.204e+14,  -2.262e+14, 4.467e+14,
                       -2.599e+14, 2.664e+14,  -2.866e+15,
                       -3.098e+14, -8.89e+14,  -3.487e+14,
                       5.981e+14,  -1.278e+14, -3.748e+15,
                       4.056e+14,  -2.895e+14, -7.817e+14,
                       -1.102e+14, -3.048e+14, -9.327e+13,
                       -2.734e+14, 3.953e+14,  -8.083e+14,
                       -1.885e+14, -3.315e+14, 2.389e+14,
                       -7.801e+14)
                   )
    mdat  <- as.matrix(mdat)
    row.names(mdat)  <- 1:nrow(mdat)
    expect_silent(pm  <- pairmatch(mdat[,"x"], z=mdat[,"z"], data=mdat))
})