tests/testthat/test_phase.R

In msm: Multi-State Markov and Hidden Markov Models in Continuous Time

test_that("one phased state", {
  psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, fixedpars=TRUE,
                  phase.states=c(1))
  expect_equal(psor.msm$minus2loglik, 1308.35590680014, tol=1e-06)
}
)

test_that("working example",{
  skip_on_cran()
  ## SIMULATE
  mst1 <- 5 # Short-stay mean 
  mst2 <- 30 # Long-stay mean 
  p2 <- 0.9 # Long-stay probability 
  q23 <- 1/5 # Transition rate between phases
  
  l1 <- (p2/mst1)
  mu1 <- (1-p2)/mst1
  mu2 <- 1/(mst2-mst1)
  Q <- rbind(c(0,l1,mu1*0.4,mu1*0.6),
             c(0,0,mu2*0.4,mu2*0.6),
             c(0,0,0,q23),
             c(0,0,0,0))
  # Given the hidden state, the observed state is deterministic
  E <- rbind(c(1,0,0,0),
             c(1,0,0,0),
             c(0,1,0,0),
             c(0,0,1,0))
  nsubj <- 1000; nobspt <- 10
  set.seed(1)
  sim.df <- data.frame(subject = rep(1:nsubj, each=nobspt), time = seq(0, 100, length=nobspt))
  sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=Q, ematrix=E)
  statetable.msm(obs, subject, sim2.df)
  
  ## FIT
  Q3 <- rbind(c(0,0.5,0.5),c(0,0,0.5),c(0,0,0))
  s.msm <- msm(obs ~ time, subject=subject, data=sim2.df, phase.states=1, qmatrix=Q3, # default inits
               phase.inits=list(list(trans=0.05, 
                                     exit=matrix(c(0.1,0.1,0.1,0.1),nrow=2))),
               control=list(trace=1,REPORT=1,fnscale=50000,maxit=10000),method="BFGS")
  
  # Parameter estimates should agree with the values used for simulation
  s.msm 
  c(l1, mu1*0.4, mu1*0.6, mu2*0.4, mu2*0.6, q23)
  means <- phasemeans.msm(s.msm)
  
  expect_equal(means[[1,"Short stay mean"]], 5, tol=1)
  expect_equal(means[[1,"Long stay mean"]], 30, tol=5)
  expect_equal(means[[1,"Long stay probability"]], 0.9, tol=0.1)
})


test_that("two phased states", {
  ## note phase transition within state 2 appears hard to estimate.
  psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, fixedpars=TRUE,
                  phase.states=c(1,2))
  expect_equal(psor.msm$minus2loglik, 1303.768173132893, tol=1e-06)
})


test_that("supplying initial values",{
  psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, phase.states=c(1,2),
                  phase.inits = list(
                    list(trans=c(0.42032), exit=c(0.17404,0.04809)),
                    list(trans=c(0.42032), exit=c(0.17404,0.04809))),                 
                  fixedpars=TRUE)
  expect_equal(psor.msm$minus2loglik, 1280.788860486683, tol=1e-06)
})

test_that("errors in initial values",{
  expect_error(psor2.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, phase.states=c(1,2), phase.inits = "foo"), "phase.inits should be a list")
  expect_error(psor2.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, phase.states=c(1,2), phase.inits = list(1,2,3)), "phase.inits of length 3, but there are 2 phased states")
  expect_error(psor2.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, phase.states=c(1,2), phase.inits = list(1,2)), "phase.inits.+ list of length 1, should be 2")
  expect_error(psor2.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, phase.states=c(1), phase.inits = list(list(trans=c(0.42032, 1), exit=c(0.17404,0.04809)))), "phase.inits.+trans of length 2, should be 1")
  expect_error(psor2.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, phase.states=c(1), phase.inits = list(list(trans=c(0.42032), exit=c(0.17404,0.04809,1,1)))), "phase.inits.+exit has 4 columns, should be 2")
  expect_error(psor2.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, phase.states=c(1), phase.inits = list(list(trans=c(0.42032), exit=matrix(c(0.17404,0.04809,1,1),ncol=2,byrow=TRUE)))), "phase.inits.+exit has 2 rows, but there are 1 exit states from this state")
})


test_that("with censoring", {
  psor2 <- psor
  psor2$state[c(16,18)] <- 99
  psorc.msm <- msm(state ~ months, subject=ptnum, data=psor2, qmatrix = psor.q, fixedpars=TRUE,
                   censor = 99, censor.states=c(3,4))
  expect_equal(psorc.msm$minus2loglik, 1290.189703452163, tol=1e-06)
})


test_that("HMM on top", {
  ### Note 1.6 clarifies obstrue not supported for hmmCat: so test result in 1.5 wrong
  miscnew.msm <- msm(state ~ years, subject = PTNUM, data = cav,
                     qmatrix = oneway4.q, death = 5, #obstrue=firstobs,
                     fixedpars=TRUE,
                     # could try to fit, but weakly identifiable.  fit seems improved though (-2LL 3864 vs 3951)
                     # control=list(trace=1,REPORT=1,fnscale=4000, maxit=10000),
                     phase.states = 1, 
                     hmodel=list(
                       hmmCat(prob=c(0.9, 0.1, 0, 0)),
                       hmmCat(prob=c(0.1, 0.8, 0.1, 0)),
                       hmmCat(prob=c(0, 0.1, 0.9, 0)), hmmIdent(4))
  )
  expect_equal(miscnew.msm$minus2loglik, 4357.70908245511, tol=1e-06)  
})