tests/testthat/test-na-rm.R

In afc: Generalized Discrimination Score

# na.rm = TRUE: NA pairs are dropped and the score is computed on complete cases.
# One block per subfunction, then a dispatcher check.

# ── afc.cc ──────────────────────────────────────────────────────────────────

test_that("afc.cc: na.rm=TRUE drops NA obsv, perfect result", {
  obsv <- c(1, NA, 3, 4, 5)
  fcst <- c(1, 2,  3, 4, 5)
  expect_equal(afc.cc(obsv, fcst, na.rm = TRUE), 1)
})

test_that("afc.cc: na.rm=TRUE equals clean call", {
  obsv <- c(1, NA, 3, 4, 5)
  fcst <- c(1, 2,  3, 4, 5)
  expect_equal(afc.cc(obsv, fcst, na.rm = TRUE),
               afc.cc(c(1, 3, 4, 5), c(1, 3, 4, 5)))
})

# ── afc.ce ──────────────────────────────────────────────────────────────────

test_that("afc.ce: na.rm=TRUE drops NA fcst row, perfect result", {
  fcst <- matrix(c(1, 3, NA, 7,
                   2, 4,  6, 8), 4, 2)
  expect_equal(afc.ce(c(1, NA, 3, 4), fcst, na.rm = TRUE), 1)
})

# ── afc.dc ──────────────────────────────────────────────────────────────────

test_that("afc.dc: na.rm=TRUE drops NA obsv, perfect result", {
  obsv <- c(0, NA, 0, 1, 1, 1)
  fcst <- c(1,  2, 3, 4, 5, 6)
  expect_equal(afc.dc(obsv, fcst, na.rm = TRUE), 1)
})

# ── afc.dd ──────────────────────────────────────────────────────────────────

test_that("afc.dd: na.rm=TRUE result equals clean call", {
  obsv_na <- c(0, NA, 0, 1, 1, NA)
  fcst_na <- c(0,  1, 1, 0, 1,  0)
  expect_equal(afc.dd(obsv_na, fcst_na, na.rm = TRUE),
               afc.dd(c(0, 0, 1, 1), c(0, 1, 0, 1)))
})

# ── afc.de ──────────────────────────────────────────────────────────────────

test_that("afc.de: na.rm=TRUE drops NA obsv, perfect result", {
  obsv <- c(0, NA, 1, 1)
  fcst <- matrix(c(1, 2, 5, 6,
                   1, 2, 5, 6), 4, 2)
  expect_equal(afc.de(obsv, fcst, na.rm = TRUE), 1)
})

# ── afc.dm ──────────────────────────────────────────────────────────────────

test_that("afc.dm: na.rm=TRUE drops NA obsv, perfect result", {
  obsv <- c(0, NA, 1, 1)
  fcst <- c(1,  1, 2, 2)
  expect_equal(afc.dm(obsv, fcst, mf = 2, na.rm = TRUE), 1)
})

# ── afc.dp ──────────────────────────────────────────────────────────────────

test_that("afc.dp: na.rm=TRUE drops NA pair, perfect result", {
  obsv <- c(0, NA, 1, 1)
  fcst <- c(0,  0, 1, 1)
  expect_equal(afc.dp(obsv, fcst, na.rm = TRUE), 1)
})

# ── afc.mc ──────────────────────────────────────────────────────────────────

test_that("afc.mc: na.rm=TRUE drops NA obsv, perfect result", {
  obsv <- c(1, NA, 2, 3)
  fcst <- c(1,  2, 3, 4)
  expect_equal(afc.mc(obsv, fcst, m = 3, na.rm = TRUE), 1)
})

# ── afc.me ──────────────────────────────────────────────────────────────────

test_that("afc.me: na.rm=TRUE drops NA fcst row, perfect result", {
  obsv <- c(1, NA, 2, 3)
  fcst <- matrix(c(1, 2, 3, 4,
                   1, 2, 3, 4), 4, 2)
  expect_equal(afc.me(obsv, fcst, m = 3, na.rm = TRUE), 1)
})

# ── afc.mm ──────────────────────────────────────────────────────────────────

test_that("afc.mm: na.rm=TRUE drops NA pair, equals clean call", {
  obsv <- c(1, NA, 2, 3)
  fcst <- c(1,  2, 2, 3)
  expect_equal(afc.mm(obsv, fcst, mv = 3, mf = 3, na.rm = TRUE),
               afc.mm(c(1, 2, 3), c(1, 2, 3), mv = 3, mf = 3))
})

# ── afc.mp ──────────────────────────────────────────────────────────────────

test_that("afc.mp: na.rm=TRUE drops NA obsv, perfect result", {
  obsv <- c(1, NA, 3)
  fcst <- diag(3)
  expect_equal(afc.mp(obsv, fcst, m = 3, na.rm = TRUE), 1)
})

# ── afc.nn ──────────────────────────────────────────────────────────────────

test_that("afc.nn: na.rm=TRUE drops NA pair, equals clean call", {
  obsv <- c(1, NA, 2, 3)
  fcst <- c(1,  2, 2, 3)
  expect_equal(afc.nn(obsv, fcst, m = 3, na.rm = TRUE),
               afc.nn(c(1, 2, 3), c(1, 2, 3), m = 3))
})

# ── afc.np ──────────────────────────────────────────────────────────────────

test_that("afc.np: na.rm=TRUE drops NA obsv, perfect result", {
  # NA at position 2; after drop obsv=c(1,2,3), fcst=diag(3) — all 3 categories kept
  obsv <- c(1, NA, 2, 3)
  fcst <- rbind(c(1, 0, 0), c(0, 1, 0), c(0, 1, 0), c(0, 0, 1))
  expect_equal(afc.np(obsv, fcst, m = 3, na.rm = TRUE), 1)
})

# ── afc() dispatcher ─────────────────────────────────────────────────────────

test_that("afc(): na.rm=TRUE c-c, perfect after NA drop", {
  obsv <- c(1, NA, 3, 4, 5)
  fcst <- c(1,  2, 3, 4, 5)
  expect_equal(afc(obsv, fcst, obsv.type = "c", fcst.type = "c", na.rm = TRUE), 1)
})

test_that("afc(): na.rm=TRUE d-c, perfect after NA drop", {
  obsv <- c(0, NA, 0, 1, 1, 1)
  fcst <- c(1,  2, 3, 4, 5, 6)
  expect_equal(afc(obsv, fcst, obsv.type = "d", fcst.type = "c", na.rm = TRUE), 1)
})

test_that("afc(): na.rm=TRUE d-d, equals clean call", {
  obsv_na <- c(0, NA, 0, 1, 1, NA)
  fcst_na <- c(0,  1, 1, 0, 1,  0)
  expect_equal(
    afc(obsv_na, fcst_na, obsv.type = "d", fcst.type = "d", na.rm = TRUE),
    afc(c(0, 0, 1, 1), c(0, 1, 0, 1), obsv.type = "d", fcst.type = "d")
  )
})