tests/testthat/test-visitation.R

In andrewmarx/samc: Spatial Absorbing Markov Chains

context("Visitation")


for(test in testlist) {
  # Create the samc object
  samc_obj <- test$samc

  # Extract Q
  Q <- samc_obj$q_matrix
  Q <- as.matrix(Q)

  # Prepare the occupancy data
  occ_ras = raster::raster(test$init)
  pv = as.vector(occ_ras)
  pv = pv[is.finite(pv)]


  #
  # Short-term tests
  #

  Qt <- diag(nrow(Q))
  base_result = Qt
  for (i in 1:(time - 1)) {
    Qt <- Qt %*% Q
    base_result <- base_result + Qt
  }

  test_that("Testing visitation(samc, time)", {
    samc_obj$override = TRUE
    r = visitation(samc_obj, time = time)
    samc_obj$override = FALSE

    expect_equal(dim(r), dim(base_result))
    expect_equal(as.vector(r), as.vector(base_result))
  })

  test_that("Testing visitation(samc, origin, time)", {
    result = visitation(samc_obj, origin = row_vec[1], time = time)
    result_char = visitation(samc_obj, origin = as.character(row_vec[1]), time = time)
    expect_equal(result, result_char)

    expect_equal(as.vector(result), as.vector(base_result[row_vec[1], ]))
  })

  test_that("Testing visitation(samc, dest, time)", {
    result = visitation(samc_obj, dest = col_vec[1], time = time)
    result_char = visitation(samc_obj, dest = as.character(col_vec[1]), time = time)
    expect_equal(result, result_char)

    expect_equal(as.vector(result), as.vector(base_result[, col_vec[1]]))
  })

  test_that("Testing visitation(samc, init, time)", {
    result = visitation(samc_obj, init = test$init, time = time)

    r = pv %*% base_result
    expect_equal(as.vector(result), as.vector(r))
  })


  #
  # Long-term tests
  #

  I = diag(nrow(Q))
  base_result = solve(I - Q)

  test_that("Testing visitation(samc)", {
    samc_obj$override <- TRUE
    r <- visitation(samc_obj)
    samc_obj$override <- FALSE

    expect_equal(dim(r), dim(base_result))
    expect_equal(as.vector(r), as.vector(base_result))
  })

  test_that("Testing visitation(samc, origin)", {
    for (i in 1:length(row_vec)) {
      r <- visitation(samc_obj, origin = row_vec[i])
      r_char <- visitation(samc_obj, origin = as.character(row_vec[i]))

      expect_equal(r, r_char)
      expect_equal(r, base_result[row_vec[i], ], check.names = FALSE)
    }
  })

  test_that("Testing visitation(samc, dest)", {
    for (i in 1:length(row_vec)) {
      r <- visitation(samc_obj, dest = col_vec[i])
      r_char <- visitation(samc_obj, dest = as.character(col_vec[i]))

      expect_equal(r, r_char)
      expect_equal(r, base_result[, col_vec[i]], check.names = FALSE)
    }
  })

  test_that("Testing visitation(samc, origin, dest)", {
    vector_result <- visitation(samc_obj, origin = row_vec, dest = col_vec)
    vector_result_char <- visitation(samc_obj, origin = as.character(row_vec), dest = as.character(col_vec))

    expect_equal(vector_result, vector_result_char)

    for (i in 1:length(row_vec)) {
      r <- visitation(samc_obj, origin = row_vec[i], dest = col_vec[i])

      expect_equal(vector_result[i], r)
      expect_equal(r, base_result[row_vec[i], col_vec[i]], check.names = FALSE)
    }
  })


  # TODO visitation_net() tests
}