tests/testthat/test_HMM_algo.R

In jonotuke/HMMCPP: Implementation of HMM package in Rcpp

library(HMMCPP)

context("Check HMM algorithms")

library(HMM)
## Set up biased coin example ----
start_prob <- rep(1/2,2)
symbols <- 1:6
states <- c("F","B")
A <- matrix(c(0.9, 0.1, 0.1, 0.9),
            ncol = 2,
            byrow = TRUE)
B <- matrix(c(1/6, 1/6, 1/6, 1/6, 1/6, 1/6,
              0.1, 0.1, 0.1, 0.1, 0.1, 0.5),
            ncol = 6, byrow = TRUE)

## Create HMM object ----
hmm <- initHMM(States = states,
               Symbols = symbols,
               startProbs = start_prob,
               transProbs = A, emissionProbs = B)

hmm
## Sim some data ----
n <- 2000
sim2 <- sim_HMM(initial_prop = start_prob,
                n_sims = n, A = A,
                state_sym = states,
                B = B,
                obs_sym = symbols)

test_that("rcpp_forward works",{
  tmp1 <- forward(hmm, sim2$observation)
  tmp2 <- Rcpp_forward(states = states, symbols = symbols,
                       pi = start_prob, A = A, B = B,
                       obs = sim2$observation)
  expect_equivalent(tmp1, tmp2$alpha)
})

test_that("rcpp_backward works",{
  tmp1 <- backward(hmm, sim2$observation)
  tmp2 <- Rcpp_backward(states = states, symbols = symbols,
                        pi = start_prob, A = A, B = B,
                        obs = sim2$observation)
  expect_equivalent(tmp1, tmp2)
})

test_that("rcpp_viterbi works",
          {
            tmp1 <- viterbi(hmm, sim2$observation)
            tmp2 <- Rcpp_viterbi(states = states, symbols = symbols,
                                 pi = start_prob, A = A, B = B,
                                 obs = sim2$observation)
            expect_equivalent(tmp1, tmp2)
          }
)

test_that("rcpp_forward_backward works",{
  tmp1 <- posterior(hmm, sim2$observation)
  tmp2 <- Rcpp_forward_backward(states = states, symbols = symbols,
                                pi = start_prob, A = A, B = B,
                                obs = sim2$observation)
  expect_equivalent(tmp1, tmp2)
})

test_that("rcpp_viterbi_training works",{
  sim2 <- sim_HMM(initial_prop = start_prob,
                  n_sims = 200, A = A,
                  state_sym = states,
                  B = B,
                  obs_sym = symbols)
  tmp1 <- viterbiTraining(hmm, sim2$observation)
  tmp2 <- Rcpp_viterbi_training(states = states,
                                symbols = symbols,
                                pi = start_prob,
                                A = A,
                                B = B,
                                obs = sim2$observation)
  expect_equivalent(tmp1$hmm$transProbs, tmp2$A)
  expect_equivalent(tmp1$hmm$emissionProbs, tmp2$B)
  expect_equivalent(tmp1$difference, tmp2$diff)
})

test_that("rcpp_baum_welch works",{
  sim2 <- sim_HMM(initial_prop = start_prob,
                  n_sims = 200, A = A,
                  state_sym = states,
                  B = B,
                  obs_sym = symbols)
  tmp1 <- baumWelch(hmm, sim2$observation)
  tmp2 <- Rcpp_baum_welch(states = states,
                          symbols = symbols,
                          pi = start_prob,
                          A = A,
                          B = B,
                          obs = sim2$observation)
  expect_equivalent(tmp1$hmm$transProbs, tmp2$A)
  expect_equivalent(tmp1$hmm$emissionProbs, tmp2$B)
  expect_equivalent(tmp1$difference, tmp2$diff)
})