tests/testthat/test-stratification.R

In familiar: End-to-End Automated Machine Learning and Model Evaluation

testthat::skip_on_cran()

# Find available stratification methods.
stratification_methods <- familiar:::.get_available_stratification_methods()

if (!familiar:::test_data_package_installed("survival")) testthat::skip()
if (!rlang::is_installed("power.transform")) testthat::skip()

# Test for good dataset.
for (stratification_method in stratification_methods) {
  # Create a dataset using the good dataset.
  data <- familiar:::test_create_good_data("survival")

  # Train a simple linear GLM using the good dataset.
  fam_model <- familiar:::test_train(
    data = data,
    cluster_method = "none",
    imputation_method = "simple",
    hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)),
    learner = "cox",
    stratification_method = stratification_method,
    create_novelty_detector = FALSE)

  # Risk stratification.
  predictions_risk <- familiar::predict(
    object = fam_model,
    newdata = data,
    type = "risk_stratification")

  testthat::test_that("Risk groups are formed.", {
    testthat::expect_equal(fam_model@km_info$stratification_method, stratification_method)
    testthat::expect_true(all(is.finite(predictions_risk$risk_group)))
  })
}

# Test for single-feature dataset.
for (stratification_method in stratification_methods) {
  # Create a dataset using the single-feature dataset.
  data <- familiar:::test_create_single_feature_data("survival")

  # Train a simple linear GLM using the good dataset.
  fam_model <- familiar:::test_train(
    data = data,
    cluster_method = "none",
    imputation_method = "simple",
    hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)),
    learner = "cox",
    stratification_method = stratification_method,
    create_novelty_detector = FALSE)

  # Risk stratification.
  predictions_risk <- familiar::predict(
    object = fam_model,
    newdata = data,
    type = "risk_stratification")

  testthat::test_that("Risk groups are formed.", {
    testthat::expect_equal(fam_model@km_info$stratification_method, stratification_method)
    testthat::expect_true(all(is.finite(predictions_risk$risk_group)))
  })
}

# Test for dataset with only one value for a feature.
for (stratification_method in stratification_methods) {
  # Create a dataset with a feature that only has two values.
  data <- familiar:::test_create_single_feature_two_values_data("survival")

  # Train a simple linear GLM using the feature set that only has two values.
  fam_model <- familiar:::test_train(
    data = data,
    cluster_method = "none",
    imputation_method = "simple",
    hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)),
    learner = "cox",
    stratification_method = stratification_method,
    create_novelty_detector = FALSE)

  # Risk stratification.
  predictions_risk <- familiar::predict(
    object = fam_model,
    newdata = data,
    type = "risk_stratification")

  testthat::test_that("Risk groups are formed.", {
    testthat::expect_equal(fam_model@km_info$stratification_method, stratification_method)
    testthat::expect_true(all(is.finite(predictions_risk$risk_group)))
  })
}

# Test that multiple risk stratifications methods can be applied simultaneously.

# Create a dataset using the good dataset.
data <- familiar:::test_create_good_data("survival")

# Train a simple linear GLM using the good dataset.
fam_model <- familiar:::test_train(
  data = data,
  cluster_method = "none",
  imputation_method = "simple",
  hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)),
  learner = "cox",
  stratification_method = stratification_methods,
  create_novelty_detector = FALSE)

for (stratification_method in stratification_methods) {
  # Risk stratification.
  predictions_risk <- familiar::predict(
    object = fam_model,
    newdata = data,
    type = "risk_stratification",
    stratification_method = stratification_method)

  testthat::test_that("Risk groups are formed.", {
    testthat::expect_true(all(is.finite(predictions_risk$risk_group)))
  })
}

# Test that creation fails for models that only yield invalid predictions
for (stratification_method in stratification_methods) {
  # Create a dataset using the good dataset.
  data <- familiar:::test_create_good_data("survival")

  # Train a simple linear GLM using the good dataset.
  fam_model <- familiar:::test_train(
    data = data,
    cluster_method = "none",
    imputation_method = "simple",
    hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)),
    learner = "lasso_test_all_fail",
    stratification_method = stratification_method,
    create_novelty_detector = FALSE)

  # Risk stratification.
  predictions_risk <- familiar::predict(
    object = fam_model,
    newdata = data,
    type = "risk_stratification")

  testthat::test_that("Risk groups are formed.", {
    testthat::expect_equal(fam_model@km_info$stratification_method, NULL)
    testthat::expect_false(any(is.finite(predictions_risk$risk_group)))
  })
}

# Test that creation succeeds for models that yield some invalid predictions.
for (stratification_method in stratification_methods) {
  # Create a dataset using the good dataset.
  data <- familiar:::test_create_good_data("survival")

  # Train a simple linear GLM using the good dataset.
  fam_model <- familiar:::test_train(
    data = data,
    cluster_method = "none",
    imputation_method = "simple",
    hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)),
    learner = "lasso_test_some_fail",
    stratification_method = stratification_method,
    create_novelty_detector = FALSE)

  # Risk stratification.
  predictions_risk <- familiar::predict(
    object = fam_model,
    newdata = data,
    type = "risk_stratification")

  testthat::test_that("Risk groups are formed.", {
    testthat::expect_equal(fam_model@km_info$stratification_method, stratification_method)
    testthat::expect_false(all(is.finite(predictions_risk$risk_group)))
    testthat::expect_true(any(is.finite(predictions_risk$risk_group)))
  })
}