tests/neutral-site-home-field.R

In mvglmmRank: Multivariate Generalized Linear Mixed Models for Ranking Sports Teams

library(mvglmmRank)

check_true <- function(value, message) {
  if (!isTRUE(value)) {
    stop(message, call. = FALSE)
  }
}

check_fit <- function(data, method, home.field, has.neutral) {
  fit <- mvglmmRank(
    data,
    method = method,
    first.order = TRUE,
    home.field = home.field,
    max.iter.EM = 1,
    verbose = FALSE,
    Hessian = FALSE,
    REML.N = FALSE
  )

  label <- paste0("method=", method, ", home.field=", home.field)

  check_true(inherits(fit, "mvglmmRank"),
             paste(label, "did not return an mvglmmRank object"))
  check_true(identical(isTRUE(fit$home.field), isTRUE(home.field)),
             paste(label, "returned the wrong home.field value"))

  if (method %in% c("N", "NB")) {
    expected <- if (home.field) {
      if (has.neutral) 3L else 2L
    } else {
      1L
    }
    check_true(length(fit$n.mean) == expected,
               paste(label, "returned an unexpected n.mean length"))
  }

  if (method %in% c("P0", "P1", "PB0", "PB1")) {
    expected <- if (home.field) {
      if (has.neutral) 3L else 2L
    } else {
      1L
    }
    check_true(length(fit$p.mean) == expected,
               paste(label, "returned an unexpected p.mean length"))
  }

  if (method %in% c("B", "NB", "PB0", "PB1", "NB.mov")) {
    check_true(length(fit$b.ratings) > 0L,
               paste(label, "did not return binary ratings"))
  }

  if (method %in% c("NB.mov", "N.mov")) {
    check_true(length(fit$n.mean) == 1L,
               paste(label, "returned an unexpected margin mean length"))
    if (!home.field) {
      check_true(isTRUE(all.equal(as.numeric(fit$n.mean), 0, tolerance = 1e-8)),
                 paste(label, "did not omit the fixed margin home effect"))
    }
  }

  invisible(fit)
}

check_prediction <- function(fit, home, away, neutral.site, label) {
  out <- capture.output(game.pred(fit, home = home, away = away,
                                  neutral.site = neutral.site))
  check_true(length(out) > 0L, paste(label, "did not print a prediction"))
  invisible(out)
}

data(f2012)

home <- as.character(f2012$home[1])
away <- as.character(f2012$away[1])

# CRAN-safe regression coverage for the fixed no-home-field branch.
check_fit(f2012, "N.mov", TRUE, has.neutral = TRUE)
check_fit(f2012, "N.mov", FALSE, has.neutral = TRUE)

fit_home <- check_fit(f2012, "PB0", TRUE, has.neutral = TRUE)
fit_no_home <- check_fit(f2012, "PB0", FALSE, has.neutral = TRUE)

check_prediction(fit_home, home, away, neutral.site = FALSE,
                 label = "home-site prediction")
check_prediction(fit_home, home, away, neutral.site = TRUE,
                 label = "neutral-site prediction")
check_prediction(fit_no_home, home, away, neutral.site = TRUE,
                 label = "no-home-field prediction")

if (identical(Sys.getenv("NOT_CRAN"), "true")) {
  data(nfl2012)

  methods <- c("B", "P0", "P1", "N", "NB", "PB0", "PB1", "NB.mov", "N.mov")

  for (method in methods) {
    for (home.field in c(TRUE, FALSE)) {
      check_fit(f2012, method, home.field, has.neutral = TRUE)
      check_fit(nfl2012, method, home.field, has.neutral = FALSE)
    }
  }

  fit_home <- check_fit(f2012, "PB0", TRUE, has.neutral = TRUE)
  fit_no_home <- check_fit(f2012, "PB0", FALSE, has.neutral = TRUE)

  check_prediction(fit_home, home, away, neutral.site = FALSE,
                   label = "extended home-site prediction")
  check_prediction(fit_home, home, away, neutral.site = TRUE,
                   label = "extended neutral-site prediction")
  check_prediction(fit_no_home, home, away, neutral.site = TRUE,
                   label = "extended no-home-field prediction")
}