tests/testthat/test-extended.R

In seqHMM: Mixture Hidden Markov Models for Social Sequence Data and Other Multivariate, Multichannel Categorical Time Series

run_extended_tests <- identical(Sys.getenv("SEQHMM_EXTENDED_TESTS"), "true")

test_that(
  "parameters are recovered and `mnhmm` and `mhmm` give equivalent results", {
    skip_if_not(run_extended_tests)
    
    set.seed(123)
    n_seq <- 5000
    t_seq <- 50
    pi <- list(c(0.6, 0.4), c(0.8, 0.2))
    omega = c(0.3, 0.7)
    A <- list(diag(0.8, 2) + 0.1, matrix(c(0.95, 0.2, 0.05, 0.8), 2, 2))
    B <- list(
      list(rbind(c(0.5,0.2,0.2,0.1), c(0.1, 0.1, 0.7, 0.1))), 
      list(rbind(c(0.1,0.1,0.4,0.4), c(0.2, 0.3, 0.1, 0.4)))
    )
    expect_error(
      sim <- simulate_mnhmm(
        2, 2, y ~ 1,
        data = data.frame(
          id = rep(1:n_seq, each = t_seq),
          time = rep_len(1:t_seq, n_seq),
          y = factor(sample(letters[1:4], t_seq * n_seq, replace = TRUE), 
                     levels = letters[1:4])),
        id = "id", time = "time",
        coefs = list(cluster_probs = omega, initial_probs = pi, 
                     transition_probs = A, emission_probs = B)
      ),
      NA
    )
    set.seed(1)
    expect_error(
      fit_dnm <- estimate_mnhmm(
        n_states = 2, n_clusters = 2,
        data = sim$data, time = "time", id = "id", 
        emission_formula = y ~ 1, 
        inits = sim$model$etas, init_sd = 0.1,
        method = "DNM", restarts = 50
      ),
      NA
    )
    set.seed(1)
    expect_error(
      fit_em <- estimate_mnhmm(
        n_states = 2, n_clusters = 2,
        data = sim$data, time = "time", id = "id", 
        emission_formula = y ~ 1, 
        inits = sim$model$etas, init_sd = 0.1,
        method = "EM", restarts = 50
      ),
      NA
    )
    
    expect_error(
      init <- build_mhmm(
        observations = data_to_stslist(sim$data, "id", "time", "y"),
        transition_probs = A,
        emission_probs = list(B[[1]][[1]], B[[2]][[1]]),
        initial_probs = pi,
        coefficients = matrix(c(0, sim$model$gammas$gamma_omega[2]*2), 1, 2)
      ),
      NA
    )
    set.seed(1)
    expect_error(
      suppressWarnings(fit_old <- fit_model(
        init, 
        control_em = list(restart = list(times = 50))
      )$model
      )
      ,
      NA
    )
    
    expect_equal(logLik(fit_dnm), logLik(fit_em), tolerance = 0.1)
    expect_equal(logLik(fit_dnm), logLik(fit_old), tolerance = 0.1)
    
    expect_error(coef_true <- coef(sim$model), NA)
    expect_error(coef_est <- coef(fit_dnm), NA)
    expect_equal(coef_est$cluster, coef_true$cluster, tolerance = 0.1)
    expect_equal(coef_est$initial, coef_true$initial, tolerance = 0.1)
    expect_equal(coef_est$emission, coef_true$emission, tolerance = 0.1)
    expect_equal(coef_est$transition, coef_true$transition, tolerance = 0.1)
  }
)

test_that("Mixture FAN-HMM works properly", {
  skip_if_not(run_extended_tests)
  set.seed(123)
  n_seq <- 500
  t_seq <- 20
  pi <- list(c(0.6, 0.4), c(0.8, 0.2))
  omega = c(0.3, 0.7)
  A <- list(diag(0.8, 2) + 0.1, matrix(c(0.95, 0.2, 0.05, 0.8), 2, 2))
  B <- list(
    list(rbind(c(0.5,0.2,0.2,0.1), c(0.1, 0.1, 0.7, 0.1))), 
    list(rbind(c(0.1,0.1,0.4,0.4), c(0.2, 0.3, 0.1, 0.4)))
  )
  expect_error(
    sim <- simulate_mnhmm(
      2, 2, y ~ lag(y),
      data = data.frame(
        id = rep(1:n_seq, each = t_seq),
        time = rep_len(1:t_seq, n_seq),
        y = factor(sample(letters[1:4], t_seq * n_seq, replace = TRUE), 
                   levels = letters[1:4])),
      id = "id", time = "time",
      coefs = list(cluster_probs = omega, initial_probs = pi, 
                   transition_probs = A, emission_probs = B),
      init_sd = 1
    ),
    NA
  )
  y_prior <- prop.table(table(sim$data$y[sim$data$time == 1]))
  set.seed(1)
  expect_error(
    fit_dnm <- estimate_mnhmm(
      n_states = 2, n_clusters = 2,
      data = sim$data, time = "time", id = "id", 
      emission_formula = y ~ lag(y), 
      inits = sim$model$etas, init_sd = 0.1, lambda = 0.1, restarts = 20,
      method = "DNM", prior_obs = list(y = y_prior)
    ),
    NA
  )
  set.seed(1)
  expect_error(
    fit_em <- estimate_mnhmm(
      n_states = 2, n_clusters = 2,
      data = sim$data, time = "time", id = "id", 
      emission_formula = y ~ lag(y), 
      inits = sim$model$etas, init_sd = 0.1, lambda = 0.1, restarts = 20,
      method = "EM", prior_obs = list(y = y_prior)
    ),
    NA
  )
  expect_equal(logLik(fit_dnm), logLik(fit_em),tolerance = 0.1)
  expect_error(coef_dnm <- coef(fit_dnm), NA)
  expect_error(coef_em <- coef(fit_em), NA)
  expect_equal(coef_dnm$cluster, coef_em$cluster, tolerance = 0.1)
  expect_equal(coef_dnm$initial, coef_em$initial, tolerance = 0.1)
  expect_equal(coef_dnm$emission, coef_em$emission, tolerance = 0.1)
  expect_equal(coef_dnm$transition, coef_em$transition, tolerance = 0.1)
})