tests/testthat/test-hhh4_NA.R

In surveillance: Temporal and Spatio-Temporal Modeling and Monitoring of Epidemic Phenomena

### fitting hhh4() models to time series with missing values

data("influMen")
fluMen <- disProg2sts(influMen)
## set some observations to NA
set.seed(3)
is.na(fluMen@observed) <- sample(length(fluMen@observed), 100)

## compare endemic-only model against NegBin-GLM
form <- addSeason2formula(f = ~ -1 + fe(1, which = c(TRUE, TRUE)), S = c(3, 1))
fitHHH <- hhh4(fluMen,
               list(end = list(f=form), family = "NegBin1", subset = 1:nrow(fluMen)))
fitGLM <- MASS::glm.nb(
    formula = observed ~ -1 + unit + sin(2*pi*t/52):unit + cos(2*pi*t/52):unit +
        I(sin(4*pi*t/52)*unitI) + I(cos(4*pi*t/52)*unitI) +
        I(sin(6*pi*t/52)*unitI) + I(cos(6*pi*t/52)*unitI),
    data = transform(tidy.sts(fluMen), t = epoch - 1, unitI = unit == "influenza"))

expect_equal(logLik(fitHHH), logLik(fitGLM))
expect_equal(fitted(fitHHH)[!terms(fitHHH)$isNA], unname(fitted(fitGLM)))
expect_equivalent(coef(fitHHH)[["overdisp"]], 1/fitGLM$theta)
idxhhh <- c(1:2, 7:10, 3:6)
expect_equivalent(head(fitHHH$coefficients, -1), fitGLM$coefficients[idxhhh])
expect_equivalent(head(fitHHH$se, -1), summary(fitGLM)$coefficients[idxhhh, 2],
                  tolerance = 0.01)

### compare AR-only model against NegBin-GLM
## meningococcal counts are strictly positive so plain AR works
men <- fluMen[,"meningococcus"]
fitHHH_AR <- hhh4(men, list(end = list(f = ~-1), family = "NegBin1",
                            ar = list(f = addSeason2formula(~1))))
fitGLM_AR <- MASS::glm.nb(
    formula = addSeason2formula(observed ~ 1 + offset(log(Ylag))),
    data = transform(tidy.sts(men), t = epoch - 1, Ylag = c(NA, head(observed, -1))))

expect_equal(logLik(fitHHH_AR), logLik(fitGLM_AR))
expect_equal(fitted(fitHHH_AR)[!terms(fitHHH_AR)$isNA[fitHHH_AR$control$subset,,drop=FALSE]],
             unname(fitted(fitGLM_AR)))
expect_equivalent(coef(fitHHH_AR)[["overdisp"]], 1/fitGLM_AR$theta)
expect_equivalent(head(fitHHH_AR$coefficients, -1), fitGLM_AR$coefficients)
expect_equivalent(head(fitHHH_AR$se, -1), summary(fitGLM_AR)$coefficients[, 2],
                  tolerance = 0.05)

### compare NE-only model against NegBin-GLM (where NE is actually AR as above)
expect_warning(
fitHHH_NE <- hhh4(men, list(end = list(f = ~-1), family = "NegBin1",
                            ne = list(f = addSeason2formula(~1), weights = diag(1))))
, "requires a multivariate")
expect_equivalent(fitHHH_AR, fitHHH_NE, ignore = c("control", "lags"))
expect_equal(meanHHH(fitHHH_AR$coefficients, terms(fitHHH_AR))$epi.own,
             meanHHH(fitHHH_NE$coefficients, terms(fitHHH_NE))$epi.neighbours)
if (dev.capabilities("capture")[[1L]]) { # e.g. not in tinytest as that uses pdf
plot(fitHHH_AR, legend = FALSE, col = c(8,8,8)); plotARfit <- dev.capture()
plot(fitHHH_NE, legend = FALSE, col = c(8,8,8)); plotNEfit <- dev.capture()
expect_identical(plotARfit, plotNEfit)
}