tests/testthat/test_matrix.R

In heemod: Markov Models for Health Economic Evaluations

test_that(
  "Matrix definition", {
    mat1 <- define_transition(
      state_names = c("X1", "X2"),
      .3, .7,
      .6, .4
    )
    expect_output(
      str(mat1),
      'List of 4
 $ cell_1_1: language ~0.3',
      fixed = TRUE
    )
    expect_error(
      define_transition(
        state_names = c("X1", "X1"),
        .3, .7,
        .6, .4
      )
    )
    expect_error(
      define_transition(
        state_names = c("X1", "X2", "X3"),
        .3, .7,
        .6, .4
      )
    )
    expect_error(
      define_transition(
        state_names = c("X1", "X2"),
        .3, .7,
        .6, .4, .4
      )
    )
    expect_error(
      modify(
        mat1,
        marcel = .4,
        cell_1_2 = .6
      )
    )
    expect_output(
      str(
        modify(
          mat1,
          cell_1_1 = .4,
          cell_1_2 = .6
        )
      ),
      'List of 4
 $ cell_1_1: language ~0.4',
      fixed = TRUE
    )
    expect_output(
      print(mat1),
      'A transition matrix, 2 states.

   X1  X2 
X1 0.3 0.7
X2 0.6 0.4',
      fixed = TRUE
    )
  }
)

test_that(
  "Functions on matrix objects", {
    mat1 <- define_transition(
      state_names = c("X1", "X2"),
      .3, .7,
      .6, .4
    )
    plot(mat1)
    expect_equal(
      heemod:::get_matrix_order(mat1),
      2
    )
    expect_equal(
      get_state_names(mat1),
      c("X1", "X2")
    )
    
    test_array <- array(0, dim = c(2, 2, 2))
    test_array[1,,] <- c(1, -1, 0, 2)
    test_array[2,,] <- c(1, 0, 1, 1)
    attr(test_array, "state_names") <- c("A", "B")
    
    expect_error(
      check_matrix(test_array),
      "rows sum to 1"
    )
    test_array[2,1, 2] <- 0
    expect_error(
      check_matrix(test_array),
      "outside the interval [0 - 1]",
      fixed = TRUE
    )
    
    class(test_array) <- "not an array"
    expect_error(
      check_matrix(test_array),
      'inherits(x, "array")',
      fixed = TRUE
    )
    
    ## test that we get expected error with expanded states
    par1 <- define_parameters(a = ifelse(state_time == 3, 1.1, 0.5))
    mat1 <- define_transition(a, C, 0.2, 0.8, state_names = c("A","B"))
    
    A1 <- define_state(cost = 1, utility = 1)
    B1 <- define_state(cost = 2, utility = 2)
    st1 <- define_strategy(A = A1, B = B1, transition = mat1)
    
    expect_error(run_model(
      st1, init = c(100, 0), cycles = 5, parameters = par1
    ),
    "outside the interval [0 - 1]",
    fixed = TRUE)
    ## and that it works without the error
    par1 <- define_parameters(a = ifelse(state_time == 3, 0.4, 0.5))
    
    expect_identical(
      class(run_model(st1, init = c(100, 0), cycles = 5, parameters = par1,
              cost = cost, effect = utility))[1],
      "run_model")
  }
)

test_that(
  "Matrix evaluation", {
    par1 <- define_parameters(
      a = .1,
      b = 1 / (model_time + 1)
    )
    mat1 <- define_transition(
      state_names = c("X1", "X2"),
      1-a, a,
      1-b, b
    )
    matC <- define_transition(
      state_names = c("X1", "X2"),
      C, a,
      C, b
    )
    e_par1 <- heemod:::eval_parameters(
      par1, 10
    )
    e_mat <- heemod:::eval_transition(
      mat1, e_par1
    )
    e_matC <- heemod:::eval_transition(
      matC, e_par1
    )
    expect_output(
      str(e_mat),
      'List of 10
 $ : num [1:2, 1:2] 0.9 0.5 0.1 0.5
 $ : num [1:2, 1:2] 0.9 0.667 0.1 0.333
 $ : num [1:2, 1:2] 0.9 0.75 0.1 0.25
 $ : num [1:2, 1:2] 0.9 0.8 0.1 0.2
 $ : num [1:2, 1:2] 0.9 0.833 0.1 0.167
 $ : num [1:2, 1:2] 0.9 0.857 0.1 0.143
 $ : num [1:2, 1:2] 0.9 0.875 0.1 0.125
 $ : num [1:2, 1:2] 0.9 0.889 0.1 0.111
 $ : num [1:2, 1:2] 0.9 0.9 0.1 0.1
 $ : num [1:2, 1:2] 0.9 0.9091 0.1 0.0909
 - attr(*, "class")= chr [1:2] "eval_matrix" "list"
 - attr(*, "state_names")= chr [1:2] "X1" "X2"',
      fixed = TRUE
    )
    expect_output(
      print(e_mat),
      'An evaluated transition matrix, 2 states, 10 markov cycles.

State names:

X1
X2

[[1]]
     [,1] [,2]
[1,]  0.9  0.1
[2,]  0.5  0.5',
      fixed = TRUE
    )
    expect_equal(
      get_state_names(e_mat),
      c("X1", "X2")
    )
    expect_equal(
      get_matrix_order(e_mat), 2
    )
    expect_equal(e_mat, e_matC)
  }
)


test_that(
  "C bug #82 doesnt come back", {
    sampleTM <- define_transition(0.1, 0.1, C, C, 0.3, 0.25, C, 0, 0.5)
    A <- define_state(cost = 1, utility = 2)
    B <- define_state(cost = 5, utility = 7)
    C <- define_state(cost = 4, utility = 4)
    sample_mod <- define_strategy(transition = sampleTM, A = A,
                                  B = B, C = C)
    res <- run_model(sample_mod, cost = cost, effect = utility,
                     method = "end")
    
    
    expect_equal(
      res$run_model$cost, 3800
    )
  }
)

test_that("get_counts_diff works correctly", {
  sampleTM <- define_transition(0.1, 0.1, C, 
                                C  , 0.3, 0.25, 
                                C  , 0  , 0.5)
  A <- define_state(cost = 1, utility = 2)
  B <- define_state(cost = 5, utility = 7)
  C <- define_state(cost = 4, utility = 4)
  sample_mod <- define_strategy(transition = sampleTM, A = A,
                                B = B, C = C)
  res <- run_model(sample_mod, cost = cost, effect = utility,
                   cycles = 3)
  count_diff <- get_counts_diff(res$eval_strategy_list$I$transition, 
                                init = res$eval_strategy_list$I$e_init, inflow = res$eval_strategy_list$I$e_inflow)
  expected_count <-list(c(A = 1000, B = 0, C = 0),
                        c(A = 100, B = 100, C = 800),
                        c(A = 455, B = 40, C = 505),
                        c(A = 316, B = 57.5, C = 626.5))
  expected_diff <- list(matrix(c(-900, 100, 800, rep(0,6)), ncol = 3, byrow = TRUE),
                        matrix(c(-90, 10, 80, 45, -70, 25, 400, 0, -400), ncol = 3, byrow = TRUE),
                        matrix(c(-409.5, 45.5, 364, 18, -28, 10, 252.5, 0, -252.5), ncol = 3, byrow = TRUE),
                        NULL
  )
  expect_equal(lapply(count_diff, `[[`, 1), expected_count)
  expect_equal(lapply(count_diff, `[[`, 2), expected_diff)  
})