tests/testthat/test-cubical-4dim.R

In rrrlw/ripserr: Calculate Persistent Homology with Ripser-Based Engines

context("cubical 4-dim")
library("ripserr")

test_that("basic 4-dim cubical works", {
  # reproducibility
  set.seed(42)
  
  # create dataset to be used
  tester <- rnorm(5 ^ 4)
  dim(tester) <- rep(5, 4)
  
  # calculate cubical complex for 4-dim voxel data
  cub_comp <- ripserr::cubical(tester)
  
  # test cubical complex frequency/counts
  expect_equal(ncol(cub_comp), 3)
  expect_true(nrow(cub_comp) > 0)
  
  counts <- base::table(cub_comp[, 1])
  names(counts) <- NULL
  counts <- as.numeric(counts)
  
  # at least 1 feature from each dimension
  expect_true(counts[1] > 0)
  expect_true(counts[2] > 0)
  expect_true(counts[3] > 0)
  expect_true(counts[4] > 0)
  
  # make sure no births after deaths
  expect_equal(0, sum(cub_comp[, 2] > cub_comp[, 3]))
})

test_that("4-dim calculation returns same values as validated tests", {
  # read validated input and output data
  input_data <- readRDS("input_4dim.rds")
  output_data <- readRDS("output_4dim.rds")
  
  # re-calculate output w/ ripserr
  THRESH <- 9999
  test_output <- ripserr::cubical(input_data, threshold = THRESH)
  
  # filter out threshold value features to avoid spurious differences in equality
  output_data <- subset(output_data, death < THRESH)
  test_output <- subset(test_output, death < THRESH)
  
  # ensure no NAs
  expect_equal(0, sum(is.na(output_data)))
  expect_equal(0, sum(is.na(test_output)))
  
  # make sure # of features is close enough
  expect_equal(nrow(test_output), nrow(output_data), tolerance = 5)
  
  # check means of births and deaths to ensure close enough
  expect_equal(mean(test_output$birth), mean(output_data$birth), tolerance = 0.025)
  expect_equal(mean(test_output$death), mean(output_data$death), tolerance = 0.025)
})