From a97771c3bbcf69a5915084436daaf74b68eb0700 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Fri, 1 May 2026 19:14:03 +0200 Subject: [PATCH 01/21] rename files for clearer organization add a epoch to test remove processing of y in front of pretraining --- .Rbuildignore | 1 + R/hardhat.R | 7 ++----- R/{explain.R => model_explain.R} | 0 R/{pretraining.R => model_pretraining.R} | 0 R/{model.R => model_training.R} | 0 R/{tab-network.R => tabnet_network.R} | 0 man/tabnet_config.Rd | 2 +- man/tabnet_explain.Rd | 2 +- man/tabnet_nn.Rd | 2 +- man/tabnet_pretrain.Rd | 2 +- .../_snaps/{pretraining.md => model_pretraining.md} | 0 tests/testthat/{test-explain.R => test-model_explain.R} | 0 .../{test-pretraining.R => test-model_pretraining.R} | 0 tests/testthat/{test-model.R => test-model_training.R} | 0 tests/testthat/test-parsnip.R | 1 + .../testthat/{test_translations.R => test-translations.R} | 0 16 files changed, 8 insertions(+), 9 deletions(-) rename R/{explain.R => model_explain.R} (100%) rename R/{pretraining.R => model_pretraining.R} (100%) rename R/{model.R => model_training.R} (100%) rename R/{tab-network.R => tabnet_network.R} (100%) rename tests/testthat/_snaps/{pretraining.md => model_pretraining.md} (100%) rename tests/testthat/{test-explain.R => test-model_explain.R} (100%) rename tests/testthat/{test-pretraining.R => test-model_pretraining.R} (100%) rename tests/testthat/{test-model.R => test-model_training.R} (100%) rename tests/testthat/{test_translations.R => test-translations.R} (100%) diff --git a/.Rbuildignore b/.Rbuildignore index 4117da74..94ba712b 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -14,3 +14,4 @@ ^CRAN-SUBMISSION$ ^revdep$ ^vignettes/*_files$ +^\.claude$ diff --git a/R/hardhat.R b/R/hardhat.R index 1d57a1b4..48cb076a 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -272,9 +272,7 @@ tabnet_pretrain.default <- function(x, ...) { #' @export #' @rdname tabnet_pretrain -tabnet_pretrain.data.frame <- function(x, y, tabnet_model = NULL, config = tabnet_config(), ..., from_epoch = NULL) { - processed <- hardhat::mold(x, y) - +tabnet_pretrain.data.frame <- function(x, y = NULL, tabnet_model = NULL, config = tabnet_config(), ..., from_epoch = NULL) { config <- merge_config_and_dots(config, ...) tabnet_bridge(processed, config = config, tabnet_model, from_epoch, task = "unsupervised") } @@ -309,8 +307,7 @@ tabnet_pretrain.Node <- function(x, tabnet_model = NULL, config = tabnet_config( check_compliant_node(x) # get tree leaves and extract attributes into data.frames xy_df <- node_to_df(x) - tabnet_pretrain(xy_df$x, xy_df$y, tabnet_model = tabnet_model, config = config, ..., from_epoch = from_epoch) - + tabnet_pretrain(xy_df$x, tabnet_model = tabnet_model, config = config, ..., from_epoch = from_epoch) } new_tabnet_pretrain <- function(pretrain, blueprint) { diff --git a/R/explain.R b/R/model_explain.R similarity index 100% rename from R/explain.R rename to R/model_explain.R diff --git a/R/pretraining.R b/R/model_pretraining.R similarity index 100% rename from R/pretraining.R rename to R/model_pretraining.R diff --git a/R/model.R b/R/model_training.R similarity index 100% rename from R/model.R rename to R/model_training.R diff --git a/R/tab-network.R b/R/tabnet_network.R similarity index 100% rename from R/tab-network.R rename to R/tabnet_network.R diff --git a/man/tabnet_config.Rd b/man/tabnet_config.Rd index d20ecd87..7295409d 100644 --- a/man/tabnet_config.Rd +++ b/man/tabnet_config.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model.R +% Please edit documentation in R/model_training.R \name{tabnet_config} \alias{tabnet_config} \title{Configuration for TabNet models} diff --git a/man/tabnet_explain.Rd b/man/tabnet_explain.Rd index f750c5f5..1327c039 100644 --- a/man/tabnet_explain.Rd +++ b/man/tabnet_explain.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/explain.R +% Please edit documentation in R/model_explain.R \name{tabnet_explain} \alias{tabnet_explain} \alias{tabnet_explain.default} diff --git a/man/tabnet_nn.Rd b/man/tabnet_nn.Rd index ae5e8f76..3fa483a1 100644 --- a/man/tabnet_nn.Rd +++ b/man/tabnet_nn.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tab-network.R +% Please edit documentation in R/tabnet_network.R \name{tabnet_nn} \alias{tabnet_nn} \title{TabNet Model Architecture} diff --git a/man/tabnet_pretrain.Rd b/man/tabnet_pretrain.Rd index 5c1e42e7..b3777ae5 100644 --- a/man/tabnet_pretrain.Rd +++ b/man/tabnet_pretrain.Rd @@ -15,7 +15,7 @@ tabnet_pretrain(x, ...) \method{tabnet_pretrain}{data.frame}( x, - y, + y = NULL, tabnet_model = NULL, config = tabnet_config(), ..., diff --git a/tests/testthat/_snaps/pretraining.md b/tests/testthat/_snaps/model_pretraining.md similarity index 100% rename from tests/testthat/_snaps/pretraining.md rename to tests/testthat/_snaps/model_pretraining.md diff --git a/tests/testthat/test-explain.R b/tests/testthat/test-model_explain.R similarity index 100% rename from tests/testthat/test-explain.R rename to tests/testthat/test-model_explain.R diff --git a/tests/testthat/test-pretraining.R b/tests/testthat/test-model_pretraining.R similarity index 100% rename from tests/testthat/test-pretraining.R rename to tests/testthat/test-model_pretraining.R diff --git a/tests/testthat/test-model.R b/tests/testthat/test-model_training.R similarity index 100% rename from tests/testthat/test-model.R rename to tests/testthat/test-model_training.R diff --git a/tests/testthat/test-parsnip.R b/tests/testthat/test-parsnip.R index 742281e8..6373e6ed 100644 --- a/tests/testthat/test-parsnip.R +++ b/tests/testthat/test-parsnip.R @@ -98,6 +98,7 @@ test_that("Check we can finalize a workflow from a tune_grid", { model <- tabnet(epochs = tune(), checkpoint_epochs = 1) %>% parsnip::set_mode("regression") %>% + parsnip::set_args(epochs = 2) %>% parsnip::set_engine("torch") wf <- workflows::workflow() %>% diff --git a/tests/testthat/test_translations.R b/tests/testthat/test-translations.R similarity index 100% rename from tests/testthat/test_translations.R rename to tests/testthat/test-translations.R From 2f5b71a77d8028f97fa09bdc9989f69f4cfbea2d Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sat, 2 May 2026 15:30:47 +0200 Subject: [PATCH 02/21] fix #187 --- .Rbuildignore | 1 + .gitignore | 1 + DESCRIPTION | 2 +- R/hardhat.R | 15 ++++++++++----- R/model_training.R | 20 +++++++++++++------- po/R-fr.po | 2 +- tests/testthat/test-hardhat_hierarchical.R | 10 ++++++---- 7 files changed, 33 insertions(+), 18 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 94ba712b..15030367 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -15,3 +15,4 @@ ^revdep$ ^vignettes/*_files$ ^\.claude$ +^\.positai$ diff --git a/.gitignore b/.gitignore index 4b3d4c83..985fdf11 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ tabnet_*.tar.gz tabnet.Rproj po/glossary.csv inst/IMPORTLIST +.positai diff --git a/DESCRIPTION b/DESCRIPTION index 95044dcc..93bc2b5a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -68,5 +68,5 @@ Config/testthat/parallel: false Config/testthat/start-first: interface, explain, params Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.3 Language: en-US +Config/roxygen2/version: 8.0.0 diff --git a/R/hardhat.R b/R/hardhat.R index 48cb076a..af85eaba 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -164,14 +164,17 @@ tabnet_fit.Node <- function(x, tabnet_model = NULL, config = tabnet_config(), .. processed <- hardhat::mold(xy_df$x, xy_df$y) # Given n classes, M is an (n x n) matrix where M_ij = 1 if class i is descendant of class j ancestor <- data.tree::ToDataFrameNetwork(x) %>% - mutate_if(is.character, ~.x %>% as.factor %>% as.numeric) - # TODO check correctness - # embed the M matrix in the config$ancestor variable - dims <- c(max(ancestor), max(ancestor)) - ancestor_m <- Matrix::sparseMatrix(ancestor$from, ancestor$to, dims = dims, x = 1) + mutate_if(is.character, ~.x %>% as.factor %>% as.integer) + + # embed the M matrix in the config$ancestor_tt variable + ancestor_tt <- torch::torch_sparse_coo_tensor( + matrix(c(ancestor$from, ancestor$to), nrow = 2), + rep(TRUE, length(ancestor$from))) + check_type(processed$outcomes) config <- merge_config_and_dots(config, ...) + config$ancestor <- ancestor_tt tabnet_bridge(processed, config = config, tabnet_model, from_epoch, task = "supervised") } @@ -273,6 +276,8 @@ tabnet_pretrain.default <- function(x, ...) { #' @export #' @rdname tabnet_pretrain tabnet_pretrain.data.frame <- function(x, y = NULL, tabnet_model = NULL, config = tabnet_config(), ..., from_epoch = NULL) { + processed <- hardhat::mold(x, y) + config <- merge_config_and_dots(config, ...) tabnet_bridge(processed, config = config, tabnet_model, from_epoch, task = "unsupervised") } diff --git a/R/model_training.R b/R/model_training.R index 30084761..50553ef6 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -175,7 +175,8 @@ tabnet_config <- function(batch_size = 1024^2, early_stopping_tolerance = 0, early_stopping_patience = 0L, num_workers=0L, - skip_importance = FALSE) { + skip_importance = FALSE + ) { if (is.null(decision_width) && is.null(attention_width)) { decision_width <- 8 # default is 8 } @@ -249,7 +250,7 @@ resolve_loss <- function(config, dtype) { loss_fn <- loss else if (loss %in% c("mse", "auto") && !dtype == torch::torch_long()) loss_fn <- torch::nn_mse_loss() - else if ((loss %in% c("bce", "cross_entropy", "auto") && dtype == torch::torch_long()) || !is.null(config$ancestor_tt)) + else if ((loss %in% c("bce", "cross_entropy", "auto") && dtype == torch::torch_long()) || !is.null(config$.ancestor_tt)) # cross entropy loss is required loss_fn <- torch::nn_cross_entropy_loss() else @@ -278,14 +279,14 @@ train_batch <- function(network, optimizer, batch, config) { if (max(batch$output_dim$shape) > 1) { # multi-outcome outcome_nlevels <- as.numeric(batch$output_dim$to(device="cpu")) - if (!is.null(config$ancestor_tt)) { + if (!is.null(config$.ancestor_tt)) { # hierarchical mandates use of `max_constraint_output` loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( list( torch::torch_split(out, outcome_nlevels, dim = 2), torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) ), - ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$ancestor_tt)) + ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$.ancestor_tt)) )), dim = 1) } else { @@ -332,14 +333,14 @@ valid_batch <- function(network, batch, config) { if (max(batch$output_dim$shape) > 1) { # multi-outcome outcome_nlevels <- as.numeric(batch$output_dim$to(device="cpu")) - if (!is.null(config$ancestor_tt)) { + if (!is.null(config$.ancestor_tt)) { # hierarchical mandates use of `max_constraint_output` loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( list( torch::torch_split(out, outcome_nlevels, dim = 2), torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) ), - ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$ancestor_tt)) + ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$.ancestor_tt)) )), dim = 1) } else { @@ -513,7 +514,12 @@ tabnet_train_supervised <- function(obj, x, y, config = tabnet_config(), epoch_s # provide ancestor to torch tensor in case of hierarchical classification if (!is.null(config$ancestor)) { - config$ancestor_tt <- torch::torch_tensor(config$ancestor)$to(torch::torch_bool(), device = device) + if (config$ancestor$is_spase()) { + # config is expected to carry the sparse tensor + config$.ancestor_tt <- config$ancestor + } else { + config$.ancestor_tt <- NULL + } } # instantiate optimizer diff --git a/po/R-fr.po b/po/R-fr.po index 14b4b8a1..efa406ad 100644 --- a/po/R-fr.po +++ b/po/R-fr.po @@ -225,7 +225,7 @@ msgid "" " Please change those names as they will lead to unexpected " "tabnet behavior." msgstr "" -"Les attributs ou noms de colonnes dans l’objet hiérarchique fournit utilise " +"Les `attributs` (noms de colonne) dans l’objet hiérarchique fournit utilisent " "les noms réservés suivants : {.vars {actual_names[actual_names %in% " "reserved_names]}}. Veuillez changer ces noms pour éviter un comportement " "imprévisible de TabNet." diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index a6fa0983..14f54595 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -20,7 +20,7 @@ test_that("C-HMCNN get_constr_output works ", { test_that("C-HMCNN max_constraint_output works ", { output <- torch::torch_rand(c(3, 5)) labels <- torch::torch_diag(rep(1,5))[1:3, ]$to(dtype = torch::torch_bool()) - ancestor <- torch::torch_tril(torch::torch_zeros(c(5, 5))$bernoulli(p = 0.2) )$to(dtype = torch::torch_bool()) + ancestor <- torch::torch_triu(torch::torch_zeros(c(5, 5))$bernoulli(p = 0.2) )$to(dtype = torch::torch_bool()) expect_no_error( MC_output <- max_constraint_output(output, labels, ancestor) @@ -34,7 +34,7 @@ test_that("C-HMCNN max_constraint_output works ", { ) # max_constraint_output provides more than 35% null values expect_gte( - as.matrix(torch::torch_sum(MC_output == 0), device="cpu"), .30 * output$shape[1] * output$shape[2] + as.matrix(torch::torch_sum(MC_output == 0), device="cpu"), .30 * prod(output$shape) ) }) @@ -69,12 +69,13 @@ test_that("Training hierarchical classification for {data.tree} Node", { expect_no_error( fit <- tabnet_fit(acme, epochs = 1) ) + expect_named(fit$fit$config, "ancestor") expect_no_error( result <- predict(fit, acme_df, type = "prob") ) expect_equal(ncol(result), 3) - outcome_levels <-levels(fit$blueprint$ptypes$outcomes[[1]]) + outcome_levels <- levels(fit$blueprint$ptypes$outcomes[[1]]) # we get back outcomes vars with a `.pred_` prefix expect_equal(stringr::str_remove(names(result), ".pred_"), outcome_levels) expect_no_error( @@ -106,7 +107,8 @@ test_that("Training hierarchical classification for {data.tree} Node with valida expect_no_error( fit <- tabnet_fit(attrition_tree, valid_split = 0.2, epochs = 1) ) - + expect_named(fit$fit$config, "ancestor") + expect_no_error( result <- predict(fit, attrition_tree, type = "prob") ) From 81b1d5a7695ef3340a9c02b61df8098cdeaad62d Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sat, 2 May 2026 16:09:26 +0200 Subject: [PATCH 03/21] lint with jarl --- R/hardhat.R | 2 +- R/model_training.R | 2 +- R/parsnip.R | 2 +- R/plot.R | 2 +- tests/testthat/setup.R | 2 +- tests/testthat/test-hardhat_hierarchical.R | 9 ++++++--- tests/testthat/test-hardhat_multi-outcome.R | 8 ++++---- tests/testthat/test-model_explain.R | 4 ++-- tests/testthat/test-parsnip.R | 10 +++++----- vignettes/Hierarchical_classification.Rmd | 22 ++++++++++++++++----- 10 files changed, 39 insertions(+), 24 deletions(-) diff --git a/R/hardhat.R b/R/hardhat.R index af85eaba..77cafd7c 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -439,7 +439,7 @@ predict_tabnet_bridge <- function(type, object, predictors, epoch, batch_size) { is_multi_outcome <- ncol(object$blueprint$ptypes$outcomes) > 1 outcome_nlevels <- NULL if (is_multi_outcome & type != "numeric") { - outcome_nlevels <- purrr::map_dbl(object$blueprint$ptypes$outcomes, ~length(levels(.x))) + outcome_nlevels <- purrr::map_dbl(object$blueprint$ptypes$outcomes, ~nlevels(.x)) } if (!is.null(epoch)) { diff --git a/R/model_training.R b/R/model_training.R index 50553ef6..11bdd0d0 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -696,7 +696,7 @@ predict_impl_numeric <- function(obj, x, batch_size) { predict_impl_numeric_multiple <- function(obj, x, batch_size) { p <- as.matrix(predict_impl(obj, x, batch_size)) # TODO use a cleaner function to turn matrix into vectors - hardhat::spruce_numeric_multiple(!!!purrr::map(1:ncol(p), ~p[,.x])) + hardhat::spruce_numeric_multiple(!!!purrr::map(seq_len(ncol(p)), ~p[,.x])) } #' single-outcome level blueprint diff --git a/R/parsnip.R b/R/parsnip.R index 00627a59..33d16fd6 100644 --- a/R/parsnip.R +++ b/R/parsnip.R @@ -539,7 +539,7 @@ multi_predict._tabnet_fit <- function(object, new_data, type = NULL, epochs = NU pred <- predict(object$fit, new_data, type = type, epoch = epoch) nms <- names(pred) pred[["epochs"]] <- epoch - pred[[".row"]] <- 1:nrow(new_data) + pred[[".row"]] <- seq_len(nrow(new_data)) pred[, c(".row", "epochs", nms)] }) diff --git a/R/plot.R b/R/plot.R index f84ea638..4d3985d5 100644 --- a/R/plot.R +++ b/R/plot.R @@ -41,7 +41,7 @@ autoplot.tabnet_fit <- function(object, ...) { if ("checkpoint" %in% names(collect_metrics)) { checkpoints <- collect_metrics %>% - dplyr::filter(checkpoint == TRUE, dataset == "train") %>% + dplyr::filter(checkpoint, dataset == "train") %>% dplyr::select(-checkpoint) %>% dplyr::mutate(size = 2) p + diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 4b78d736..589ba492 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -13,7 +13,7 @@ y <- ames[ids,]$Sale_Price # ames common models ames_pretrain <- tabnet_pretrain(x, y, epoch = 2, checkpoint_epochs = 1) -ames_pretrain_vsplit <- tabnet_pretrain(x, y, epochs = 3, valid_split=.2, +ames_pretrain_vsplit <- tabnet_pretrain(x, y, epochs = 3, valid_split=0.2, num_steps = 1, attention_width = 1, num_shared = 1, num_independent = 1) ames_fit <- tabnet_fit(x, y, epochs = 5 , checkpoint_epochs = 2) ames_fit_vsplit <- tabnet_fit(x, y, tabnet_model=ames_pretrain_vsplit, epochs = 3, diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index 14f54595..c8acdf06 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -34,7 +34,7 @@ test_that("C-HMCNN max_constraint_output works ", { ) # max_constraint_output provides more than 35% null values expect_gte( - as.matrix(torch::torch_sum(MC_output == 0), device="cpu"), .30 * prod(output$shape) + as.matrix(torch::torch_sum(MC_output == 0), device="cpu"), 0.30 * prod(output$shape) ) }) @@ -70,6 +70,8 @@ test_that("Training hierarchical classification for {data.tree} Node", { fit <- tabnet_fit(acme, epochs = 1) ) expect_named(fit$fit$config, "ancestor") + expect_true(fit$fit$config$ancestor$is_sparse()) + expect_no_error( result <- predict(fit, acme_df, type = "prob") ) @@ -92,7 +94,7 @@ test_that("Training hierarchical classification for {data.tree} Node", { expect_equal(ncol(result), 2) # 2 outcomes levels_ - outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~length(levels(.x))) + outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~nlevels(.x)) # we get back outcomes vars with a `.pred_` prefix expect_equal(stringr::str_remove(names(result), ".pred_"), names(outcome_nlevels)) @@ -108,6 +110,7 @@ test_that("Training hierarchical classification for {data.tree} Node with valida fit <- tabnet_fit(attrition_tree, valid_split = 0.2, epochs = 1) ) expect_named(fit$fit$config, "ancestor") + expect_true(fit$fit$config$ancestor$is_sparse()) expect_no_error( result <- predict(fit, attrition_tree, type = "prob") @@ -115,7 +118,7 @@ test_that("Training hierarchical classification for {data.tree} Node with valida expect_equal(ncol(result), 2) # 2 outcomes levels_ - outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~length(levels(.x))) + outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~nlevels(.x)) # we get back outcomes vars with a `.pred_` prefix expect_equal(stringr::str_remove(names(result), ".pred_"), names(outcome_nlevels)) diff --git a/tests/testthat/test-hardhat_multi-outcome.R b/tests/testthat/test-hardhat_multi-outcome.R index fa3eafd2..d1a79d43 100644 --- a/tests/testthat/test-hardhat_multi-outcome.R +++ b/tests/testthat/test-hardhat_multi-outcome.R @@ -54,7 +54,7 @@ test_that("Training multilabel classification from data.frame", { ) expect_equal(ncol(result), 3) - outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~length(levels(.x))) + outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~nlevels(.x)) # we get back outcomes vars with a `.pred_` prefix expect_equal(stringr::str_remove(names(result), ".pred_"), names(outcome_nlevels)) @@ -82,7 +82,7 @@ test_that("Training multilabel classification from formula", { ) expect_equal(ncol(result), 2) - outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~length(levels(.x))) + outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~nlevels(.x)) # we get back outcomes vars with a `.pred_` prefix expect_equal(stringr::str_remove(names(result), ".pred_"), names(outcome_nlevels)) @@ -108,7 +108,7 @@ test_that("Training multilabel classification from recipe", { ) expect_equal(ncol(result), 2) - outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~length(levels(.x))) + outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~nlevels(.x)) expect_equal(stringr::str_remove(names(result), ".pred_class_"), names(outcome_nlevels)) }) @@ -126,7 +126,7 @@ test_that("Training multilabel classification from data.frame with validation sp expect_equal(ncol(result), 3) - outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~length(levels(.x))) + outcome_nlevels <- purrr::map_dbl(fit$blueprint$ptypes$outcomes, ~nlevels(.x)) # we get back outcomes vars with a `.pred_` prefix expect_equal(stringr::str_remove(names(result), ".pred_"), names(outcome_nlevels)) diff --git a/tests/testthat/test-model_explain.R b/tests/testthat/test-model_explain.R index 549afed4..db0ace3b 100644 --- a/tests/testthat/test-model_explain.R +++ b/tests/testthat/test-model_explain.R @@ -52,7 +52,7 @@ test_that("explain works for dataframe, formula and recipe", { # formula - tabnet_pretrain <- tabnet_pretrain(Sale_Price ~., data=small_ames, epochs = 3, valid_split=.2, + tabnet_pretrain <- tabnet_pretrain(Sale_Price ~., data=small_ames, epochs = 3, valid_split=0.2, num_steps = 1, attention_width = 1, num_shared = 1, num_independent = 1) expect_no_error( tabnet_explain(tabnet_pretrain, new_data=small_ames) @@ -69,7 +69,7 @@ test_that("explain works for dataframe, formula and recipe", { step_zv(all_predictors()) %>% step_normalize(all_numeric_predictors()) - tabnet_pretrain <- tabnet_pretrain(rec, data=small_ames, epochs = 3, valid_split=.2, + tabnet_pretrain <- tabnet_pretrain(rec, data=small_ames, epochs = 3, valid_split=0.2, num_steps = 1, attention_width = 1, num_shared = 1, num_independent = 1) expect_no_error( tabnet_explain(tabnet_pretrain, new_data=small_ames) diff --git a/tests/testthat/test-parsnip.R b/tests/testthat/test-parsnip.R index 6373e6ed..f322bcbe 100644 --- a/tests/testthat/test-parsnip.R +++ b/tests/testthat/test-parsnip.R @@ -135,7 +135,7 @@ test_that("tabnet grid reduction - torch", { expect_equal(reg_grid_smol$epochs, rep(3, 2)) expect_equal(reg_grid_smol$penalty, 1:2) - for (i in 1:nrow(reg_grid_smol)) { + for (i in seq_len(nrow(reg_grid_smol))) { expect_equal(reg_grid_smol$.submodels[[i]], list(epochs = 1:2)) } @@ -156,7 +156,7 @@ test_that("tabnet grid reduction - torch", { expect_equal(reg_grid_extra_smol$epochs, rep(3, 6)) expect_equal(reg_grid_extra_smol$penalty, rep(1:2, each = 3)) expect_equal(reg_grid_extra_smol$batch_size, rep(10:12, 2)) - for (i in 1:nrow(reg_grid_extra_smol)) { + for (i in seq_len(nrow(reg_grid_extra_smol))) { expect_equal(reg_grid_extra_smol$.submodels[[i]], list(epochs = 1:2)) } @@ -173,7 +173,7 @@ test_that("tabnet grid reduction - torch", { expect_equal(no_sub_smol$epochs, rep(1, 2)) expect_equal(no_sub_smol$penalty, 1:2) - for (i in 1:nrow(no_sub_smol)) { + for (i in seq_len(nrow(no_sub_smol))) { expect_length(no_sub_smol$.submodels[[i]], 0) } @@ -185,7 +185,7 @@ test_that("tabnet grid reduction - torch", { expect_equal(reg_grid_smol$Amos, rep(3, 2)) expect_equal(reg_grid_smol$penalty, 1:2) - for (i in 1:nrow(reg_grid_smol)) { + for (i in seq_len(nrow(reg_grid_smol))) { expect_equal(reg_grid_smol$.submodels[[i]], list(Amos = 1:2)) } @@ -203,7 +203,7 @@ test_that("tabnet grid reduction - torch", { expect_equal(reg_grid_smol$`Ade Tukunbo`, rep(3, 4)) expect_equal(reg_grid_smol$penalty, rep(1:2, each = 2)) expect_equal(reg_grid_smol$` \t123`, rep(10:11, 2)) - for (i in 1:nrow(reg_grid_smol)) { + for (i in seq_len(nrow(reg_grid_smol))) { expect_equal(reg_grid_smol$.submodels[[i]], list(`Ade Tukunbo` = 1:2)) } }) diff --git a/vignettes/Hierarchical_classification.Rmd b/vignettes/Hierarchical_classification.Rmd index ab7bee93..e4f804d9 100644 --- a/vignettes/Hierarchical_classification.Rmd +++ b/vignettes/Hierarchical_classification.Rmd @@ -25,20 +25,32 @@ library(tibble) set.seed(202307) ``` -## Data preparation +## Data format The supported data format for hierarchical classification is the `Node` object format from package `{data.tree}`. This is a general purpose format that fits generic hierarchical tree encoding needs. Each node of the tree is associated with predictor values through the `attributes` in the data `Node` object. - - A very basic example is the `acme` dataset to show you how the two predictors values `cost` and `p` are associates attributes of each node in the hierarchy : +|{tabnet} concept| {data.tree} concept |see command| +|---|---|---| +|dataset predictor| Node `attributesAll` | acme example | +|dataset multi-label target| Node hierarchy | print(acme) | + + +A very basic example is the `acme` dataset to show you how the two predictors values `cost` and `p` are associates attributes of each node in the hierarchy : ```{r} data(acme, package = "data.tree") acme$attributesAll print(acme, "cost", "p" , limit = 8) ``` +So printing Node objects reverse the usual ordering, as target is printed first in column `levelName`, and predictors printed right of it. + +As you can see, only leaf nodes of the tree gets predictors value. {tabnet} will take this into account via an `ancestor` square sparse tensor registering all possible parent-child relation among the target labels. + + +## Data preparation -- Multiple manual or programmatic methods are available to create or update predictors. They are detailled in the `vignette("data.tree", package = "data.tree")`. +Multiple manual or programmatic methods are available to create or update predictors. They are detailled in the `vignette("data.tree", package = "data.tree")`. - a lot of native hierarchical data-format conversion from files to `Node` are covered by the`{data.tree}` package. You can find them in the "Create tree from a file" section of the same vignette. If needed, the `{ape}` package covers a lot of conversion format to the `philo` format. Thus you can reach the `Node` format in maybe two transformation steps... @@ -74,13 +86,13 @@ As `as.Node()` will only consider the as.numeric() values of a factor(), you sho Your dataset hierarchy will be turn internally into multi-outcomes named `level_1` to `level_n`, n beeing the depth of your tree. Thus column names starting with `level_` should be avoided. -### Ensure the last hierarchy of the tree is the observation id +### Ensure the last hierarchy of the tree is the **observation id** The tree only keeps a single row of attributes per tree leaf. Thus in order to transfer your complete predictors dataset into the Node object, you must keep the last level of the hierarchy to be a unique observation identifier (last resort beeing `rowid_to_column()` to achieve it). The classification will be done **removing the last level of hierarchy** in any case. -### Ensure there is a root level in the hierarchy +### Ensure there is a **root level** in the hierarchy The tree should have a single root for all nodes to be consistent. Thus you have to use a constant prefix to all `pathString`. From 57295f7ee78e8d88eb2877df9f90961f58c5bdd0 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sat, 2 May 2026 16:13:00 +0200 Subject: [PATCH 04/21] lint && fix --- R/hardhat.R | 2 +- R/model_pretraining.R | 4 ++-- R/model_training.R | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/hardhat.R b/R/hardhat.R index 77cafd7c..fc056347 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -438,7 +438,7 @@ predict_tabnet_bridge <- function(type, object, predictors, epoch, batch_size) { type <- check_type(object$blueprint$ptypes$outcomes, type) is_multi_outcome <- ncol(object$blueprint$ptypes$outcomes) > 1 outcome_nlevels <- NULL - if (is_multi_outcome & type != "numeric") { + if (is_multi_outcome && type != "numeric") { outcome_nlevels <- purrr::map_dbl(object$blueprint$ptypes$outcomes, ~nlevels(.x)) } diff --git a/R/model_pretraining.R b/R/model_pretraining.R index 2ec315d6..0f48482e 100644 --- a/R/model_pretraining.R +++ b/R/model_pretraining.R @@ -178,9 +178,9 @@ tabnet_train_unsupervised <- function(x, config = tabnet_config(), epoch_shift = metrics[[epoch]][["valid"]] <- transpose_metrics(valid_metrics)$loss } - if (config$verbose & !has_valid) + if (config$verbose && !has_valid) message(gettextf("[Epoch %03d] Loss: %3f", epoch, mean(metrics[[epoch]]$train))) - if (config$verbose & has_valid) + if (config$verbose && has_valid) message(gettextf("[Epoch %03d] Loss: %3f, Valid loss: %3f", epoch, mean(metrics[[epoch]]$train), mean(metrics[[epoch]]$valid))) # Early-stopping checks diff --git a/R/model_training.R b/R/model_training.R index 11bdd0d0..23547b9d 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -585,9 +585,9 @@ tabnet_train_supervised <- function(obj, x, y, config = tabnet_config(), epoch_s metrics[[epoch]][["valid"]] <- transpose_metrics(valid_metrics)$loss } - if (config$verbose & !has_valid) + if (config$verbose && !has_valid) message(gettextf("[Epoch %03d] Loss: %3f", epoch, mean(metrics[[epoch]]$train))) - if (config$verbose & has_valid) + if (config$verbose && has_valid) message(gettextf("[Epoch %03d] Loss: %3f, Valid loss: %3f", epoch, mean(metrics[[epoch]]$train), mean(metrics[[epoch]]$valid))) From b1600245ce5d3e7923ae47f59f5332490c3e0c6f Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sat, 2 May 2026 20:11:02 +0200 Subject: [PATCH 05/21] do not duplicate ancestor transport --- R/hardhat.R | 8 ++++---- R/model_training.R | 16 +++++++--------- tests/testthat/test-hardhat_hierarchical.R | 10 +++++----- 3 files changed, 16 insertions(+), 18 deletions(-) diff --git a/R/hardhat.R b/R/hardhat.R index fc056347..51a37888 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -166,15 +166,15 @@ tabnet_fit.Node <- function(x, tabnet_model = NULL, config = tabnet_config(), .. ancestor <- data.tree::ToDataFrameNetwork(x) %>% mutate_if(is.character, ~.x %>% as.factor %>% as.integer) - # embed the M matrix in the config$ancestor_tt variable - ancestor_tt <- torch::torch_sparse_coo_tensor( + # embed the M matrix in the config$ancestor variable + ancestor <- torch::torch_sparse_coo_tensor( matrix(c(ancestor$from, ancestor$to), nrow = 2), rep(TRUE, length(ancestor$from))) check_type(processed$outcomes) config <- merge_config_and_dots(config, ...) - config$ancestor <- ancestor_tt + config$ancestor <- ancestor tabnet_bridge(processed, config = config, tabnet_model, from_epoch, task = "supervised") } @@ -606,4 +606,4 @@ nn_prune_head.tabnet_pretrain <- function(x, head_size) { nn_prune_head(x$fit$network, head_size=head_size) } -} \ No newline at end of file +} diff --git a/R/model_training.R b/R/model_training.R index 23547b9d..977ac550 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -250,7 +250,7 @@ resolve_loss <- function(config, dtype) { loss_fn <- loss else if (loss %in% c("mse", "auto") && !dtype == torch::torch_long()) loss_fn <- torch::nn_mse_loss() - else if ((loss %in% c("bce", "cross_entropy", "auto") && dtype == torch::torch_long()) || !is.null(config$.ancestor_tt)) + else if ((loss %in% c("bce", "cross_entropy", "auto") && dtype == torch::torch_long()) || !is.null(config$ancestor)) # cross entropy loss is required loss_fn <- torch::nn_cross_entropy_loss() else @@ -279,14 +279,14 @@ train_batch <- function(network, optimizer, batch, config) { if (max(batch$output_dim$shape) > 1) { # multi-outcome outcome_nlevels <- as.numeric(batch$output_dim$to(device="cpu")) - if (!is.null(config$.ancestor_tt)) { + if (!is.null(config$ancestor)) { # hierarchical mandates use of `max_constraint_output` loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( list( torch::torch_split(out, outcome_nlevels, dim = 2), torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) ), - ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$.ancestor_tt)) + ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$ancestor)) )), dim = 1) } else { @@ -333,14 +333,14 @@ valid_batch <- function(network, batch, config) { if (max(batch$output_dim$shape) > 1) { # multi-outcome outcome_nlevels <- as.numeric(batch$output_dim$to(device="cpu")) - if (!is.null(config$.ancestor_tt)) { + if (!is.null(config$ancestor)) { # hierarchical mandates use of `max_constraint_output` loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( list( torch::torch_split(out, outcome_nlevels, dim = 2), torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) ), - ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$.ancestor_tt)) + ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$ancestor)) )), dim = 1) } else { @@ -514,11 +514,9 @@ tabnet_train_supervised <- function(obj, x, y, config = tabnet_config(), epoch_s # provide ancestor to torch tensor in case of hierarchical classification if (!is.null(config$ancestor)) { - if (config$ancestor$is_spase()) { + if (!config$ancestor$is_sparse()) { # config is expected to carry the sparse tensor - config$.ancestor_tt <- config$ancestor - } else { - config$.ancestor_tt <- NULL + runtime_error("ancestor was configured. Expecting a sparse tensor but got {.class {class(config$ancestor)}}") } } diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index c8acdf06..9d5e4ef3 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -18,9 +18,9 @@ test_that("C-HMCNN get_constr_output works ", { }) test_that("C-HMCNN max_constraint_output works ", { - output <- torch::torch_rand(c(3, 5)) - labels <- torch::torch_diag(rep(1,5))[1:3, ]$to(dtype = torch::torch_bool()) - ancestor <- torch::torch_triu(torch::torch_zeros(c(5, 5))$bernoulli(p = 0.2) )$to(dtype = torch::torch_bool()) + output <- torch::torch_rand(c(5, 7)) + labels <- torch::torch_diag(rep(1,7))[1:5, ]$to(dtype = torch::torch_bool()) + ancestor <- torch::torch_triu(torch::torch_zeros(c(7, 7))$bernoulli(p = 0.1) )$to(dtype = torch::torch_bool()) expect_no_error( MC_output <- max_constraint_output(output, labels, ancestor) @@ -32,9 +32,9 @@ test_that("C-HMCNN max_constraint_output works ", { expect_not_equal_to_tensor( MC_output, output ) - # max_constraint_output provides more than 35% null values + # max_constraint_output provides more than 50% null values expect_gte( - as.matrix(torch::torch_sum(MC_output == 0), device="cpu"), 0.30 * prod(output$shape) + as.numeric((MC_output == 0)$sum()), 0.50 * prod(output$shape) ) }) From 9acdeda52eab189bda836c177348643c9a79341c Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sun, 3 May 2026 14:52:13 +0200 Subject: [PATCH 06/21] augment and fix get_constr_output add a proper `build_ancestor_matrix` [ FAIL 12 | WARN 0 | SKIP 0 | PASS 126 ] --- NAMESPACE | 3 + R/hardhat.R | 120 +++++++- R/model_training.R | 10 +- tests/testthat/helper-tensor.R | 9 +- tests/testthat/setup.R | 2 + tests/testthat/test-hardhat_hierarchical.R | 341 +++++++++++++++++++-- 6 files changed, 439 insertions(+), 46 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 8f99e229..7cc1064a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -72,5 +72,8 @@ importFrom(stats,predict) importFrom(stats,update) importFrom(tidyr,replace_na) importFrom(torch,nn_prune_head) +importFrom(torch,torch_int64) +importFrom(torch,torch_ones) +importFrom(torch,torch_sparse_coo_tensor) importFrom(tune,min_grid) importFrom(zeallot,"%<-%") diff --git a/R/hardhat.R b/R/hardhat.R index 51a37888..d1111ef1 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -162,19 +162,17 @@ tabnet_fit.Node <- function(x, tabnet_model = NULL, config = tabnet_config(), .. # get tree leaves and extract attributes into data.frames xy_df <- node_to_df(x) processed <- hardhat::mold(xy_df$x, xy_df$y) + check_type(processed$outcomes) + # Given n classes, M is an (n x n) matrix where M_ij = 1 if class i is descendant of class j - ancestor <- data.tree::ToDataFrameNetwork(x) %>% + edges <- data.tree::ToDataFrameNetwork(x) %>% mutate_if(is.character, ~.x %>% as.factor %>% as.integer) # embed the M matrix in the config$ancestor variable - ancestor <- torch::torch_sparse_coo_tensor( - matrix(c(ancestor$from, ancestor$to), nrow = 2), - rep(TRUE, length(ancestor$from))) + ancestor_tt <- build_ancestor_matrix(edges) - check_type(processed$outcomes) - config <- merge_config_and_dots(config, ...) - config$ancestor <- ancestor + config$ancestor <- ancestor_tt tabnet_bridge(processed, config = config, tabnet_model, from_epoch, task = "supervised") } @@ -607,3 +605,111 @@ nn_prune_head.tabnet_pretrain <- function(x, head_size) { } } + +#' Build a sparse ancestor-descendant matrix from a hierarchy edge list +#' +#' Given a directed graph where edges point from descendant to ancestor, +#' computes the full transitive closure via BFS, then transposes so that +#' the resulting sparse matrix R satisfies R\[i, j\] = 1 whenever class j +#' is a descendant of class i (including i itself). This is the +#' orientation expected by \code{get_constr_output} and the +#' max-constraint-margin (MCM) loss. +#' +#' @param edges A \code{data.frame} with exactly two integer columns +#' named \code{"from"} and \code{"to"}. Each row represents a +#' directed edge from a descendant node to one of its ancestors. +#' Node IDs must be positive integers. Self-loops (e.g. \code{1 -> 1}) +#' are allowed but not required; the diagonal is always set to 1 +#' for every node in \code{1:n_classes}. +#' @param n_classes `integer(1)` or `code{NULL}`. Total number of +#' classes. When \code{NULL} (the default), it is computed as +#' \code{max(edges$from, edges$to)} so that every node appearing in +#' the edge list is represented. Supply an explicit value when there +#' are classes with no edges at all that must still appear in the +#' matrix. +#' +#' @return A \code{torch_sparse_coo_tensor} of shape +#' \code{(n_classes, n_classes)} and dtype \code{torch_double()}. +#' Entry \code{R[i, j] = 1} means class \code{j} is a descendant of +#' class \code{i}. Indices follow torch's 0-based convention. +#' +#' @details +#' The algorithm proceeds in three stages: +#' \enumerate{ +#' \item Build an adjacency list from the edge \code{data.frame} using +#' \code{split()}, grouping by the \code{from} column. Each entry +#' \code{adj[[i]]} contains the direct ancestors reachable from node +#' \code{i} in one hop. +#' \item Run a breadth-first search from every node \code{i = 1, ..., +#' n_classes}, following outgoing edges to discover the full set of +#' ancestors (the transitive closure). A logical \code{visited} +#' vector provides O(1) membership tests and prevents infinite loops +#' when cycles are present. +#' \item Transpose the collected COO index pairs so that the final +#' matrix is oriented for MCM: \code{R[i, j] = 1} means "j is a +#' descendant of i". +#' } +#' Because the diagonal is always filled, every class is its own +#' descendant, ensuring that the MCM constraint is at least as +#' permissive as the unconstrained prediction. +#' +#' @examples +#' \dontrun{ +#' edges <- data.frame( +#' from = c(1L, 1L, 2L, 2L, 3L), +#' to = c(2L, 3L, 4L, 5L, 5L) +#' ) +#' R <- build_ancestor_matrix(edges, n_classes = 5L) +#' } +#' +#' @importFrom torch torch_ones torch_int64 torch_sparse_coo_tensor +#' @noRd +build_ancestor_matrix <- function(edges, n_classes = NULL) { + + if (is.null(n_classes)) { + n_classes <- max(c(edges$from, edges$to)) + } + + # Build adjacency list efficiently: adj[[i]] = direct ancestors of i + adj <- vector("list", n_classes) + by_from <- split(edges$to, edges$from) + for (nm in names(by_from)) { + adj[[as.integer(nm)]] <- as.integer(by_from[[nm]]) + } + + # BFS from each node to find all reachable nodes via outgoing edges + # (i.e., all ancestors). Collect COO indices. + idx_list <- lapply(seq_len(n_classes), function(i) { + visited <- rep(FALSE, n_classes) + visited[i] <- TRUE + frontier <- adj[[i]] + + while (length(frontier) > 0L) { + next_frontier <- integer(0) + for (node in frontier) { + if (!visited[node]) { + visited[node] <- TRUE + next_frontier <- c(next_frontier, adj[[node]]) + } + } + frontier <- next_frontier + } + + reached <- which(visited) + cbind(rep(i, length(reached)), reached) + }) + + # Combine all pairs: before transpose, (i, j) means j is ancestor of i + idx_mat <- do.call(rbind, idx_list) + + # Transpose: swap columns so that (i, j) means j is descendant of i + idx_mat <- cbind(idx_mat[, 2L], idx_mat[, 1L]) + + # idx <- torch::torch_tensor( + # matrix(idx_mat - 1L, nrow = 2L), + # dtype = torch::torch_int64() + # ) + # vals <- torch::torch_ones(nrow(idx_mat), dtype = torch::torch_double()) + + torch::torch_sparse_coo_tensor(t(idx_mat), rep(TRUE, nrow(idx_mat)), c(n_classes, n_classes)) +} diff --git a/R/model_training.R b/R/model_training.R index 977ac550..739a0beb 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -229,8 +229,8 @@ tabnet_config <- function(batch_size = 1024^2, get_constr_output <- function(x, R) { # MCM of the prediction given the hierarchy constraint expressed in the matrix R """ - c_out <- x$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) - R_batch <- R$expand(c(x$shape[1], R$shape[2], R$shape[2])) + c_out <- x$to(dtype = torch::torch_double())$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) + R_batch <- R$unsqueeze(1)$expand(c(x$shape[1], R$shape[2], R$shape[2])) final_out <- torch::torch_max(R_batch * c_out, dim = 3) final_out[[1]] } @@ -238,7 +238,7 @@ get_constr_output <- function(x, R) { max_constraint_output <- function(output, labels, ancestor) { constr_output <- get_constr_output(output, ancestor) train_output <- get_constr_output(labels * output, ancestor) - labels$bitwise_not() * constr_output + labels * train_output + torch::torch_logical_not(labels) * constr_output + labels * train_output } resolve_loss <- function(config, dtype) { @@ -271,7 +271,7 @@ resolve_early_stop_monitor <- function(early_stopping_monitor, valid_split) { } train_batch <- function(network, optimizer, batch, config) { - # NULLing values to avoid a R-CMD Check Note "No visible binding for global variable" + # NULL-ing values to avoid a R-CMD Check Note "No visible binding for global variable" out <- M_loss <- NULL # forward pass c(out, M_loss) %<-% network(batch$x, batch$x_na_mask) @@ -516,7 +516,7 @@ tabnet_train_supervised <- function(obj, x, y, config = tabnet_config(), epoch_s if (!is.null(config$ancestor)) { if (!config$ancestor$is_sparse()) { # config is expected to carry the sparse tensor - runtime_error("ancestor was configured. Expecting a sparse tensor but got {.class {class(config$ancestor)}}") + runtime_error("ancestor was configured. Expecting a sparse tensor but got {.cls {class(config$ancestor)}}") } } diff --git a/tests/testthat/helper-tensor.R b/tests/testthat/helper-tensor.R index 31b5c9bd..534bff14 100644 --- a/tests/testthat/helper-tensor.R +++ b/tests/testthat/helper-tensor.R @@ -38,7 +38,7 @@ expect_no_error <- function(object, ...) { expect_tensor <- function(object) { expect_true(torch:::is_torch_tensor(object)) - expect_no_error(torch::as_array(object$to(device = "cpu"))) + expect_no_error(torch::as_array(object$to_dense()$to(device = "cpu"))) } expect_equal_to_r <- function(object, expected, ...) { @@ -50,6 +50,13 @@ expect_tensor_shape <- function(object, expected) { expect_equal(object$shape, expected) } + +expect_tensor_dtype <- function(object, expected_dtype) { + expect_tensor(object) + expect_true(object$dtype == expected_dtype) +} + + expect_undefined_tensor <- function(object) { # TODO } diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 589ba492..74c72ae9 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -38,6 +38,8 @@ attr_fitted_vsplit <- tabnet_fit(attrix, attriy, epochs = 12, valid_split=0.3) utils::data("acme", package = "data.tree") acme_df <- data.tree::ToDataFrameTypeCol(acme, acme$attributesAll) %>% select(-starts_with("level_")) +# acme2 <- acme$clone() +# acme2$RemoveAttribute("level_3") attrition_tree <- attrition %>% tibble::rowid_to_column() %>% diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index 9d5e4ef3..8ce70b4a 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -1,41 +1,316 @@ -test_that("C-HMCNN get_constr_output works ", { - x <- torch::torch_rand(c(2,4)) - R <- torch::torch_tril(torch::torch_zeros(c(4,4))$bernoulli(p = 0.2) + torch::torch_diag(rep(1,4)))$to(dtype = torch::torch_bool()) - expect_no_error( - constr_output <- get_constr_output(x, R) - ) - expect_tensor_shape( - constr_output, x$shape - ) - # expect_equal( - # constr_output$dtype, torch_tensor(0.1)$dtype - # ) +test_that("get_constr_output handles basic 2D input with identity constraint", { + x <- torch_tensor(matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2), dtype = torch_float32()) + R <- torch_eye(2, dtype = torch_float32()) + result <- get_constr_output(x, R) + expect_tensor(result) + expect_tensor_shape(result, c(2, 2)) + expect_equal_to_r(result, matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2)) +}) - R <- torch::torch_zeros(c(4,4))$to(dtype = torch::torch_bool()) - expect_equal_to_tensor( - get_constr_output(x, R), torch::torch_zeros_like(x) - ) +test_that("get_constr_output applies hierarchy constraint correctly", { + x <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) + R <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(2, 2)) + expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected, tolerance = 1e-6) }) -test_that("C-HMCNN max_constraint_output works ", { - output <- torch::torch_rand(c(5, 7)) - labels <- torch::torch_diag(rep(1,7))[1:5, ]$to(dtype = torch::torch_bool()) - ancestor <- torch::torch_triu(torch::torch_zeros(c(7, 7))$bernoulli(p = 0.1) )$to(dtype = torch::torch_bool()) +test_that("get_constr_output preserves input dtype", { + x_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float32()) + x_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float64()) + R <- torch_eye(2) + expect_tensor_dtype(get_constr_output(x_f32, R), torch_float64()) + expect_tensor_dtype(get_constr_output(x_f64, R), torch_float64()) +}) - expect_no_error( - MC_output <- max_constraint_output(output, labels, ancestor) - ) - expect_tensor_shape( - MC_output, output$shape - ) - # max_constraint_output is not identity - expect_not_equal_to_tensor( - MC_output, output +test_that("get_constr_output handles batch dimension correctly", { + x <- torch_tensor(matrix(1:12, nrow = 3, ncol = 4)) + R <- torch_tensor(matrix(c(1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(3, 4)) + + for (i in 1:3) { + row_result <- as_array(result[i, ]) + max_grp1 <- max(as_array(x[i, 1:2])) + max_grp2 <- max(as_array(x[i, 3:4])) + + expect_equal(row_result[1:2], rep(max_grp1, 2), tolerance = 1e-6) + expect_equal(row_result[3:4], rep(max_grp2, 2), tolerance = 1e-6) + } +}) +test_that("get_constr_output works with single sample", { + x <- torch_tensor(matrix(c(2, 1, 4, 3), nrow = 1, ncol = 4, byrow = TRUE)) + R <- torch_tensor(matrix(c(1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(1, 4)) + expected <- matrix(c(2, 2, 4, 4), nrow = 1, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("get_constr_output handles all-zeros constraint matrix", { + x <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) + R <- torch_zeros(c(3, 3)) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(2, 3)) + expect_equal_to_r(result, matrix(0, nrow = 2, ncol = 3)) +}) + +test_that("get_constr_output handles all-ones constraint matrix", { + x <- torch_tensor(matrix(c(1, 5, 3, 2, 4, 6), nrow = 2, ncol = 3, byrow = TRUE)) + R <- torch_ones(c(3, 3)) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(2, 3)) + # Each row is filled with its own row-wise maximum + expected <- matrix(c(5, 5, 5, 6, 6, 6), nrow = 2, ncol = 3, byrow = TRUE) + expect_equal_to_r(result, expected, tolerance = 1e-6) +}) + +test_that("get_constr_output throws error for dimension mismatch", { + x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + R <- torch_eye(3) + expect_error(get_constr_output(x, R), "must match the existing size") +}) + +test_that("get_constr_output throws error for non-2D R", { + x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + R <- torch_tensor(array(1:8, dim = c(2, 2, 2))) + expect_error(get_constr_output(x, R), "dimension") +}) + +test_that("max_constraint_output returns original output when ancestor is identity", { + output <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) + labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, FALSE, TRUE, FALSE), nrow = 2, ncol = 3), dtype = torch_bool()) + ancestor <- torch_eye(3) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 3)) + # With an identity ancestor matrix, constraint propagation is neutral. + # The formula simplifies to: (~labels * output) + (labels * output) == output + expect_equal_to_r(result, matrix(1:6, nrow = 2, ncol = 3)) +}) + +test_that("max_constraint_output applies constraint to positive labels", { + output <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(1, 0, 1, 0), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 2)) + # Unlabelled positions get propagated raw max, labelled get propagated masked max + expected <- matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("max_constraint_output handles all-zero labels", { + output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + labels <- torch_zeros(c(2, 2), dtype = torch_bool()) + ancestor <- torch_eye(2) + result <- max_constraint_output(output, labels, ancestor) + # With all false labels, result equals constr_output. With identity ancestor, constr_output == output + expect_equal_to_r(result, matrix(1:4, nrow = 2, ncol = 2)) +}) + +test_that("max_constraint_output handles all-one labels", { + output <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_ones(c(2, 2), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 2)) + # When all labels are TRUE, (~labels) is 0, so result = train_output. + expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("max_constraint_output preserves output dtype", { + output_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float32()) + output_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float64()) + labels <- torch_ones(c(2, 2), dtype = torch_bool()) + ancestor <- torch_eye(2) + expect_tensor_dtype(max_constraint_output(output_f32, labels, ancestor), torch_float64()) + expect_tensor_dtype(max_constraint_output(output_f64, labels, ancestor), torch_float64()) +}) + + +test_that("max_constraint_output works with complex hierarchy", { + output <- torch_tensor(matrix(c(1, 2, 3, 4, 5, 6), nrow = 2, ncol = 3, byrow = TRUE)) + labels <- torch_tensor(matrix(c(1, 0, 0, 0, 1, 0), nrow = 2, ncol = 3, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, 1, 0, 1, 1, 0, 0, 1), nrow = 3, ncol = 3, byrow = TRUE)) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 3)) + # Row 1: label on col 1 -> train_output[1,1]=1, others get constr_output=3 + # Row 2: label on col 2 -> train_output[2,2]=5, others get constr_output=6 + row1_expected <- c(1, 3, 3) + row2_expected <- c(6, 5, 6) + expect_equal_to_r(result[1, ], row1_expected) + expect_equal_to_r(result[2, ], row2_expected) +}) + +test_that("max_constraint_output handles single element tensors", { + output <- torch_tensor(matrix(5, nrow = 1, ncol = 1)) + labels <- torch_tensor(matrix(TRUE, nrow = 1, ncol = 1), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(1, nrow = 1, ncol = 1)) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(1, 1)) + # Compare against 1x1 matrix instead of scalar to match torch array output + expect_equal_to_r(result, matrix(5, nrow = 1, ncol = 1)) +}) + +test_that("max_constraint_output throws error for dimension mismatch", { + output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + labels <- torch_ones(c(2, 3), dtype = torch_bool()) + ancestor <- torch_eye(2) + expect_error(max_constraint_output(output, labels, ancestor), "dimension") +}) + +test_that("max_constraint_output handles float labels without error", { + # torch_logical_not works on float tensors (0.0 -> TRUE, others -> FALSE) + # No explicit type check exists in the function, so it should run successfully + output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + labels <- torch_ones(c(2, 2), dtype = torch_float32()) + ancestor <- torch_eye(2) + expect_silent(max_constraint_output(output, labels, ancestor)) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 2)) +}) + +test_that("get_constr_output and max_constraint_output compose correctly", { + output <- torch_tensor(matrix(c(1, 4, 2, 3), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, FALSE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + direct <- max_constraint_output(output, labels, ancestor) + constr_out <- get_constr_output(output, ancestor) + train_out <- get_constr_output(labels * output, ancestor) + manual <- torch_logical_not(labels) * constr_out + labels * train_out + expect_equal_to_r(direct, as_array(manual)) +}) + +test_that("get_constr_output handles negative values correctly", { + x <- torch_tensor(matrix(c(-5, -1, -3, -2), nrow = 2, ncol = 2, byrow = TRUE)) + R <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + result <- get_constr_output(x, R) + expected <- matrix(c(-1, 0, -2, 0), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("max_constraint_output handles mixed positive-negative with constraints", { + output <- torch_tensor(matrix(c(-5, 3, -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(TRUE, FALSE, FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + result <- max_constraint_output(output, labels, ancestor) + expected <- matrix(c(-1, 0, 0, 4), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("build-ancestor-matrix diagonal is always 1 for every class", { + edges <- data.frame(from = c(1L, 2L, 3L), to = c(2L, 3L, 1L)) + R <- build_ancestor_matrix(edges, n_classes = 3L) + R_dense <- R$to_dense() + + expect_equal_to_r(R_dense[1, 1], TRUE) + expect_equal_to_r(R_dense[2, 2], TRUE) + expect_equal_to_r(R_dense[3, 3], TRUE) +}) + +test_that("build-ancestor-matrix: single edge produces correct transitive pair", { + # 1 -> 2 means "2 is ancestor of 1", so transposed: R[2, 1] = 1 + edges <- data.frame(from = c(1L, 2L), to = c(2L, 2L)) + R <- build_ancestor_matrix(edges, n_classes = 2L) + R_dense <- R$to_dense() + + # 2 is descendant of 2 (self) + expect_equal_to_r(R_dense[2, 2], TRUE) + # 1 is descendant of 1 (self) + expect_equal_to_r(R_dense[1, 1], TRUE) + # 1 is descendant of 2 (because 1 -> 2) + expect_equal_to_r(R_dense[2, 1], TRUE) + # 2 is NOT descendant of 1 + expect_equal_to_r(R_dense[1, 2], FALSE) +}) + +test_that("build-ancestor-matrix: multi-hop ancestor chain is fully resolved", { + # Chain: 1 -> 2 -> 3 -> 4 (each is ancestor of the previous) + # After transpose: 4 is descendant of 1, 2, 3, 4 + # 3 is descendant of 1, 2, 3 + # 2 is descendant of 1, 2 + # 1 is descendant of 1 + edges <- data.frame( + from = c(1L, 2L, 3L, 1L, 2L, 3L, 4L), + to = c(2L, 3L, 4L, 1L, 2L, 3L, 4L) ) - # max_constraint_output provides more than 50% null values - expect_gte( - as.numeric((MC_output == 0)$sum()), 0.50 * prod(output$shape) + R <- build_ancestor_matrix(edges, n_classes = 4L) + R_dense <- R$to_dense() + + # Row 1: only node 1 is its own descendant + expect_equal_to_r(R_dense[1, ], c(TRUE, FALSE, FALSE, FALSE)) + # Row 2: nodes 1 and 2 are descendants of 2 + expect_equal_to_r(R_dense[2, ], c(TRUE, TRUE, FALSE, FALSE)) + # Row 3: nodes 1, 2, 3 are descendants of 3 + expect_equal_to_r(R_dense[3, ], c(TRUE, TRUE, TRUE, FALSE)) + # Row 4: all nodes are descendants of 4 + expect_equal_to_r(R_dense[4, ], c(TRUE, TRUE, TRUE, TRUE)) +}) + +test_that("build-ancestor-matrix: diamond hierarchy merges both paths", { + # Diamond: 1 -> 2 -> 4, 1 -> 3 -> 4 + # After transpose: 4 is descendant of all; 2 and 3 are descendants of + # 1 and themselves only + edges <- data.frame( + from = c(1L, 1L, 2L, 3L), + to = c(2L, 3L, 4L, 4L) ) + R <- build_ancestor_matrix(edges, n_classes = 4L) + R_dense <- R$to_dense() + + expect_equal_to_r(R_dense[4, 1], TRUE) + expect_equal_to_r(R_dense[4, 2], TRUE) + expect_equal_to_r(R_dense[4, 3], TRUE) + expect_equal_to_r(R_dense[4, 4], TRUE) + expect_equal_to_r(R_dense[2, 3], FALSE) + expect_equal_to_r(R_dense[3, 2], FALSE) +}) + +test_that("build-ancestor-matrix: isolated nodes have only a diagonal entry", { + edges <- data.frame(from = c(1L, 1L), to = c(2L, 1L)) + R <- build_ancestor_matrix(edges, n_classes = 5L) + R_dense <- R$to_dense() + + # Nodes 3, 4, 5 have no edges + expect_equal_to_r(R_dense[3, 3], TRUE) + expect_equal_to_r(R_dense[3, ], c(FALSE, FALSE, TRUE, FALSE, FALSE)) + expect_equal_to_r(R_dense[4, 4], TRUE) + expect_equal_to_r(R_dense[5, 5], TRUE) +}) + +test_that("build-ancestor-matrix: n_classes defaults to max node id when NULL", { + edges <- data.frame(from = c(1L, 1L), to = c(5L, 1L)) + R <- build_ancestor_matrix(edges) + + # n_classes should be max(1, 5, TRUE) = 5 + expect_tensor_shape(R, c(5, 5)) +}) + +test_that("build-ancestor-matrix: output has correct shape and dtype", { + edges <- data.frame(from = c(1L, 2L), to = c(2L, 1L)) + R <- build_ancestor_matrix(edges, n_classes = 3L) + + expect_tensor_shape(R, c(3L, 3L)) + expect_tensor_dtype(R, torch::torch_bool()) + expect_true(R$is_sparse()) +}) + +test_that("build-ancestor-matrix: output uses 0-based indices internally", { + # Verify that torch sees correct values when converted to dense + edges <- data.frame(from = c(1L, 2L, 3L), to = c(2L, 3L, 1L)) + R <- build_ancestor_matrix(edges, n_classes = 3L) + # 3 -> 1 -> 2 -> 3 is a cycle; after transpose every node is + # descendant of every other node + expect_equal_to_r(R$to_dense(), matrix(rep(TRUE, 9), nrow=3)) +}) + +test_that("build-ancestor-matrix: single-node graph produces identity-like matrix", { + edges <- data.frame(from = 1L, to = 1L) + R <- build_ancestor_matrix(edges, n_classes = 1L) + expect_tensor_shape(R$to_dense(), c(1L, 1L)) + expect_equal_to_r(R$to_dense()[1, 1], TRUE) }) test_that("node_to_df works ", { @@ -69,7 +344,7 @@ test_that("Training hierarchical classification for {data.tree} Node", { expect_no_error( fit <- tabnet_fit(acme, epochs = 1) ) - expect_named(fit$fit$config, "ancestor") + expect_true("ancestor" %in% fit$fit$config$names) expect_true(fit$fit$config$ancestor$is_sparse()) expect_no_error( From b6e52c0da62460a34916235c46da4a3173661979 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Mon, 4 May 2026 17:28:47 +0200 Subject: [PATCH 07/21] prune leafs in adjacency matrix extraction --- R/hardhat.R | 133 ++++++----------- R/model_training.R | 2 +- tests/testthat/test-hardhat_hierarchical.R | 165 +++++++++------------ 3 files changed, 116 insertions(+), 184 deletions(-) diff --git a/R/hardhat.R b/R/hardhat.R index d1111ef1..5cdaf4b9 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -164,12 +164,7 @@ tabnet_fit.Node <- function(x, tabnet_model = NULL, config = tabnet_config(), .. processed <- hardhat::mold(xy_df$x, xy_df$y) check_type(processed$outcomes) - # Given n classes, M is an (n x n) matrix where M_ij = 1 if class i is descendant of class j - edges <- data.tree::ToDataFrameNetwork(x) %>% - mutate_if(is.character, ~.x %>% as.factor %>% as.integer) - - # embed the M matrix in the config$ancestor variable - ancestor_tt <- build_ancestor_matrix(edges) + ancestor_tt <- build_ancestor_matrix(x) config <- merge_config_and_dots(config, ...) config$ancestor <- ancestor_tt @@ -615,101 +610,67 @@ nn_prune_head.tabnet_pretrain <- function(x, head_size) { #' orientation expected by \code{get_constr_output} and the #' max-constraint-margin (MCM) loss. #' -#' @param edges A \code{data.frame} with exactly two integer columns -#' named \code{"from"} and \code{"to"}. Each row represents a -#' directed edge from a descendant node to one of its ancestors. -#' Node IDs must be positive integers. Self-loops (e.g. \code{1 -> 1}) -#' are allowed but not required; the diagonal is always set to 1 -#' for every node in \code{1:n_classes}. -#' @param n_classes `integer(1)` or `code{NULL}`. Total number of -#' classes. When \code{NULL} (the default), it is computed as -#' \code{max(edges$from, edges$to)} so that every node appearing in -#' the edge list is represented. Supply an explicit value when there -#' are classes with no edges at all that must still appear in the -#' matrix. -#' +#' @param x a Node object. #' @return A \code{torch_sparse_coo_tensor} of shape #' \code{(n_classes, n_classes)} and dtype \code{torch_double()}. #' Entry \code{R[i, j] = 1} means class \code{j} is a descendant of #' class \code{i}. Indices follow torch's 0-based convention. #' -#' @details -#' The algorithm proceeds in three stages: -#' \enumerate{ -#' \item Build an adjacency list from the edge \code{data.frame} using -#' \code{split()}, grouping by the \code{from} column. Each entry -#' \code{adj[[i]]} contains the direct ancestors reachable from node -#' \code{i} in one hop. -#' \item Run a breadth-first search from every node \code{i = 1, ..., -#' n_classes}, following outgoing edges to discover the full set of -#' ancestors (the transitive closure). A logical \code{visited} -#' vector provides O(1) membership tests and prevents infinite loops -#' when cycles are present. -#' \item Transpose the collected COO index pairs so that the final -#' matrix is oriented for MCM: \code{R[i, j] = 1} means "j is a -#' descendant of i". -#' } -#' Because the diagonal is always filled, every class is its own -#' descendant, ensuring that the MCM constraint is at least as -#' permissive as the unconstrained prediction. -#' -#' @examples -#' \dontrun{ -#' edges <- data.frame( -#' from = c(1L, 1L, 2L, 2L, 3L), -#' to = c(2L, 3L, 4L, 5L, 5L) -#' ) -#' R <- build_ancestor_matrix(edges, n_classes = 5L) -#' } #' #' @importFrom torch torch_ones torch_int64 torch_sparse_coo_tensor #' @noRd -build_ancestor_matrix <- function(edges, n_classes = NULL) { +build_ancestor_matrix <- function(x) { + # 1. Extract edges + edges <- data.tree::ToDataFrameNetwork(x) + # 2. prune tree from root and from leafs + non_root_edges <- edges$from != x$path + non_leaf_targets <- edges$to %in% unique(edges$from) - if (is.null(n_classes)) { - n_classes <- max(c(edges$from, edges$to)) - } - - # Build adjacency list efficiently: adj[[i]] = direct ancestors of i - adj <- vector("list", n_classes) - by_from <- split(edges$to, edges$from) - for (nm in names(by_from)) { - adj[[as.integer(nm)]] <- as.integer(by_from[[nm]]) + edges <- edges[non_root_edges & non_leaf_targets, ] + + # 3. Map node names to integer indices + all_nodes <- unique(c(edges$from, edges$to)) + n <- length(all_nodes) + # Handle case where no edges match the filter + if (n == 0) { + return(matrix(nrow = 0, ncol = 2)) } - # BFS from each node to find all reachable nodes via outgoing edges - # (i.e., all ancestors). Collect COO indices. - idx_list <- lapply(seq_len(n_classes), function(i) { - visited <- rep(FALSE, n_classes) - visited[i] <- TRUE - frontier <- adj[[i]] + # Create a lookup map: name -> index + node_map <- setNames(seq_along(all_nodes), all_nodes) + + # Conversion of edges to integer indices + from_idx <- node_map[edges$from] + to_idx <- node_map[edges$to] + + # 4. Build Adjacency Matrix + # adj_mat[i, j] = 1 means i is a direct parent of j + adj_mat <- matrix(0L, nrow = n, ncol = n) + adj_mat[cbind(from_idx, to_idx)] <- 1L + + # 5. Compute Transitive Closure (Ancestors) + # Initialize reachability matrix with self-loops (Identity) + direct connections + reachability <- adj_mat + diag(n) + + # Use Boolean Matrix Multiplication to find all reachable nodes + # (i, j) = 1 if j is reachable from i (i is ancestor of j) + repeat { + # reachability %*% reachability finds paths of length 2*k + # Multiplying the matrix by itself effectively extends the reachable frontier + next_reachability <- (reachability %*% reachability) > 0 - while (length(frontier) > 0L) { - next_frontier <- integer(0) - for (node in frontier) { - if (!visited[node]) { - visited[node] <- TRUE - next_frontier <- c(next_frontier, adj[[node]]) - } - } - frontier <- next_frontier + # Check for convergence + if (identical(next_reachability, reachability)) { + break } - reached <- which(visited) - cbind(rep(i, length(reached)), reached) - }) - - # Combine all pairs: before transpose, (i, j) means j is ancestor of i - idx_mat <- do.call(rbind, idx_list) - - # Transpose: swap columns so that (i, j) means j is descendant of i - idx_mat <- cbind(idx_mat[, 2L], idx_mat[, 1L]) + # Convert back to integer/numeric for next iteration + reachability <- next_reachability * 1L + } - # idx <- torch::torch_tensor( - # matrix(idx_mat - 1L, nrow = 2L), - # dtype = torch::torch_int64() - # ) - # vals <- torch::torch_ones(nrow(idx_mat), dtype = torch::torch_double()) + # 6. Extract indices (COO format) + # which(arr.ind = TRUE) returns a matrix where col 1 is row (Ancestor) and col 2 is column (Descendant) + idx_mat <- which(reachability == 1L, arr.ind = TRUE) torch::torch_sparse_coo_tensor(t(idx_mat), rep(TRUE, nrow(idx_mat)), c(n_classes, n_classes)) } diff --git a/R/model_training.R b/R/model_training.R index 739a0beb..f5fe82dd 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -286,7 +286,7 @@ train_batch <- function(network, optimizer, batch, config) { torch::torch_split(out, outcome_nlevels, dim = 2), torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) ), - ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$ancestor)) + ~config$loss_fn(max_constraint_output(.x, .y, config$ancestor), .y$squeeze(2)) )), dim = 1) } else { diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index 8ce70b4a..bddc2286 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -133,15 +133,14 @@ test_that("max_constraint_output preserves output dtype", { test_that("max_constraint_output works with complex hierarchy", { output <- torch_tensor(matrix(c(1, 2, 3, 4, 5, 6), nrow = 2, ncol = 3, byrow = TRUE)) labels <- torch_tensor(matrix(c(1, 0, 0, 0, 1, 0), nrow = 2, ncol = 3, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, 1, 0, 1, 1, 0, 0, 1), nrow = 3, ncol = 3, byrow = TRUE)) + ancestor <- torch_triu(torch_ones(c(3,3))) result <- max_constraint_output(output, labels, ancestor) expect_tensor_shape(result, c(2, 3)) # Row 1: label on col 1 -> train_output[1,1]=1, others get constr_output=3 # Row 2: label on col 2 -> train_output[2,2]=5, others get constr_output=6 - row1_expected <- c(1, 3, 3) - row2_expected <- c(6, 5, 6) - expect_equal_to_r(result[1, ], row1_expected) - expect_equal_to_r(result[2, ], row2_expected) + expected <- matrix(c(1, 3, 3, + 6, 5, 6), nrow = 2, ncol = 3, byrow = TRUE) + expect_equal_to_r(result, expected) }) test_that("max_constraint_output handles single element tensors", { @@ -192,19 +191,21 @@ test_that("get_constr_output handles negative values correctly", { }) test_that("max_constraint_output handles mixed positive-negative with constraints", { - output <- torch_tensor(matrix(c(-5, 3, -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(TRUE, FALSE, FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + output <- torch_tensor(matrix(c(-5, -3, -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(TRUE, TRUE, FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) result <- max_constraint_output(output, labels, ancestor) - expected <- matrix(c(-1, 0, 0, 4), nrow = 2, ncol = 2, byrow = TRUE) + expected <- matrix(c(-3, 0, 4, 4), nrow = 2, ncol = 2, byrow = TRUE) expect_equal_to_r(result, expected) }) +# need rework as FromDataFrameNetwork(edges) gives "cannot find root name" error test_that("build-ancestor-matrix diagonal is always 1 for every class", { - edges <- data.frame(from = c(1L, 2L, 3L), to = c(2L, 3L, 1L)) - R <- build_ancestor_matrix(edges, n_classes = 3L) + edges <- data.frame(from = c(1L, 2L, 2L), + to = c(2L, 3L, 4L)) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) R_dense <- R$to_dense() - + expect_equal_to_r(R_dense[1, 1], TRUE) expect_equal_to_r(R_dense[2, 2], TRUE) expect_equal_to_r(R_dense[3, 3], TRUE) @@ -212,10 +213,10 @@ test_that("build-ancestor-matrix diagonal is always 1 for every class", { test_that("build-ancestor-matrix: single edge produces correct transitive pair", { # 1 -> 2 means "2 is ancestor of 1", so transposed: R[2, 1] = 1 - edges <- data.frame(from = c(1L, 2L), to = c(2L, 2L)) - R <- build_ancestor_matrix(edges, n_classes = 2L) + edges <- data.frame(from = c(1L, 2L), to = c(2L, 3L)) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) R_dense <- R$to_dense() - + # 2 is descendant of 2 (self) expect_equal_to_r(R_dense[2, 2], TRUE) # 1 is descendant of 1 (self) @@ -227,26 +228,20 @@ test_that("build-ancestor-matrix: single edge produces correct transitive pair", }) test_that("build-ancestor-matrix: multi-hop ancestor chain is fully resolved", { - # Chain: 1 -> 2 -> 3 -> 4 (each is ancestor of the previous) + # Chain: 2 -> 3 -> 4 -> 5 (each is ancestor of the previous) # After transpose: 4 is descendant of 1, 2, 3, 4 # 3 is descendant of 1, 2, 3 # 2 is descendant of 1, 2 # 1 is descendant of 1 edges <- data.frame( - from = c(1L, 2L, 3L, 1L, 2L, 3L, 4L), - to = c(2L, 3L, 4L, 1L, 2L, 3L, 4L) + from = c(1L, 2L, 3L, 4L), + to = c(2L, 3L, 4L, 5L) ) - R <- build_ancestor_matrix(edges, n_classes = 4L) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) R_dense <- R$to_dense() - + # Row 1: only node 1 is its own descendant - expect_equal_to_r(R_dense[1, ], c(TRUE, FALSE, FALSE, FALSE)) - # Row 2: nodes 1 and 2 are descendants of 2 - expect_equal_to_r(R_dense[2, ], c(TRUE, TRUE, FALSE, FALSE)) - # Row 3: nodes 1, 2, 3 are descendants of 3 - expect_equal_to_r(R_dense[3, ], c(TRUE, TRUE, TRUE, FALSE)) - # Row 4: all nodes are descendants of 4 - expect_equal_to_r(R_dense[4, ], c(TRUE, TRUE, TRUE, TRUE)) + expect_equal_to_r(R_dense, lower.tri(diag(4), diag = TRUE)) }) test_that("build-ancestor-matrix: diamond hierarchy merges both paths", { @@ -257,61 +252,58 @@ test_that("build-ancestor-matrix: diamond hierarchy merges both paths", { from = c(1L, 1L, 2L, 3L), to = c(2L, 3L, 4L, 4L) ) - R <- build_ancestor_matrix(edges, n_classes = 4L) - R_dense <- R$to_dense() - - expect_equal_to_r(R_dense[4, 1], TRUE) - expect_equal_to_r(R_dense[4, 2], TRUE) - expect_equal_to_r(R_dense[4, 3], TRUE) - expect_equal_to_r(R_dense[4, 4], TRUE) - expect_equal_to_r(R_dense[2, 3], FALSE) - expect_equal_to_r(R_dense[3, 2], FALSE) -}) - -test_that("build-ancestor-matrix: isolated nodes have only a diagonal entry", { - edges <- data.frame(from = c(1L, 1L), to = c(2L, 1L)) - R <- build_ancestor_matrix(edges, n_classes = 5L) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) R_dense <- R$to_dense() - - # Nodes 3, 4, 5 have no edges - expect_equal_to_r(R_dense[3, 3], TRUE) - expect_equal_to_r(R_dense[3, ], c(FALSE, FALSE, TRUE, FALSE, FALSE)) - expect_equal_to_r(R_dense[4, 4], TRUE) - expect_equal_to_r(R_dense[5, 5], TRUE) -}) - -test_that("build-ancestor-matrix: n_classes defaults to max node id when NULL", { - edges <- data.frame(from = c(1L, 1L), to = c(5L, 1L)) - R <- build_ancestor_matrix(edges) - - # n_classes should be max(1, 5, TRUE) = 5 - expect_tensor_shape(R, c(5, 5)) -}) - -test_that("build-ancestor-matrix: output has correct shape and dtype", { - edges <- data.frame(from = c(1L, 2L), to = c(2L, 1L)) - R <- build_ancestor_matrix(edges, n_classes = 3L) - - expect_tensor_shape(R, c(3L, 3L)) - expect_tensor_dtype(R, torch::torch_bool()) - expect_true(R$is_sparse()) -}) + expect_equal_to_r(R_dense[3, 1], TRUE) + expect_equal_to_r(R_dense[4, 2], TRUE) + expect_equal_to_r(R_dense[4, 3], FALSE) + expect_equal_to_r(R_dense[2, 4], FALSE) +}) + +# test_that("build-ancestor-matrix: isolated nodes have only a diagonal entry", { +# edges <- data.frame(from = c(1L, 1L), +# to = c(2L, 1L)) +# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) +# R_dense <- R$to_dense() +# +# # Nodes 3, 4, 5 have no edges +# expect_equal_to_r(R_dense[3, 3], TRUE) +# expect_equal_to_r(R_dense[3, ], c(FALSE, FALSE, TRUE, FALSE, FALSE)) +# expect_equal_to_r(R_dense[4, 4], TRUE) +# expect_equal_to_r(R_dense[5, 5], TRUE) +# }) +# +# test_that("build-ancestor-matrix: n_classes defaults to max node id when NULL", { +# edges <- data.frame(from = c(1L, 1L), to = c(5L, 1L)) +# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) +# +# # n_classes should be max(1, 5, TRUE) = 5 +# expect_tensor_shape(R, c(5, 5)) +# }) + +# test_that("build-ancestor-matrix: output has correct shape and dtype", { +# edges <- data.frame(from = c(1L, 2L), to = c(2L, 1L)) +# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) +# +# expect_tensor_shape(R, c(3L, 3L)) +# expect_tensor_dtype(R, torch::torch_bool()) +# expect_true(R$is_sparse()) +# }) +# test_that("build-ancestor-matrix: output uses 0-based indices internally", { # Verify that torch sees correct values when converted to dense - edges <- data.frame(from = c(1L, 2L, 3L), to = c(2L, 3L, 1L)) - R <- build_ancestor_matrix(edges, n_classes = 3L) - # 3 -> 1 -> 2 -> 3 is a cycle; after transpose every node is - # descendant of every other node - expect_equal_to_r(R$to_dense(), matrix(rep(TRUE, 9), nrow=3)) + edges <- data.frame(from = c(1L, 2L, 1L), to = c(2L, 3L, 3L)) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) + expect_equal_to_r(R$to_dense(), matrix(c(TRUE, TRUE, FALSE, TRUE), nrow=2)) }) -test_that("build-ancestor-matrix: single-node graph produces identity-like matrix", { - edges <- data.frame(from = 1L, to = 1L) - R <- build_ancestor_matrix(edges, n_classes = 1L) - expect_tensor_shape(R$to_dense(), c(1L, 1L)) - expect_equal_to_r(R$to_dense()[1, 1], TRUE) -}) +# test_that("build-ancestor-matrix: single-node graph produces identity-like matrix", { +# edges <- data.frame(from = 1L, to = 1L) +# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) +# expect_tensor_shape(R$to_dense(), c(1L, 1L)) +# expect_equal_to_r(R$to_dense()[1, 1], TRUE) +# }) test_that("node_to_df works ", { expect_no_error( @@ -338,28 +330,7 @@ test_that("node_to_df works ", { }) - -test_that("Training hierarchical classification for {data.tree} Node", { - - expect_no_error( - fit <- tabnet_fit(acme, epochs = 1) - ) - expect_true("ancestor" %in% fit$fit$config$names) - expect_true(fit$fit$config$ancestor$is_sparse()) - - expect_no_error( - result <- predict(fit, acme_df, type = "prob") - ) - - expect_equal(ncol(result), 3) - outcome_levels <- levels(fit$blueprint$ptypes$outcomes[[1]]) - # we get back outcomes vars with a `.pred_` prefix - expect_equal(stringr::str_remove(names(result), ".pred_"), outcome_levels) - expect_no_error( - result <- predict(fit, acme_df) - ) - expect_equal(ncol(result), 1) - +test_that("Training hierarchical classification for {data.tree} Node attrition_tree", { expect_no_error( fit <- tabnet_fit(attrition_tree, epochs = 1) ) From 3d702d8296880678ccefbd4031caac7c44ac1c65 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Mon, 4 May 2026 17:29:14 +0200 Subject: [PATCH 08/21] split tests bw utils and modeling --- tests/testthat/test-hardhat_hierarchical.R | 332 --------------------- tests/testthat/test-hierarchical_utils.R | 331 ++++++++++++++++++++ 2 files changed, 331 insertions(+), 332 deletions(-) create mode 100644 tests/testthat/test-hierarchical_utils.R diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index bddc2286..1b3d9ef8 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -1,335 +1,3 @@ -test_that("get_constr_output handles basic 2D input with identity constraint", { - x <- torch_tensor(matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2), dtype = torch_float32()) - R <- torch_eye(2, dtype = torch_float32()) - result <- get_constr_output(x, R) - expect_tensor(result) - expect_tensor_shape(result, c(2, 2)) - expect_equal_to_r(result, matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2)) -}) - -test_that("get_constr_output applies hierarchy constraint correctly", { - x <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) - R <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) - result <- get_constr_output(x, R) - expect_tensor_shape(result, c(2, 2)) - expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected, tolerance = 1e-6) -}) - -test_that("get_constr_output preserves input dtype", { - x_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float32()) - x_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float64()) - R <- torch_eye(2) - expect_tensor_dtype(get_constr_output(x_f32, R), torch_float64()) - expect_tensor_dtype(get_constr_output(x_f64, R), torch_float64()) -}) - -test_that("get_constr_output handles batch dimension correctly", { - x <- torch_tensor(matrix(1:12, nrow = 3, ncol = 4)) - R <- torch_tensor(matrix(c(1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) - result <- get_constr_output(x, R) - expect_tensor_shape(result, c(3, 4)) - - for (i in 1:3) { - row_result <- as_array(result[i, ]) - max_grp1 <- max(as_array(x[i, 1:2])) - max_grp2 <- max(as_array(x[i, 3:4])) - - expect_equal(row_result[1:2], rep(max_grp1, 2), tolerance = 1e-6) - expect_equal(row_result[3:4], rep(max_grp2, 2), tolerance = 1e-6) - } -}) -test_that("get_constr_output works with single sample", { - x <- torch_tensor(matrix(c(2, 1, 4, 3), nrow = 1, ncol = 4, byrow = TRUE)) - R <- torch_tensor(matrix(c(1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) - result <- get_constr_output(x, R) - expect_tensor_shape(result, c(1, 4)) - expected <- matrix(c(2, 2, 4, 4), nrow = 1, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -test_that("get_constr_output handles all-zeros constraint matrix", { - x <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) - R <- torch_zeros(c(3, 3)) - result <- get_constr_output(x, R) - expect_tensor_shape(result, c(2, 3)) - expect_equal_to_r(result, matrix(0, nrow = 2, ncol = 3)) -}) - -test_that("get_constr_output handles all-ones constraint matrix", { - x <- torch_tensor(matrix(c(1, 5, 3, 2, 4, 6), nrow = 2, ncol = 3, byrow = TRUE)) - R <- torch_ones(c(3, 3)) - result <- get_constr_output(x, R) - expect_tensor_shape(result, c(2, 3)) - # Each row is filled with its own row-wise maximum - expected <- matrix(c(5, 5, 5, 6, 6, 6), nrow = 2, ncol = 3, byrow = TRUE) - expect_equal_to_r(result, expected, tolerance = 1e-6) -}) - -test_that("get_constr_output throws error for dimension mismatch", { - x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - R <- torch_eye(3) - expect_error(get_constr_output(x, R), "must match the existing size") -}) - -test_that("get_constr_output throws error for non-2D R", { - x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - R <- torch_tensor(array(1:8, dim = c(2, 2, 2))) - expect_error(get_constr_output(x, R), "dimension") -}) - -test_that("max_constraint_output returns original output when ancestor is identity", { - output <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) - labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, FALSE, TRUE, FALSE), nrow = 2, ncol = 3), dtype = torch_bool()) - ancestor <- torch_eye(3) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 3)) - # With an identity ancestor matrix, constraint propagation is neutral. - # The formula simplifies to: (~labels * output) + (labels * output) == output - expect_equal_to_r(result, matrix(1:6, nrow = 2, ncol = 3)) -}) - -test_that("max_constraint_output applies constraint to positive labels", { - output <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(1, 0, 1, 0), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 2)) - # Unlabelled positions get propagated raw max, labelled get propagated masked max - expected <- matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -test_that("max_constraint_output handles all-zero labels", { - output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - labels <- torch_zeros(c(2, 2), dtype = torch_bool()) - ancestor <- torch_eye(2) - result <- max_constraint_output(output, labels, ancestor) - # With all false labels, result equals constr_output. With identity ancestor, constr_output == output - expect_equal_to_r(result, matrix(1:4, nrow = 2, ncol = 2)) -}) - -test_that("max_constraint_output handles all-one labels", { - output <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_ones(c(2, 2), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 2)) - # When all labels are TRUE, (~labels) is 0, so result = train_output. - expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -test_that("max_constraint_output preserves output dtype", { - output_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float32()) - output_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float64()) - labels <- torch_ones(c(2, 2), dtype = torch_bool()) - ancestor <- torch_eye(2) - expect_tensor_dtype(max_constraint_output(output_f32, labels, ancestor), torch_float64()) - expect_tensor_dtype(max_constraint_output(output_f64, labels, ancestor), torch_float64()) -}) - - -test_that("max_constraint_output works with complex hierarchy", { - output <- torch_tensor(matrix(c(1, 2, 3, 4, 5, 6), nrow = 2, ncol = 3, byrow = TRUE)) - labels <- torch_tensor(matrix(c(1, 0, 0, 0, 1, 0), nrow = 2, ncol = 3, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_triu(torch_ones(c(3,3))) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 3)) - # Row 1: label on col 1 -> train_output[1,1]=1, others get constr_output=3 - # Row 2: label on col 2 -> train_output[2,2]=5, others get constr_output=6 - expected <- matrix(c(1, 3, 3, - 6, 5, 6), nrow = 2, ncol = 3, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -test_that("max_constraint_output handles single element tensors", { - output <- torch_tensor(matrix(5, nrow = 1, ncol = 1)) - labels <- torch_tensor(matrix(TRUE, nrow = 1, ncol = 1), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(1, nrow = 1, ncol = 1)) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(1, 1)) - # Compare against 1x1 matrix instead of scalar to match torch array output - expect_equal_to_r(result, matrix(5, nrow = 1, ncol = 1)) -}) - -test_that("max_constraint_output throws error for dimension mismatch", { - output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - labels <- torch_ones(c(2, 3), dtype = torch_bool()) - ancestor <- torch_eye(2) - expect_error(max_constraint_output(output, labels, ancestor), "dimension") -}) - -test_that("max_constraint_output handles float labels without error", { - # torch_logical_not works on float tensors (0.0 -> TRUE, others -> FALSE) - # No explicit type check exists in the function, so it should run successfully - output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - labels <- torch_ones(c(2, 2), dtype = torch_float32()) - ancestor <- torch_eye(2) - expect_silent(max_constraint_output(output, labels, ancestor)) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 2)) -}) - -test_that("get_constr_output and max_constraint_output compose correctly", { - output <- torch_tensor(matrix(c(1, 4, 2, 3), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, FALSE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - direct <- max_constraint_output(output, labels, ancestor) - constr_out <- get_constr_output(output, ancestor) - train_out <- get_constr_output(labels * output, ancestor) - manual <- torch_logical_not(labels) * constr_out + labels * train_out - expect_equal_to_r(direct, as_array(manual)) -}) - -test_that("get_constr_output handles negative values correctly", { - x <- torch_tensor(matrix(c(-5, -1, -3, -2), nrow = 2, ncol = 2, byrow = TRUE)) - R <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - result <- get_constr_output(x, R) - expected <- matrix(c(-1, 0, -2, 0), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -test_that("max_constraint_output handles mixed positive-negative with constraints", { - output <- torch_tensor(matrix(c(-5, -3, -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(TRUE, TRUE, FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - result <- max_constraint_output(output, labels, ancestor) - expected <- matrix(c(-3, 0, 4, 4), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -# need rework as FromDataFrameNetwork(edges) gives "cannot find root name" error -test_that("build-ancestor-matrix diagonal is always 1 for every class", { - edges <- data.frame(from = c(1L, 2L, 2L), - to = c(2L, 3L, 4L)) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - R_dense <- R$to_dense() - - expect_equal_to_r(R_dense[1, 1], TRUE) - expect_equal_to_r(R_dense[2, 2], TRUE) - expect_equal_to_r(R_dense[3, 3], TRUE) -}) - -test_that("build-ancestor-matrix: single edge produces correct transitive pair", { - # 1 -> 2 means "2 is ancestor of 1", so transposed: R[2, 1] = 1 - edges <- data.frame(from = c(1L, 2L), to = c(2L, 3L)) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - R_dense <- R$to_dense() - - # 2 is descendant of 2 (self) - expect_equal_to_r(R_dense[2, 2], TRUE) - # 1 is descendant of 1 (self) - expect_equal_to_r(R_dense[1, 1], TRUE) - # 1 is descendant of 2 (because 1 -> 2) - expect_equal_to_r(R_dense[2, 1], TRUE) - # 2 is NOT descendant of 1 - expect_equal_to_r(R_dense[1, 2], FALSE) -}) - -test_that("build-ancestor-matrix: multi-hop ancestor chain is fully resolved", { - # Chain: 2 -> 3 -> 4 -> 5 (each is ancestor of the previous) - # After transpose: 4 is descendant of 1, 2, 3, 4 - # 3 is descendant of 1, 2, 3 - # 2 is descendant of 1, 2 - # 1 is descendant of 1 - edges <- data.frame( - from = c(1L, 2L, 3L, 4L), - to = c(2L, 3L, 4L, 5L) - ) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - R_dense <- R$to_dense() - - # Row 1: only node 1 is its own descendant - expect_equal_to_r(R_dense, lower.tri(diag(4), diag = TRUE)) -}) - -test_that("build-ancestor-matrix: diamond hierarchy merges both paths", { - # Diamond: 1 -> 2 -> 4, 1 -> 3 -> 4 - # After transpose: 4 is descendant of all; 2 and 3 are descendants of - # 1 and themselves only - edges <- data.frame( - from = c(1L, 1L, 2L, 3L), - to = c(2L, 3L, 4L, 4L) - ) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - R_dense <- R$to_dense() - - expect_equal_to_r(R_dense[3, 1], TRUE) - expect_equal_to_r(R_dense[4, 2], TRUE) - expect_equal_to_r(R_dense[4, 3], FALSE) - expect_equal_to_r(R_dense[2, 4], FALSE) -}) - -# test_that("build-ancestor-matrix: isolated nodes have only a diagonal entry", { -# edges <- data.frame(from = c(1L, 1L), -# to = c(2L, 1L)) -# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) -# R_dense <- R$to_dense() -# -# # Nodes 3, 4, 5 have no edges -# expect_equal_to_r(R_dense[3, 3], TRUE) -# expect_equal_to_r(R_dense[3, ], c(FALSE, FALSE, TRUE, FALSE, FALSE)) -# expect_equal_to_r(R_dense[4, 4], TRUE) -# expect_equal_to_r(R_dense[5, 5], TRUE) -# }) -# -# test_that("build-ancestor-matrix: n_classes defaults to max node id when NULL", { -# edges <- data.frame(from = c(1L, 1L), to = c(5L, 1L)) -# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) -# -# # n_classes should be max(1, 5, TRUE) = 5 -# expect_tensor_shape(R, c(5, 5)) -# }) - -# test_that("build-ancestor-matrix: output has correct shape and dtype", { -# edges <- data.frame(from = c(1L, 2L), to = c(2L, 1L)) -# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) -# -# expect_tensor_shape(R, c(3L, 3L)) -# expect_tensor_dtype(R, torch::torch_bool()) -# expect_true(R$is_sparse()) -# }) -# -test_that("build-ancestor-matrix: output uses 0-based indices internally", { - # Verify that torch sees correct values when converted to dense - edges <- data.frame(from = c(1L, 2L, 1L), to = c(2L, 3L, 3L)) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - expect_equal_to_r(R$to_dense(), matrix(c(TRUE, TRUE, FALSE, TRUE), nrow=2)) -}) - -# test_that("build-ancestor-matrix: single-node graph produces identity-like matrix", { -# edges <- data.frame(from = 1L, to = 1L) -# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) -# expect_tensor_shape(R$to_dense(), c(1L, 1L)) -# expect_equal_to_r(R$to_dense()[1, 1], TRUE) -# }) - -test_that("node_to_df works ", { - expect_no_error( - node_to_df(acme) - ) - expect_no_error( - attrition_df <- node_to_df(attrition_tree) - ) - # node_to_df removes first and last level of the hierarchy - outcome_levels <- paste0("level_", seq(2, attrition_tree$height - 1)) - expect_equal(names(attrition_df$y), outcome_levels) - - # node_to_df do not shuffle outcome rows - df <- tibble(pred_1 = seq(1,26), pred_2 = seq(26,1), - level_2 = factor(LETTERS[1:26]), level_3 = factor(letters[26:1])) - df_node_df <- df %>% - mutate(pathString = paste("synth", level_2, level_3, level_3, sep = "/")) %>% - select(-level_2, -level_3) %>% - as.Node() %>% - node_to_df() - - expect_equal(df_node_df$y %>% as_tibble(), df %>% select(starts_with("level_"))) - expect_equal(df_node_df$x %>% as_tibble(), df %>% select(starts_with("pred_"))) - -}) - test_that("Training hierarchical classification for {data.tree} Node attrition_tree", { expect_no_error( fit <- tabnet_fit(attrition_tree, epochs = 1) diff --git a/tests/testthat/test-hierarchical_utils.R b/tests/testthat/test-hierarchical_utils.R new file mode 100644 index 00000000..905d94b4 --- /dev/null +++ b/tests/testthat/test-hierarchical_utils.R @@ -0,0 +1,331 @@ +test_that("get_constr_output handles basic 2D input with identity constraint", { + x <- torch_tensor(matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2), dtype = torch_float32()) + R <- torch_eye(2, dtype = torch_float32()) + result <- get_constr_output(x, R) + expect_tensor(result) + expect_tensor_shape(result, c(2, 2)) + expect_equal_to_r(result, matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2)) +}) + +test_that("get_constr_output applies hierarchy constraint correctly", { + x <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) + R <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(2, 2)) + expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected, tolerance = 1e-6) +}) + +test_that("get_constr_output preserves input dtype", { + x_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float32()) + x_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float64()) + R <- torch_eye(2) + expect_tensor_dtype(get_constr_output(x_f32, R), torch_float64()) + expect_tensor_dtype(get_constr_output(x_f64, R), torch_float64()) +}) + +test_that("get_constr_output handles batch dimension correctly", { + x <- torch_tensor(matrix(1:12, nrow = 3, ncol = 4)) + R <- torch_tensor(matrix(c(1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(3, 4)) + + for (i in 1:3) { + row_result <- as_array(result[i, ]) + max_grp1 <- max(as_array(x[i, 1:2])) + max_grp2 <- max(as_array(x[i, 3:4])) + + expect_equal(row_result[1:2], rep(max_grp1, 2), tolerance = 1e-6) + expect_equal(row_result[3:4], rep(max_grp2, 2), tolerance = 1e-6) + } +}) +test_that("get_constr_output works with single sample", { + x <- torch_tensor(matrix(c(2, 1, 4, 3), nrow = 1, ncol = 4, byrow = TRUE)) + R <- torch_tensor(matrix(c(1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(1, 4)) + expected <- matrix(c(2, 2, 4, 4), nrow = 1, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("get_constr_output handles all-zeros constraint matrix", { + x <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) + R <- torch_zeros(c(3, 3)) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(2, 3)) + expect_equal_to_r(result, matrix(0, nrow = 2, ncol = 3)) +}) + +test_that("get_constr_output handles all-ones constraint matrix", { + x <- torch_tensor(matrix(c(1, 5, 3, 2, 4, 6), nrow = 2, ncol = 3, byrow = TRUE)) + R <- torch_ones(c(3, 3)) + result <- get_constr_output(x, R) + expect_tensor_shape(result, c(2, 3)) + # Each row is filled with its own row-wise maximum + expected <- matrix(c(5, 5, 5, 6, 6, 6), nrow = 2, ncol = 3, byrow = TRUE) + expect_equal_to_r(result, expected, tolerance = 1e-6) +}) + +test_that("get_constr_output throws error for dimension mismatch", { + x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + R <- torch_eye(3) + expect_error(get_constr_output(x, R), "must match the existing size") +}) + +test_that("get_constr_output throws error for non-2D R", { + x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + R <- torch_tensor(array(1:8, dim = c(2, 2, 2))) + expect_error(get_constr_output(x, R), "dimension") +}) + +test_that("max_constraint_output returns original output when ancestor is identity", { + output <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) + labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, FALSE, TRUE, FALSE), nrow = 2, ncol = 3), dtype = torch_bool()) + ancestor <- torch_eye(3) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 3)) + # With an identity ancestor matrix, constraint propagation is neutral. + # The formula simplifies to: (~labels * output) + (labels * output) == output + expect_equal_to_r(result, matrix(1:6, nrow = 2, ncol = 3)) +}) + +test_that("max_constraint_output applies constraint to positive labels", { + output <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(1, 0, 1, 0), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 2)) + # Unlabelled positions get propagated raw max, labelled get propagated masked max + expected <- matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("max_constraint_output handles all-zero labels", { + output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + labels <- torch_zeros(c(2, 2), dtype = torch_bool()) + ancestor <- torch_eye(2) + result <- max_constraint_output(output, labels, ancestor) + # With all false labels, result equals constr_output. With identity ancestor, constr_output == output + expect_equal_to_r(result, matrix(1:4, nrow = 2, ncol = 2)) +}) + +test_that("max_constraint_output handles all-one labels", { + output <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_ones(c(2, 2), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 2)) + # When all labels are TRUE, (~labels) is 0, so result = train_output. + expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("max_constraint_output preserves output dtype", { + output_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float32()) + output_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float64()) + labels <- torch_ones(c(2, 2), dtype = torch_bool()) + ancestor <- torch_eye(2) + expect_tensor_dtype(max_constraint_output(output_f32, labels, ancestor), torch_float64()) + expect_tensor_dtype(max_constraint_output(output_f64, labels, ancestor), torch_float64()) +}) + + +test_that("max_constraint_output works with complex hierarchy", { + output <- torch_tensor(matrix(c(1, 2, 3, 4, 5, 6), nrow = 2, ncol = 3, byrow = TRUE)) + labels <- torch_tensor(matrix(c(1, 0, 0, 0, 1, 0), nrow = 2, ncol = 3, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_triu(torch_ones(c(3,3))) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 3)) + # Row 1: label on col 1 -> train_output[1,1]=1, others get constr_output=3 + # Row 2: label on col 2 -> train_output[2,2]=5, others get constr_output=6 + expected <- matrix(c(1, 3, 3, + 6, 5, 6), nrow = 2, ncol = 3, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("max_constraint_output handles single element tensors", { + output <- torch_tensor(matrix(5, nrow = 1, ncol = 1)) + labels <- torch_tensor(matrix(TRUE, nrow = 1, ncol = 1), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(1, nrow = 1, ncol = 1)) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(1, 1)) + # Compare against 1x1 matrix instead of scalar to match torch array output + expect_equal_to_r(result, matrix(5, nrow = 1, ncol = 1)) +}) + +test_that("max_constraint_output throws error for dimension mismatch", { + output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + labels <- torch_ones(c(2, 3), dtype = torch_bool()) + ancestor <- torch_eye(2) + expect_error(max_constraint_output(output, labels, ancestor), "dimension") +}) + +test_that("max_constraint_output handles float labels without error", { + # torch_logical_not works on float tensors (0.0 -> TRUE, others -> FALSE) + # No explicit type check exists in the function, so it should run successfully + output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + labels <- torch_ones(c(2, 2), dtype = torch_float32()) + ancestor <- torch_eye(2) + expect_silent(max_constraint_output(output, labels, ancestor)) + result <- max_constraint_output(output, labels, ancestor) + expect_tensor_shape(result, c(2, 2)) +}) + +test_that("get_constr_output and max_constraint_output compose correctly", { + output <- torch_tensor(matrix(c(1, 4, 2, 3), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, FALSE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + direct <- max_constraint_output(output, labels, ancestor) + constr_out <- get_constr_output(output, ancestor) + train_out <- get_constr_output(labels * output, ancestor) + manual <- torch_logical_not(labels) * constr_out + labels * train_out + expect_equal_to_r(direct, as_array(manual)) +}) + +test_that("get_constr_output handles negative values correctly", { + x <- torch_tensor(matrix(c(-5, -1, -3, -2), nrow = 2, ncol = 2, byrow = TRUE)) + R <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + result <- get_constr_output(x, R) + expected <- matrix(c(-1, 0, -2, 0), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("max_constraint_output handles mixed positive-negative with constraints", { + output <- torch_tensor(matrix(c(-5, -3, -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(TRUE, TRUE, FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + result <- max_constraint_output(output, labels, ancestor) + expected <- matrix(c(-3, 0, 4, 4), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +# need rework as FromDataFrameNetwork(edges) gives "cannot find root name" error +test_that("build-ancestor-matrix diagonal is always 1 for every class", { + edges <- data.frame(from = c(1L, 2L, 2L), + to = c(2L, 3L, 4L)) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) + R_dense <- R$to_dense() + + expect_equal_to_r(R_dense[1, 1], TRUE) + expect_equal_to_r(R_dense[2, 2], TRUE) + expect_equal_to_r(R_dense[3, 3], TRUE) +}) + +test_that("build-ancestor-matrix: single edge produces correct transitive pair", { + # 1 -> 2 means "2 is ancestor of 1", so transposed: R[2, 1] = 1 + edges <- data.frame(from = c(1L, 2L), to = c(2L, 3L)) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) + R_dense <- R$to_dense() + + # 2 is descendant of 2 (self) + expect_equal_to_r(R_dense[2, 2], TRUE) + # 1 is descendant of 1 (self) + expect_equal_to_r(R_dense[1, 1], TRUE) + # 1 is descendant of 2 (because 1 -> 2) + expect_equal_to_r(R_dense[2, 1], TRUE) + # 2 is NOT descendant of 1 + expect_equal_to_r(R_dense[1, 2], FALSE) +}) + +test_that("build-ancestor-matrix: multi-hop ancestor chain is fully resolved", { + # Chain: 2 -> 3 -> 4 -> 5 (each is ancestor of the previous) + # After transpose: 4 is descendant of 1, 2, 3, 4 + # 3 is descendant of 1, 2, 3 + # 2 is descendant of 1, 2 + # 1 is descendant of 1 + edges <- data.frame( + from = c(1L, 2L, 3L, 4L), + to = c(2L, 3L, 4L, 5L) + ) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) + R_dense <- R$to_dense() + + # Row 1: only node 1 is its own descendant + expect_equal_to_r(R_dense, lower.tri(diag(4), diag = TRUE)) +}) + +test_that("build-ancestor-matrix: diamond hierarchy merges both paths", { + # Diamond: 1 -> 2 -> 4, 1 -> 3 -> 4 + # After transpose: 4 is descendant of all; 2 and 3 are descendants of + # 1 and themselves only + edges <- data.frame( + from = c(1L, 1L, 2L, 3L), + to = c(2L, 3L, 4L, 4L) + ) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) + R_dense <- R$to_dense() + + expect_equal_to_r(R_dense[3, 1], TRUE) + expect_equal_to_r(R_dense[4, 2], TRUE) + expect_equal_to_r(R_dense[4, 3], FALSE) + expect_equal_to_r(R_dense[2, 4], FALSE) +}) + +# test_that("build-ancestor-matrix: isolated nodes have only a diagonal entry", { +# edges <- data.frame(from = c(1L, 1L), +# to = c(2L, 1L)) +# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) +# R_dense <- R$to_dense() +# +# # Nodes 3, 4, 5 have no edges +# expect_equal_to_r(R_dense[3, 3], TRUE) +# expect_equal_to_r(R_dense[3, ], c(FALSE, FALSE, TRUE, FALSE, FALSE)) +# expect_equal_to_r(R_dense[4, 4], TRUE) +# expect_equal_to_r(R_dense[5, 5], TRUE) +# }) +# +# test_that("build-ancestor-matrix: n_classes defaults to max node id when NULL", { +# edges <- data.frame(from = c(1L, 1L), to = c(5L, 1L)) +# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) +# +# # n_classes should be max(1, 5, TRUE) = 5 +# expect_tensor_shape(R, c(5, 5)) +# }) + +# test_that("build-ancestor-matrix: output has correct shape and dtype", { +# edges <- data.frame(from = c(1L, 2L), to = c(2L, 1L)) +# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) +# +# expect_tensor_shape(R, c(3L, 3L)) +# expect_tensor_dtype(R, torch::torch_bool()) +# expect_true(R$is_sparse()) +# }) +# +test_that("build-ancestor-matrix: output uses 0-based indices internally", { + # Verify that torch sees correct values when converted to dense + edges <- data.frame(from = c(1L, 2L, 1L), to = c(2L, 3L, 3L)) + R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) + expect_equal_to_r(R$to_dense(), matrix(c(TRUE, TRUE, FALSE, TRUE), nrow=2)) +}) + +# test_that("build-ancestor-matrix: single-node graph produces identity-like matrix", { +# edges <- data.frame(from = 1L, to = 1L) +# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) +# expect_tensor_shape(R$to_dense(), c(1L, 1L)) +# expect_equal_to_r(R$to_dense()[1, 1], TRUE) +# }) + +test_that("node_to_df works ", { + expect_no_error( + node_to_df(acme) + ) + expect_no_error( + attrition_df <- node_to_df(attrition_tree) + ) + # node_to_df removes first and last level of the hierarchy + outcome_levels <- paste0("level_", seq(2, attrition_tree$height - 1)) + expect_equal(names(attrition_df$y), outcome_levels) + + # node_to_df do not shuffle outcome rows + df <- tibble(pred_1 = seq(1,26), pred_2 = seq(26,1), + level_2 = factor(LETTERS[1:26]), level_3 = factor(letters[26:1])) + df_node_df <- df %>% + mutate(pathString = paste("synth", level_2, level_3, level_3, sep = "/")) %>% + select(-level_2, -level_3) %>% + as.Node() %>% + node_to_df() + + expect_equal(df_node_df$y %>% as_tibble(), df %>% select(starts_with("level_"))) + expect_equal(df_node_df$x %>% as_tibble(), df %>% select(starts_with("pred_"))) + +}) From 07a639cd7d9fabc1158d736b9c42ee823c5a46e8 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Mon, 4 May 2026 23:00:54 +0200 Subject: [PATCH 09/21] adapt build_ancestor_matrix test to the new pruning of leaf nodes --- tests/testthat/setup.R | 15 ++ tests/testthat/test-hierarchical_utils.R | 248 +++++++++++++++-------- 2 files changed, 173 insertions(+), 90 deletions(-) diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 74c72ae9..abb33507 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -47,5 +47,20 @@ attrition_tree <- attrition %>% select(-Department, -JobRole, -rowid) %>% data.tree::as.Node() +# --- Helper function to create test trees easily --- +create_test_tree <- function(structure) { + # structure: list of path strings or a nested list + # Simple parser for "Root/A/B" style paths + paths <- structure + root_name <- unique(sapply(strsplit(paths, "/"), `[`, 1)) + + tree <- Node$new(root_name) + for (p in paths) { + if (p == root_name) next + tree$AddChild(p) + } + return(tree) +} + # Run after all tests withr::defer(testthat::teardown_env()) diff --git a/tests/testthat/test-hierarchical_utils.R b/tests/testthat/test-hierarchical_utils.R index 905d94b4..de54009b 100644 --- a/tests/testthat/test-hierarchical_utils.R +++ b/tests/testthat/test-hierarchical_utils.R @@ -199,112 +199,180 @@ test_that("max_constraint_output handles mixed positive-negative with constraint expect_equal_to_r(result, expected) }) -# need rework as FromDataFrameNetwork(edges) gives "cannot find root name" error -test_that("build-ancestor-matrix diagonal is always 1 for every class", { - edges <- data.frame(from = c(1L, 2L, 2L), - to = c(2L, 3L, 4L)) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - R_dense <- R$to_dense() +test_that("build_ancestor_matrix handles basic hierarchy", { + # Tree: Root -> A -> C + # Root -> B -> D + # Edges: R->A, A->C, R->B, B->D + # Pruning Logic: + # 1. Remove Root: Keeps A->C, B->D + # 2. Remove leaves (C, D are not in 'from'): Keeps A->C? No. C is not a parent. + # Keeps B->D? No. D is not a parent. + # Result: No edges match criteria. Empty matrix. - expect_equal_to_r(R_dense[1, 1], TRUE) - expect_equal_to_r(R_dense[2, 2], TRUE) - expect_equal_to_r(R_dense[3, 3], TRUE) + paths <- c("Root/A", "Root/A/C", "Root/B", "Root/B/D") + tree <- create_test_tree(paths) + + result <- build_ancestor_matrix(tree) + + # Expectation: No internal nodes exist that are also children (excluding Root) + # A and B are children of Root, but their children (C, D) are leaves. + # Thus A and B are effectively leaves in the "internal structure". + expect_equal(nrow(result), 0) }) -test_that("build-ancestor-matrix: single edge produces correct transitive pair", { - # 1 -> 2 means "2 is ancestor of 1", so transposed: R[2, 1] = 1 - edges <- data.frame(from = c(1L, 2L), to = c(2L, 3L)) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - R_dense <- R$to_dense() +test_that("build_ancestor_matrix handles linear chain of internal nodes", { + # Tree: Root -> A -> B -> C + # Edges: R->A, A->B, B->C + # Pruning Logic: + # 1. Remove Root: Keeps A->B, B->C + # 2. Keep only if target is a parent: + # - A->B: B is a parent (of C). Keep. + # - B->C: C is a leaf. Drop. + # Remaining Edges: A -> B + # Nodes: A(1), B(2) + # Matrix: A->A, A->B, B->B + + paths <- c("Root/A", "Root/A/B", "Root/A/B/C") + tree <- create_test_tree(paths) - # 2 is descendant of 2 (self) - expect_equal_to_r(R_dense[2, 2], TRUE) - # 1 is descendant of 1 (self) - expect_equal_to_r(R_dense[1, 1], TRUE) - # 1 is descendant of 2 (because 1 -> 2) - expect_equal_to_r(R_dense[2, 1], TRUE) - # 2 is NOT descendant of 1 - expect_equal_to_r(R_dense[1, 2], FALSE) + result <- build_ancestor_matrix(tree) + + expected <- matrix(c( + 1, 1, # A -> A + 1, 2, # A -> B + 2, 2 # B -> B + ), ncol = 2, byrow = TRUE) + + expect_equal(result, expected) }) -test_that("build-ancestor-matrix: multi-hop ancestor chain is fully resolved", { - # Chain: 2 -> 3 -> 4 -> 5 (each is ancestor of the previous) - # After transpose: 4 is descendant of 1, 2, 3, 4 - # 3 is descendant of 1, 2, 3 - # 2 is descendant of 1, 2 - # 1 is descendant of 1 - edges <- data.frame( - from = c(1L, 2L, 3L, 4L), - to = c(2L, 3L, 4L, 5L) - ) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - R_dense <- R$to_dense() +test_that("build_ancestor_matrix calculates transitive closure correctly", { + # Tree: Root -> A -> B -> C -> D + # Edges: R->A, A->B, B->C, C->D + # Pruning Logic: + # 1. Remove Root: A->B, B->C, C->D + # 2. Keep if target is parent: + # - A->B: B is parent (of C). Keep. + # - B->C: C is parent (of D). Keep. + # - C->D: D is leaf. Drop. + # Remaining Edges: A -> B, B -> C + # Nodes: A(1), B(2), C(3) - # Row 1: only node 1 is its own descendant - expect_equal_to_r(R_dense, lower.tri(diag(4), diag = TRUE)) + paths <- c("Root/A", "Root/A/B", "Root/A/B/C", "Root/A/B/C/D") + tree <- create_test_tree(paths) + + result <- build_ancestor_matrix(tree) + + # Expected Relations: + # A -> A, A -> B, A -> C + # B -> B, B -> C + # C -> C + + # Sorted by column then row (default behavior of which(arr.ind=TRUE)) + expected <- matrix(c( + 1, 1, # A->A + 1, 2, # A->B + 2, 2, # B->B + 1, 3, # A->C (transitive) + 2, 3, # B->C + 3, 3 # C->C + ), ncol = 2, byrow = TRUE) + + expect_equal(result, expected) }) -test_that("build-ancestor-matrix: diamond hierarchy merges both paths", { - # Diamond: 1 -> 2 -> 4, 1 -> 3 -> 4 - # After transpose: 4 is descendant of all; 2 and 3 are descendants of - # 1 and themselves only - edges <- data.frame( - from = c(1L, 1L, 2L, 3L), - to = c(2L, 3L, 4L, 4L) - ) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - R_dense <- R$to_dense() +test_that("build_ancestor_matrix handles branching internal nodes", { + # Tree: R -> A -> C + # R -> B -> C (Diamond shape, merging back to C) + # *Note: data.tree allows this structure (multiple parents)? + # Actually standard trees are single parent. Let's stick to standard tree. + + # Tree: R -> A -> C -> E + # R -> B -> D -> E + # Edges: R->A, A->C, C->E, R->B, B->D, D->E + # Pruning: + # 1. Remove R: A->C, C->E, B->D, D->E + # 2. Keep target if parent: + # - A->C (C is parent of E). Keep. + # - C->E (E is leaf). Drop. + # - B->D (D is parent of E). Keep. + # - D->E (E is leaf). Drop. + # Nodes: A, C, B, D + # Edges: A->C, B->D - expect_equal_to_r(R_dense[3, 1], TRUE) - expect_equal_to_r(R_dense[4, 2], TRUE) - expect_equal_to_r(R_dense[4, 3], FALSE) - expect_equal_to_r(R_dense[2, 4], FALSE) + paths <- c("Root/A", "Root/A/C", "Root/A/C/E", + "Root/B", "Root/B/D", "Root/B/D/E") + tree <- create_test_tree(paths) + + result <- build_ancestor_matrix(tree) + + # We have two disconnected components in the adjacency matrix: (A,C) and (B,D) + # A(1), C(2), B(3), D(4) (Order depends on unique(c(edges$from, edges$to))) + # Edges order: A->C, B->D. + # Unique nodes: A, C, B, D. + + # Expected: Self loops + A->C, B->D + # (1,1), (1,2), (2,2), (3,3), (3,4), (4,4) + + expected <- matrix(c( + 1, 1, # A->A + 1, 2, # A->C + 2, 2, # C->C + 3, 3, # B->B + 3, 4, # B->D + 4, 4 # D->D + ), ncol = 2, byrow = TRUE) + + expect_equal(result, expected) }) -# test_that("build-ancestor-matrix: isolated nodes have only a diagonal entry", { -# edges <- data.frame(from = c(1L, 1L), -# to = c(2L, 1L)) -# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) -# R_dense <- R$to_dense() -# -# # Nodes 3, 4, 5 have no edges -# expect_equal_to_r(R_dense[3, 3], TRUE) -# expect_equal_to_r(R_dense[3, ], c(FALSE, FALSE, TRUE, FALSE, FALSE)) -# expect_equal_to_r(R_dense[4, 4], TRUE) -# expect_equal_to_r(R_dense[5, 5], TRUE) -# }) -# -# test_that("build-ancestor-matrix: n_classes defaults to max node id when NULL", { -# edges <- data.frame(from = c(1L, 1L), to = c(5L, 1L)) -# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) -# -# # n_classes should be max(1, 5, TRUE) = 5 -# expect_tensor_shape(R, c(5, 5)) -# }) +test_that("build_ancestor_matrix returns empty for Root-only tree", { + tree <- Node$new("Root") + result <- build_ancestor_matrix(tree) + expect_equal(nrow(result), 0) +}) -# test_that("build-ancestor-matrix: output has correct shape and dtype", { -# edges <- data.frame(from = c(1L, 2L), to = c(2L, 1L)) -# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) -# -# expect_tensor_shape(R, c(3L, 3L)) -# expect_tensor_dtype(R, torch::torch_bool()) -# expect_true(R$is_sparse()) -# }) -# -test_that("build-ancestor-matrix: output uses 0-based indices internally", { - # Verify that torch sees correct values when converted to dense - edges <- data.frame(from = c(1L, 2L, 1L), to = c(2L, 3L, 3L)) - R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) - expect_equal_to_r(R$to_dense(), matrix(c(TRUE, TRUE, FALSE, TRUE), nrow=2)) +test_that("build_ancestor_matrix returns empty for Root + Leaf", { + # Tree: Root -> A + # Edges: R->A + # 1. Remove R (from!=Root): Result empty. + tree <- Node$new("Root") + tree$AddChild("A") + result <- build_ancestor_matrix(tree) + expect_equal(nrow(result), 0) }) -# test_that("build-ancestor-matrix: single-node graph produces identity-like matrix", { -# edges <- data.frame(from = 1L, to = 1L) -# R <- build_ancestor_matrix(FromDataFrameNetwork(mutate_all(edges, as.character))) -# expect_tensor_shape(R$to_dense(), c(1L, 1L)) -# expect_equal_to_r(R$to_dense()[1, 1], TRUE) -# }) +test_that("build_ancestor_matrix handles deep wide tree (Stress Test)", { + # Create a binary tree of depth 4 + tree <- Node$new("R") + add_children <- function(node, depth) { + if (depth == 0) return() + node$AddChild(paste0(node.name, "L")) + node$AddChild(paste0(node.name, "R")) + add_children(node$children[[1]], depth - 1) + add_children(node$children[[2]], depth - 1) + } + add_children(tree, 4) + + result <- build_ancestor_matrix(tree) + + # Validate structure without checking exact numbers (too complex for hardcoded) + # 1. Must be integer matrix + expect_type(result, "integer") + # 2. Must have 2 columns + expect_equal(ncol(result), 2) + # 3. First column (Ancestor) <= Second column (Descendant) implies topological sort check? + # Actually indices are arbitrary based on sorting, but relationships are directional. + # Just ensure no NA or Inf + expect_true(!any(is.na(result))) +}) +test_that("build_ancestor_matrix preserves integer type", { + paths <- c("Root/A", "Root/A/B") + tree <- create_test_tree(paths) + result <- build_ancestor_matrix(tree) + expect_type(result, "integer") +}) test_that("node_to_df works ", { expect_no_error( node_to_df(acme) From 13cd533fcab691ecd590fab7ea3d01b20daeef11 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sun, 17 May 2026 22:03:22 +0200 Subject: [PATCH 10/21] fix get_construct_outp() refactor build_ancestor_matrix() for performance --- R/hardhat.R | 134 ++++++++++----- R/model_training.R | 2 +- tests/testthat/setup.R | 15 -- tests/testthat/test-hierarchical_utils.R | 199 ++++++++++------------- 4 files changed, 179 insertions(+), 171 deletions(-) diff --git a/R/hardhat.R b/R/hardhat.R index 5cdaf4b9..f7ecf720 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -620,57 +620,105 @@ nn_prune_head.tabnet_pretrain <- function(x, head_size) { #' @importFrom torch torch_ones torch_int64 torch_sparse_coo_tensor #' @noRd build_ancestor_matrix <- function(x) { - # 1. Extract edges - edges <- data.tree::ToDataFrameNetwork(x) - # 2. prune tree from root and from leafs - non_root_edges <- edges$from != x$path - non_leaf_targets <- edges$to %in% unique(edges$from) + # 1. Get all nodes + all_nodes <- data.tree::Traverse(x, traversal = "pre-order") + all_nodes <- unname(all_nodes) + n_classes <- length(all_nodes) - edges <- edges[non_root_edges & non_leaf_targets, ] - - # 3. Map node names to integer indices - all_nodes <- unique(c(edges$from, edges$to)) - n <- length(all_nodes) - # Handle case where no edges match the filter - if (n == 0) { - return(matrix(nrow = 0, ncol = 2)) + if (n_classes == 0) { + return(torch::torch_sparse_coo_tensor( + torch::torch_int64()$view(c(2L, 0L)), + torch::torch_logical()$view(0L), + c(0L, 0L) + )) } - # Create a lookup map: name -> index - node_map <- setNames(seq_along(all_nodes), all_nodes) - - # Conversion of edges to integer indices - from_idx <- node_map[edges$from] - to_idx <- node_map[edges$to] + # 2. Create mapping + node_names <- vapply(all_nodes, function(node) node$name, character(1)) + node_map <- setNames(seq_len(n_classes), node_names) - # 4. Build Adjacency Matrix - # adj_mat[i, j] = 1 means i is a direct parent of j - adj_mat <- matrix(0L, nrow = n, ncol = n) - adj_mat[cbind(from_idx, to_idx)] <- 1L + # 3. Pre-allocate lists for efficiency + row_list <- vector("list", n_classes) + col_list <- vector("list", n_classes) - # 5. Compute Transitive Closure (Ancestors) - # Initialize reachability matrix with self-loops (Identity) + direct connections - reachability <- adj_mat + diag(n) - - # Use Boolean Matrix Multiplication to find all reachable nodes - # (i, j) = 1 if j is reachable from i (i is ancestor of j) - repeat { - # reachability %*% reachability finds paths of length 2*k - # Multiplying the matrix by itself effectively extends the reachable frontier - next_reachability <- (reachability %*% reachability) > 0 + for (i in seq_along(all_nodes)) { + node <- all_nodes[[i]] + ancestor_idx <- node_map[[node$name]] - # Check for convergence - if (identical(next_reachability, reachability)) { - break - } + # Get descendants using data.tree Traverse + descendants <- data.tree::Traverse(node, traversal = "pre-order") + descendant_names <- vapply(descendants, function(n) n$name, character(1)) + descendant_indices <- node_map[descendant_names] - # Convert back to integer/numeric for next iteration - reachability <- next_reachability * 1L + row_list[[i]] <- rep(ancestor_idx, length(descendant_indices)) + col_list[[i]] <- descendant_indices } - # 6. Extract indices (COO format) - # which(arr.ind = TRUE) returns a matrix where col 1 is row (Ancestor) and col 2 is column (Descendant) - idx_mat <- which(reachability == 1L, arr.ind = TRUE) + # 4. Combine all at once + rows <- unlist(row_list, use.names = FALSE) + cols <- unlist(col_list, use.names = FALSE) - torch::torch_sparse_coo_tensor(t(idx_mat), rep(TRUE, nrow(idx_mat)), c(n_classes, n_classes)) + # 5. Create sparse tensor + torch::torch_sparse_coo_tensor( + rbind(rows, cols), + rep(TRUE, length(rows)), + c(n_classes, n_classes) + ) } + + +# build_ancestor_matrix_slow <- function(x) { +# # 1. Extract edges +# edges <- data.tree::ToDataFrameNetwork(x) +# # 2. prune tree from root and from leafs +# non_root_edges <- edges$from != x$path +# non_leaf_targets <- edges$to %in% unique(edges$from) +# +# edges <- edges[non_root_edges & non_leaf_targets, ] +# +# # 3. Map node names to integer indices +# all_nodes <- unique(c(edges$from, edges$to)) +# n <- length(all_nodes) +# # Handle case where no edges match the filter +# if (n == 0) { +# return(matrix(nrow = 0, ncol = 2)) +# } +# +# # Create a lookup map: name -> index +# node_map <- setNames(seq_along(all_nodes), all_nodes) +# +# # Conversion of edges to integer indices +# from_idx <- node_map[edges$from] +# to_idx <- node_map[edges$to] +# +# # 4. Build Adjacency Matrix +# # adj_mat[i, j] = 1 means i is a direct parent of j +# adj_mat <- matrix(0L, nrow = n, ncol = n) +# adj_mat[cbind(from_idx, to_idx)] <- 1L +# +# # 5. Compute Transitive Closure (Ancestors) +# # Initialize reachability matrix with self-loops (Identity) + direct connections +# reachability <- adj_mat + diag(n) +# +# # Use Boolean Matrix Multiplication to find all reachable nodes +# # (i, j) = 1 if j is reachable from i (i is ancestor of j) +# repeat { +# # reachability %*% reachability finds paths of length 2*k +# # Multiplying the matrix by itself effectively extends the reachable frontier +# next_reachability <- (reachability %*% reachability) > 0 +# +# # Check for convergence +# if (identical(next_reachability, reachability)) { +# break +# } +# +# # Convert back to integer/numeric for next iteration +# reachability <- next_reachability * 1L +# } +# +# # 6. Extract indices (COO format) +# # which(arr.ind = TRUE) returns a matrix where col 1 is row (Ancestor) and col 2 is column (Descendant) +# idx_mat <- which(reachability == 1L, arr.ind = TRUE) +# +# torch::torch_sparse_coo_tensor(t(idx_mat), rep(TRUE, nrow(idx_mat)), c(n_classes, n_classes)) +# } diff --git a/R/model_training.R b/R/model_training.R index f5fe82dd..f0ff8b0d 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -230,7 +230,7 @@ tabnet_config <- function(batch_size = 1024^2, get_constr_output <- function(x, R) { # MCM of the prediction given the hierarchy constraint expressed in the matrix R """ c_out <- x$to(dtype = torch::torch_double())$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) - R_batch <- R$unsqueeze(1)$expand(c(x$shape[1], R$shape[2], R$shape[2])) + R_batch <- R$expand(c(x$shape[1], R$shape[2], R$shape[2])) final_out <- torch::torch_max(R_batch * c_out, dim = 3) final_out[[1]] } diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index abb33507..74c72ae9 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -47,20 +47,5 @@ attrition_tree <- attrition %>% select(-Department, -JobRole, -rowid) %>% data.tree::as.Node() -# --- Helper function to create test trees easily --- -create_test_tree <- function(structure) { - # structure: list of path strings or a nested list - # Simple parser for "Root/A/B" style paths - paths <- structure - root_name <- unique(sapply(strsplit(paths, "/"), `[`, 1)) - - tree <- Node$new(root_name) - for (p in paths) { - if (p == root_name) next - tree$AddChild(p) - } - return(tree) -} - # Run after all tests withr::defer(testthat::teardown_env()) diff --git a/tests/testthat/test-hierarchical_utils.R b/tests/testthat/test-hierarchical_utils.R index de54009b..e6ec5c30 100644 --- a/tests/testthat/test-hierarchical_utils.R +++ b/tests/testthat/test-hierarchical_utils.R @@ -1,15 +1,19 @@ test_that("get_constr_output handles basic 2D input with identity constraint", { - x <- torch_tensor(matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2), dtype = torch_float32()) + m <- matrix(c(1, 2, + 3, 4), nrow = 2, ncol = 2) + x <- torch_tensor(m, dtype = torch_float32()) R <- torch_eye(2, dtype = torch_float32()) result <- get_constr_output(x, R) expect_tensor(result) expect_tensor_shape(result, c(2, 2)) - expect_equal_to_r(result, matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2)) + expect_equal_to_r(result, m) }) test_that("get_constr_output applies hierarchy constraint correctly", { - x <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) - R <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) + x <- torch_tensor(matrix(c(1, 5, + 3, 2), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) + R <- torch_tensor(matrix(c(1, 1, + 0, 1), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) result <- get_constr_output(x, R) expect_tensor_shape(result, c(2, 2)) expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) @@ -26,7 +30,10 @@ test_that("get_constr_output preserves input dtype", { test_that("get_constr_output handles batch dimension correctly", { x <- torch_tensor(matrix(1:12, nrow = 3, ncol = 4)) - R <- torch_tensor(matrix(c(1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) + R <- torch_tensor(matrix(c(1, 1, 0, 0, + 1, 1, 0, 0, + 0, 0, 1, 1, + 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) result <- get_constr_output(x, R) expect_tensor_shape(result, c(3, 4)) @@ -41,7 +48,10 @@ test_that("get_constr_output handles batch dimension correctly", { }) test_that("get_constr_output works with single sample", { x <- torch_tensor(matrix(c(2, 1, 4, 3), nrow = 1, ncol = 4, byrow = TRUE)) - R <- torch_tensor(matrix(c(1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) + R <- torch_tensor(matrix(c(1, 1, 0, 0, + 1, 1, 0, 0, + 0, 0, 1, 1, + 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) result <- get_constr_output(x, R) expect_tensor_shape(result, c(1, 4)) expected <- matrix(c(2, 2, 4, 4), nrow = 1, byrow = TRUE) @@ -57,12 +67,14 @@ test_that("get_constr_output handles all-zeros constraint matrix", { }) test_that("get_constr_output handles all-ones constraint matrix", { - x <- torch_tensor(matrix(c(1, 5, 3, 2, 4, 6), nrow = 2, ncol = 3, byrow = TRUE)) + x <- torch_tensor(matrix(c(1, 5, 3, + 2, 4, 6), nrow = 2, ncol = 3, byrow = TRUE)) R <- torch_ones(c(3, 3)) result <- get_constr_output(x, R) expect_tensor_shape(result, c(2, 3)) # Each row is filled with its own row-wise maximum - expected <- matrix(c(5, 5, 5, 6, 6, 6), nrow = 2, ncol = 3, byrow = TRUE) + expected <- matrix(c(5, 5, 5, + 6, 6, 6), nrow = 2, ncol = 3, byrow = TRUE) expect_equal_to_r(result, expected, tolerance = 1e-6) }) @@ -74,13 +86,14 @@ test_that("get_constr_output throws error for dimension mismatch", { test_that("get_constr_output throws error for non-2D R", { x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - R <- torch_tensor(array(1:8, dim = c(2, 2, 2))) + R <- torch_tensor(array(1:8, dim = c(1, 2, 2, 2))) expect_error(get_constr_output(x, R), "dimension") }) test_that("max_constraint_output returns original output when ancestor is identity", { output <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) - labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, FALSE, TRUE, FALSE), nrow = 2, ncol = 3), dtype = torch_bool()) + labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, + FALSE, TRUE, FALSE), nrow = 2, ncol = 3), dtype = torch_bool()) ancestor <- torch_eye(3) result <- max_constraint_output(output, labels, ancestor) expect_tensor_shape(result, c(2, 3)) @@ -90,9 +103,12 @@ test_that("max_constraint_output returns original output when ancestor is identi }) test_that("max_constraint_output applies constraint to positive labels", { - output <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(1, 0, 1, 0), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + output <- torch_tensor(matrix(c(1, 5, + 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(1, 0, + 1, 0), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, + 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) result <- max_constraint_output(output, labels, ancestor) expect_tensor_shape(result, c(2, 2)) # Unlabelled positions get propagated raw max, labelled get propagated masked max @@ -110,7 +126,8 @@ test_that("max_constraint_output handles all-zero labels", { }) test_that("max_constraint_output handles all-one labels", { - output <- torch_tensor(matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) + output <- torch_tensor(matrix(c(1, 5, + 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) labels <- torch_ones(c(2, 2), dtype = torch_bool()) ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) result <- max_constraint_output(output, labels, ancestor) @@ -131,8 +148,10 @@ test_that("max_constraint_output preserves output dtype", { test_that("max_constraint_output works with complex hierarchy", { - output <- torch_tensor(matrix(c(1, 2, 3, 4, 5, 6), nrow = 2, ncol = 3, byrow = TRUE)) - labels <- torch_tensor(matrix(c(1, 0, 0, 0, 1, 0), nrow = 2, ncol = 3, byrow = TRUE), dtype = torch_bool()) + output <- torch_tensor(matrix(c(1, 2, 3, + 4, 5, 6), nrow = 2, ncol = 3, byrow = TRUE)) + labels <- torch_tensor(matrix(c(1, 0, 0, + 0, 1, 0), nrow = 2, ncol = 3, byrow = TRUE), dtype = torch_bool()) ancestor <- torch_triu(torch_ones(c(3,3))) result <- max_constraint_output(output, labels, ancestor) expect_tensor_shape(result, c(2, 3)) @@ -172,9 +191,12 @@ test_that("max_constraint_output handles float labels without error", { }) test_that("get_constr_output and max_constraint_output compose correctly", { - output <- torch_tensor(matrix(c(1, 4, 2, 3), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, FALSE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + output <- torch_tensor(matrix(c(1, 4, + 2, 3), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(TRUE, FALSE, + TRUE, FALSE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, + 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) direct <- max_constraint_output(output, labels, ancestor) constr_out <- get_constr_output(output, ancestor) train_out <- get_constr_output(labels * output, ancestor) @@ -183,19 +205,26 @@ test_that("get_constr_output and max_constraint_output compose correctly", { }) test_that("get_constr_output handles negative values correctly", { - x <- torch_tensor(matrix(c(-5, -1, -3, -2), nrow = 2, ncol = 2, byrow = TRUE)) - R <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + x <- torch_tensor(matrix(c(-5, -1, + -3, -2), nrow = 2, ncol = 2, byrow = TRUE)) + R <- torch_tensor(matrix(c(1, 1, + 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) result <- get_constr_output(x, R) - expected <- matrix(c(-1, 0, -2, 0), nrow = 2, ncol = 2, byrow = TRUE) + expected <- matrix(c(-1, 0, + -2, 0), nrow = 2, ncol = 2, byrow = TRUE) expect_equal_to_r(result, expected) }) test_that("max_constraint_output handles mixed positive-negative with constraints", { - output <- torch_tensor(matrix(c(-5, -3, -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(TRUE, TRUE, FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + output <- torch_tensor(matrix(c(-5, -3, + -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) + labels <- torch_tensor(matrix(c(TRUE, TRUE, + FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) + ancestor <- torch_tensor(matrix(c(1, 1, + 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) result <- max_constraint_output(output, labels, ancestor) - expected <- matrix(c(-3, 0, 4, 4), nrow = 2, ncol = 2, byrow = TRUE) + expected <- matrix(c(-3, 0, + 4, 4), nrow = 2, ncol = 2, byrow = TRUE) expect_equal_to_r(result, expected) }) @@ -209,15 +238,15 @@ test_that("build_ancestor_matrix handles basic hierarchy", { # Keeps B->D? No. D is not a parent. # Result: No edges match criteria. Empty matrix. - paths <- c("Root/A", "Root/A/C", "Root/B", "Root/B/D") - tree <- create_test_tree(paths) + tree_df <- data.frame(pathString = c("Root/A", "Root/A/C", "Root/B", "Root/B/D")) + tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree) + result <- build_ancestor_matrix(tree)$to_dense() # Expectation: No internal nodes exist that are also children (excluding Root) # A and B are children of Root, but their children (C, D) are leaves. # Thus A and B are effectively leaves in the "internal structure". - expect_equal(nrow(result), 0) + expect_tensor_shape(result, c(5,5)) }) test_that("build_ancestor_matrix handles linear chain of internal nodes", { @@ -232,18 +261,13 @@ test_that("build_ancestor_matrix handles linear chain of internal nodes", { # Nodes: A(1), B(2) # Matrix: A->A, A->B, B->B - paths <- c("Root/A", "Root/A/B", "Root/A/B/C") - tree <- create_test_tree(paths) - - result <- build_ancestor_matrix(tree) - - expected <- matrix(c( - 1, 1, # A -> A - 1, 2, # A -> B - 2, 2 # B -> B - ), ncol = 2, byrow = TRUE) + tree_df <- data.frame(pathString = c("Root/A", "Root/A/B", "Root/A/B/C"), value = 1:3) + tree <- as.Node(tree_df) - expect_equal(result, expected) + result <- build_ancestor_matrix(tree)$to_dense()$to(torch_long()) + + expected <- fBasics::Triang(matrix(TRUE, nrow = 4, ncol = 4)) # upper triangular 4 x 4 mat + expect_equal_to_r(result, expected) }) test_that("build_ancestor_matrix calculates transitive closure correctly", { @@ -258,27 +282,13 @@ test_that("build_ancestor_matrix calculates transitive closure correctly", { # Remaining Edges: A -> B, B -> C # Nodes: A(1), B(2), C(3) - paths <- c("Root/A", "Root/A/B", "Root/A/B/C", "Root/A/B/C/D") - tree <- create_test_tree(paths) - - result <- build_ancestor_matrix(tree) - - # Expected Relations: - # A -> A, A -> B, A -> C - # B -> B, B -> C - # C -> C + tree_df <- data.frame(pathString = c("Root/A", "Root/A/B", "Root/A/B/C", "Root/A/B/C/D")) + tree <- as.Node(tree_df) - # Sorted by column then row (default behavior of which(arr.ind=TRUE)) - expected <- matrix(c( - 1, 1, # A->A - 1, 2, # A->B - 2, 2, # B->B - 1, 3, # A->C (transitive) - 2, 3, # B->C - 3, 3 # C->C - ), ncol = 2, byrow = TRUE) + result <- build_ancestor_matrix(tree)$to_dense()$to(torch_long()) - expect_equal(result, expected) + expected <- fBasics::Triang(matrix(TRUE, nrow = 5, ncol = 5)) # upper triangular 5 x 5 mat + expect_equal_to_r(result, expected) }) test_that("build_ancestor_matrix handles branching internal nodes", { @@ -300,36 +310,25 @@ test_that("build_ancestor_matrix handles branching internal nodes", { # Nodes: A, C, B, D # Edges: A->C, B->D - paths <- c("Root/A", "Root/A/C", "Root/A/C/E", - "Root/B", "Root/B/D", "Root/B/D/E") - tree <- create_test_tree(paths) + tree_df <- data.frame(pathString = c("Root/A", "Root/A/C", "Root/A/C/E", + "Root/B", "Root/B/D", "Root/B/D/E")) + tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree) - - # We have two disconnected components in the adjacency matrix: (A,C) and (B,D) - # A(1), C(2), B(3), D(4) (Order depends on unique(c(edges$from, edges$to))) - # Edges order: A->C, B->D. - # Unique nodes: A, C, B, D. - - # Expected: Self loops + A->C, B->D - # (1,1), (1,2), (2,2), (3,3), (3,4), (4,4) + result <- build_ancestor_matrix(tree)$to_dense()$to(torch_long()) - expected <- matrix(c( - 1, 1, # A->A - 1, 2, # A->C - 2, 2, # C->C - 3, 3, # B->B - 3, 4, # B->D - 4, 4 # D->D - ), ncol = 2, byrow = TRUE) + # upper triangular 6 x 6 mat in a 7 x 7 matrix with few non-ancestor values + expected <- fBasics::Triang(matrix(1, nrow = 7, ncol = 7)) + expected[, 7] <- 0 + expected[2:4, 5:6] <- 0 + expected[5:6, 4] <- 1 - expect_equal(result, expected) + expect_equal_to_r(result, expected) }) test_that("build_ancestor_matrix returns empty for Root-only tree", { tree <- Node$new("Root") - result <- build_ancestor_matrix(tree) - expect_equal(nrow(result), 0) + result <- build_ancestor_matrix(tree)$to_dense() + expect_equal(nrow(result), 1) }) test_that("build_ancestor_matrix returns empty for Root + Leaf", { @@ -339,40 +338,16 @@ test_that("build_ancestor_matrix returns empty for Root + Leaf", { tree <- Node$new("Root") tree$AddChild("A") result <- build_ancestor_matrix(tree) - expect_equal(nrow(result), 0) -}) - -test_that("build_ancestor_matrix handles deep wide tree (Stress Test)", { - # Create a binary tree of depth 4 - tree <- Node$new("R") - add_children <- function(node, depth) { - if (depth == 0) return() - node$AddChild(paste0(node.name, "L")) - node$AddChild(paste0(node.name, "R")) - add_children(node$children[[1]], depth - 1) - add_children(node$children[[2]], depth - 1) - } - add_children(tree, 4) - - result <- build_ancestor_matrix(tree) - - # Validate structure without checking exact numbers (too complex for hardcoded) - # 1. Must be integer matrix - expect_type(result, "integer") - # 2. Must have 2 columns - expect_equal(ncol(result), 2) - # 3. First column (Ancestor) <= Second column (Descendant) implies topological sort check? - # Actually indices are arbitrary based on sorting, but relationships are directional. - # Just ensure no NA or Inf - expect_true(!any(is.na(result))) + expect_equal(nrow(result), 2) }) test_that("build_ancestor_matrix preserves integer type", { - paths <- c("Root/A", "Root/A/B") - tree <- create_test_tree(paths) + tree_df <- data.frame(pathString = c("Root/A", "Root/A/B")) + tree <- as.Node(tree_df) result <- build_ancestor_matrix(tree) - expect_type(result, "integer") + expect_tensor_dtype(result, torch_bool()) }) + test_that("node_to_df works ", { expect_no_error( node_to_df(acme) From 2302a15891be168c7d9f6d67fcc313df25d354cb Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sun, 17 May 2026 23:31:55 +0200 Subject: [PATCH 11/21] crop ancessor matrix from Root and Leafs --- R/hardhat.R | 119 ++++++++++------------- tests/testthat/test-hierarchical_utils.R | 85 ++++------------ 2 files changed, 69 insertions(+), 135 deletions(-) diff --git a/R/hardhat.R b/R/hardhat.R index f7ecf720..23a2b100 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -163,11 +163,11 @@ tabnet_fit.Node <- function(x, tabnet_model = NULL, config = tabnet_config(), .. xy_df <- node_to_df(x) processed <- hardhat::mold(xy_df$x, xy_df$y) check_type(processed$outcomes) - - ancestor_tt <- build_ancestor_matrix(x) config <- merge_config_and_dots(config, ...) - config$ancestor <- ancestor_tt + # add ancestor boolean sparse matrix to config + config$ancestor <- build_ancestor_matrix(x) + tabnet_bridge(processed, config = config, tabnet_model, from_epoch, task = "supervised") } @@ -620,11 +620,12 @@ nn_prune_head.tabnet_pretrain <- function(x, head_size) { #' @importFrom torch torch_ones torch_int64 torch_sparse_coo_tensor #' @noRd build_ancestor_matrix <- function(x) { - # 1. Get all nodes + # 1. Get all nodes via Traverse all_nodes <- data.tree::Traverse(x, traversal = "pre-order") all_nodes <- unname(all_nodes) n_classes <- length(all_nodes) + # Handle edge case if (n_classes == 0) { return(torch::torch_sparse_coo_tensor( torch::torch_int64()$view(c(2L, 0L)), @@ -633,11 +634,20 @@ build_ancestor_matrix <- function(x) { )) } - # 2. Create mapping + # 2. Create name to index mapping node_names <- vapply(all_nodes, function(node) node$name, character(1)) node_map <- setNames(seq_len(n_classes), node_names) - # 3. Pre-allocate lists for efficiency + # 3. Identify root and leaves + root_node <- all_nodes[[which(vapply(all_nodes, function(n) n$isRoot, logical(1)))[1]]] + root_idx <- node_map[[root_node$name]] + + # Find all leaves + is_leaf <- vapply(all_nodes, function(n) n$isLeaf, logical(1)) + leaf_nodes <- all_nodes[is_leaf] + leaf_indices <- node_map[vapply(leaf_nodes, function(n) n$name, character(1))] + + # 4. Pre-allocate lists row_list <- vector("list", n_classes) col_list <- vector("list", n_classes) @@ -645,80 +655,49 @@ build_ancestor_matrix <- function(x) { node <- all_nodes[[i]] ancestor_idx <- node_map[[node$name]] - # Get descendants using data.tree Traverse + # Skip root node + if (ancestor_idx == root_idx) { + row_list[[i]] <- 0L + col_list[[i]] <- 0L + next + } + + # Get descendants including self descendants <- data.tree::Traverse(node, traversal = "pre-order") descendant_names <- vapply(descendants, function(n) n$name, character(1)) descendant_indices <- node_map[descendant_names] - row_list[[i]] <- rep(ancestor_idx, length(descendant_indices)) - col_list[[i]] <- descendant_indices + # Filter out leaf columns + non_leaf_descendants <- descendant_indices[!descendant_indices %in% leaf_indices] + + row_list[[i]] <- rep(ancestor_idx, length(non_leaf_descendants)) + col_list[[i]] <- non_leaf_descendants } - # 4. Combine all at once + # 5. Combine all at once rows <- unlist(row_list, use.names = FALSE) cols <- unlist(col_list, use.names = FALSE) - # 5. Create sparse tensor + # 6. Re-index to account for removed root row and leaf columns + # Map rows excluding root + valid_rows <- setdiff(seq_len(n_classes), root_idx) + row_remap <- setNames(seq_along(valid_rows), valid_rows) + + # Map cols excluding leaves + valid_cols <- setdiff(seq_len(n_classes), leaf_indices) + col_remap <- setNames(seq_along(valid_cols), valid_cols) + + # Apply remapping + rows_reindexed <- row_remap[as.character(rows)] + cols_reindexed <- col_remap[as.character(cols)] + + # 7. Create sparse tensor with new dimensions: (n_classes - 1) x (n_classes - n_leaves) + nrow <- n_classes - 1L + ncol <- n_classes - length(leaf_indices) + torch::torch_sparse_coo_tensor( - rbind(rows, cols), + rbind(rows_reindexed, cols_reindexed), rep(TRUE, length(rows)), - c(n_classes, n_classes) + c(nrow, ncol) ) } - - -# build_ancestor_matrix_slow <- function(x) { -# # 1. Extract edges -# edges <- data.tree::ToDataFrameNetwork(x) -# # 2. prune tree from root and from leafs -# non_root_edges <- edges$from != x$path -# non_leaf_targets <- edges$to %in% unique(edges$from) -# -# edges <- edges[non_root_edges & non_leaf_targets, ] -# -# # 3. Map node names to integer indices -# all_nodes <- unique(c(edges$from, edges$to)) -# n <- length(all_nodes) -# # Handle case where no edges match the filter -# if (n == 0) { -# return(matrix(nrow = 0, ncol = 2)) -# } -# -# # Create a lookup map: name -> index -# node_map <- setNames(seq_along(all_nodes), all_nodes) -# -# # Conversion of edges to integer indices -# from_idx <- node_map[edges$from] -# to_idx <- node_map[edges$to] -# -# # 4. Build Adjacency Matrix -# # adj_mat[i, j] = 1 means i is a direct parent of j -# adj_mat <- matrix(0L, nrow = n, ncol = n) -# adj_mat[cbind(from_idx, to_idx)] <- 1L -# -# # 5. Compute Transitive Closure (Ancestors) -# # Initialize reachability matrix with self-loops (Identity) + direct connections -# reachability <- adj_mat + diag(n) -# -# # Use Boolean Matrix Multiplication to find all reachable nodes -# # (i, j) = 1 if j is reachable from i (i is ancestor of j) -# repeat { -# # reachability %*% reachability finds paths of length 2*k -# # Multiplying the matrix by itself effectively extends the reachable frontier -# next_reachability <- (reachability %*% reachability) > 0 -# -# # Check for convergence -# if (identical(next_reachability, reachability)) { -# break -# } -# -# # Convert back to integer/numeric for next iteration -# reachability <- next_reachability * 1L -# } -# -# # 6. Extract indices (COO format) -# # which(arr.ind = TRUE) returns a matrix where col 1 is row (Ancestor) and col 2 is column (Descendant) -# idx_mat <- which(reachability == 1L, arr.ind = TRUE) -# -# torch::torch_sparse_coo_tensor(t(idx_mat), rep(TRUE, nrow(idx_mat)), c(n_classes, n_classes)) -# } diff --git a/tests/testthat/test-hierarchical_utils.R b/tests/testthat/test-hierarchical_utils.R index e6ec5c30..e3f4481b 100644 --- a/tests/testthat/test-hierarchical_utils.R +++ b/tests/testthat/test-hierarchical_utils.R @@ -238,7 +238,7 @@ test_that("build_ancestor_matrix handles basic hierarchy", { # Keeps B->D? No. D is not a parent. # Result: No edges match criteria. Empty matrix. - tree_df <- data.frame(pathString = c("Root/A", "Root/A/C", "Root/B", "Root/B/D")) + tree_df <- data.frame(pathString = c("Root/A/C1", "Root/A/C2","Root/B/D1", "Root/B/D2")) tree <- as.Node(tree_df) result <- build_ancestor_matrix(tree)$to_dense() @@ -246,106 +246,61 @@ test_that("build_ancestor_matrix handles basic hierarchy", { # Expectation: No internal nodes exist that are also children (excluding Root) # A and B are children of Root, but their children (C, D) are leaves. # Thus A and B are effectively leaves in the "internal structure". - expect_tensor_shape(result, c(5,5)) + expect_tensor_shape(result, c(6, 3)) }) test_that("build_ancestor_matrix handles linear chain of internal nodes", { - # Tree: Root -> A -> B -> C - # Edges: R->A, A->B, B->C - # Pruning Logic: - # 1. Remove Root: Keeps A->B, B->C - # 2. Keep only if target is a parent: - # - A->B: B is a parent (of C). Keep. - # - B->C: C is a leaf. Drop. - # Remaining Edges: A -> B - # Nodes: A(1), B(2) - # Matrix: A->A, A->B, B->B - - tree_df <- data.frame(pathString = c("Root/A", "Root/A/B", "Root/A/B/C"), value = 1:3) + + tree_df <- data.frame(pathString = c("Root/A/B", "Root/A/B/C"), value = 1:2) tree <- as.Node(tree_df) result <- build_ancestor_matrix(tree)$to_dense()$to(torch_long()) - expected <- fBasics::Triang(matrix(TRUE, nrow = 4, ncol = 4)) # upper triangular 4 x 4 mat + # upper triangular 3 x 3 mat with no diag + expected <- fBasics::Triang(matrix(TRUE, nrow = 3, ncol = 3)) - diag(3) expect_equal_to_r(result, expected) }) test_that("build_ancestor_matrix calculates transitive closure correctly", { - # Tree: Root -> A -> B -> C -> D - # Edges: R->A, A->B, B->C, C->D - # Pruning Logic: - # 1. Remove Root: A->B, B->C, C->D - # 2. Keep if target is parent: - # - A->B: B is parent (of C). Keep. - # - B->C: C is parent (of D). Keep. - # - C->D: D is leaf. Drop. - # Remaining Edges: A -> B, B -> C - # Nodes: A(1), B(2), C(3) - - tree_df <- data.frame(pathString = c("Root/A", "Root/A/B", "Root/A/B/C", "Root/A/B/C/D")) + + tree_df <- data.frame(pathString = c("Root/A/B/C", "Root/A/B/C/D"), value = 1:2) tree <- as.Node(tree_df) result <- build_ancestor_matrix(tree)$to_dense()$to(torch_long()) - expected <- fBasics::Triang(matrix(TRUE, nrow = 5, ncol = 5)) # upper triangular 5 x 5 mat + # upper triangular 4 x 4 mat with no diag + expected <- fBasics::Triang(matrix(TRUE, nrow = 4, ncol = 4)) - diag(4) expect_equal_to_r(result, expected) }) test_that("build_ancestor_matrix handles branching internal nodes", { - # Tree: R -> A -> C - # R -> B -> C (Diamond shape, merging back to C) - # *Note: data.tree allows this structure (multiple parents)? - # Actually standard trees are single parent. Let's stick to standard tree. - - # Tree: R -> A -> C -> E - # R -> B -> D -> E - # Edges: R->A, A->C, C->E, R->B, B->D, D->E - # Pruning: - # 1. Remove R: A->C, C->E, B->D, D->E - # 2. Keep target if parent: - # - A->C (C is parent of E). Keep. - # - C->E (E is leaf). Drop. - # - B->D (D is parent of E). Keep. - # - D->E (E is leaf). Drop. - # Nodes: A, C, B, D - # Edges: A->C, B->D - tree_df <- data.frame(pathString = c("Root/A", "Root/A/C", "Root/A/C/E", - "Root/B", "Root/B/D", "Root/B/D/E")) + tree_df <- data.frame(pathString = c("Root/A/C/E1", "Root/A/C/E2", "Root/B/D/E1", "Root/B/D/E3")) tree <- as.Node(tree_df) result <- build_ancestor_matrix(tree)$to_dense()$to(torch_long()) - # upper triangular 6 x 6 mat in a 7 x 7 matrix with few non-ancestor values - expected <- fBasics::Triang(matrix(1, nrow = 7, ncol = 7)) - expected[, 7] <- 0 - expected[2:4, 5:6] <- 0 - expected[5:6, 4] <- 1 + # two small upper triangular 2 x 2 mat in a 5 x 8 matrix + expected <- matrix(0L, nrow = 8, ncol = 5) + expected[1:2, 2:3] <- fBasics::Triang(matrix(1L, nrow = 2, ncol = 2)) + expected[5:6, 4:5] <- fBasics::Triang(matrix(1L, nrow = 2, ncol = 2)) + expect_equal_to_r(result, expected) }) test_that("build_ancestor_matrix returns empty for Root-only tree", { tree <- Node$new("Root") - result <- build_ancestor_matrix(tree)$to_dense() - expect_equal(nrow(result), 1) + result <- build_ancestor_matrix(tree) + expect_equal(result$shape, c(0,0)) }) test_that("build_ancestor_matrix returns empty for Root + Leaf", { - # Tree: Root -> A - # Edges: R->A - # 1. Remove R (from!=Root): Result empty. - tree <- Node$new("Root") - tree$AddChild("A") - result <- build_ancestor_matrix(tree) - expect_equal(nrow(result), 2) -}) -test_that("build_ancestor_matrix preserves integer type", { - tree_df <- data.frame(pathString = c("Root/A", "Root/A/B")) + tree_df <- data.frame(pathString = c("Root/A", "Root/B")) tree <- as.Node(tree_df) result <- build_ancestor_matrix(tree) - expect_tensor_dtype(result, torch_bool()) + expect_equal(result$shape, c(2,1)) }) test_that("node_to_df works ", { From b00cde4d93157d84fb837ed203e5478a48b5ef49 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Mon, 18 May 2026 23:32:55 +0200 Subject: [PATCH 12/21] rework on `build_ancestor_matrix()` to provide a squared output --- .gitignore | 1 + R/hardhat.R | 149 ++++++++++------------- R/model_training.R | 6 +- tests/testthat/test-hierarchical_utils.R | 54 ++++---- 4 files changed, 92 insertions(+), 118 deletions(-) diff --git a/.gitignore b/.gitignore index 985fdf11..16879333 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ tabnet.Rproj po/glossary.csv inst/IMPORTLIST .positai +tools diff --git a/R/hardhat.R b/R/hardhat.R index 23a2b100..e7810b47 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -601,103 +601,88 @@ nn_prune_head.tabnet_pretrain <- function(x, head_size) { } -#' Build a sparse ancestor-descendant matrix from a hierarchy edge list -#' -#' Given a directed graph where edges point from descendant to ancestor, -#' computes the full transitive closure via BFS, then transposes so that -#' the resulting sparse matrix R satisfies R\[i, j\] = 1 whenever class j -#' is a descendant of class i (including i itself). This is the -#' orientation expected by \code{get_constr_output} and the -#' max-constraint-margin (MCM) loss. -#' -#' @param x a Node object. -#' @return A \code{torch_sparse_coo_tensor} of shape -#' \code{(n_classes, n_classes)} and dtype \code{torch_double()}. -#' Entry \code{R[i, j] = 1} means class \code{j} is a descendant of -#' class \code{i}. Indices follow torch's 0-based convention. -#' -#' -#' @importFrom torch torch_ones torch_int64 torch_sparse_coo_tensor -#' @noRd -build_ancestor_matrix <- function(x) { - # 1. Get all nodes via Traverse - all_nodes <- data.tree::Traverse(x, traversal = "pre-order") - all_nodes <- unname(all_nodes) - n_classes <- length(all_nodes) +#' Build ancestor-descendant matrix for class hierarchy from data.tree Node +#' +#' Extracts class nodes (non-root, non-leaf) from a hierarchical tree where +#' leaves contain observations and intermediate nodes represent class categories. +#' Computes the transitive closure: R[i, j] = 1 if class i is a descendant +#' of class j (including self-loops). Matches the output orientation of the +#' provided Python/NetworkX snippet. +#' +#' @param x A `data.tree::Node` object representing the hierarchy. +#' Leaves should contain individual observations; intermediate nodes +#' represent class categories (e.g., Department, JobRole). +#' @param device Target device for the output tensor (e.g., "cpu", "cuda"). +#' @return A `torch_tensor` of shape `(1, n_classes, n_classes)` with dtype +#' `torch_double`, where `R[i, j] <- 1` if class `i` is a descendant of +#' class `j` (including when `i == j`). +#' @importFrom torch torch_tensor torch_double +#' @export +build_ancestor_matrix <- function(x, device = "cpu") { + # 1. Extract CLASS nodes using data.tree's filtering to exclude root and leaves + class_nodes <- data.tree::Traverse( + x, + traversal = "pre-order", + filterFun = function(node) !node$isRoot & !node$isLeaf + ) + class_nodes <- unname(class_nodes) + n_classes <- length(class_nodes) - # Handle edge case - if (n_classes == 0) { - return(torch::torch_sparse_coo_tensor( - torch::torch_int64()$view(c(2L, 0L)), - torch::torch_logical()$view(0L), - c(0L, 0L) + # Handle edge case: no class nodes found + if (n_classes == 0L) { + return(torch::torch_zeros( + 1L, 0L, 0L, + dtype = torch::torch_double(), + device = device )) } - # 2. Create name to index mapping - node_names <- vapply(all_nodes, function(node) node$name, character(1)) - node_map <- setNames(seq_len(n_classes), node_names) - - # 3. Identify root and leaves - root_node <- all_nodes[[which(vapply(all_nodes, function(n) n$isRoot, logical(1)))[1]]] - root_idx <- node_map[[root_node$name]] - - # Find all leaves - is_leaf <- vapply(all_nodes, function(n) n$isLeaf, logical(1)) - leaf_nodes <- all_nodes[is_leaf] - leaf_indices <- node_map[vapply(leaf_nodes, function(n) n$name, character(1))] + # 2. Create 1-based index mapping + O(1) named lookup for class names + class_names <- vapply(class_nodes, `[[`, "name", FUN.VALUE = character(1)) + class_map <- setNames(seq_len(n_classes), class_names) - # 4. Pre-allocate lists + # 3. Collect (descendant, ancestor) index pairs via tree climbing row_list <- vector("list", n_classes) col_list <- vector("list", n_classes) - for (i in seq_along(all_nodes)) { - node <- all_nodes[[i]] - ancestor_idx <- node_map[[node$name]] + for (i in seq_len(n_classes)) { + node <- class_nodes[[i]] + desc_idx <- i - # Skip root node - if (ancestor_idx == root_idx) { - row_list[[i]] <- 0L - col_list[[i]] <- 0L - next - } - - # Get descendants including self - descendants <- data.tree::Traverse(node, traversal = "pre-order") - descendant_names <- vapply(descendants, function(n) n$name, character(1)) - descendant_indices <- node_map[descendant_names] + # Climb up the tree to collect all ancestor CLASS nodes (including self) + anc_indices <- integer() + current <- node - # Filter out leaf columns - non_leaf_descendants <- descendant_indices[!descendant_indices %in% leaf_indices] + repeat { + # O(1) lookup: check if current node is in our class set + anc_idx <- class_map[current$name] + if (!is.na(anc_idx) && !is.null(anc_idx)) { + anc_indices <- c(anc_indices, anc_idx) + } + # Stop climbing if we reached root or have no parent + if (current$isRoot || is.null(current$parent)) break + current <- current$parent + } - row_list[[i]] <- rep(ancestor_idx, length(non_leaf_descendants)) - col_list[[i]] <- non_leaf_descendants + row_list[[i]] <- rep(desc_idx, length(anc_indices)) + col_list[[i]] <- anc_indices } - # 5. Combine all at once + # 4. Fill matrix + R <- matrix(0L, nrow = n_classes, ncol = n_classes) rows <- unlist(row_list, use.names = FALSE) cols <- unlist(col_list, use.names = FALSE) - # 6. Re-index to account for removed root row and leaf columns - # Map rows excluding root - valid_rows <- setdiff(seq_len(n_classes), root_idx) - row_remap <- setNames(seq_along(valid_rows), valid_rows) - - # Map cols excluding leaves - valid_cols <- setdiff(seq_len(n_classes), leaf_indices) - col_remap <- setNames(seq_along(valid_cols), valid_cols) - - # Apply remapping - rows_reindexed <- row_remap[as.character(rows)] - cols_reindexed <- col_remap[as.character(cols)] - - # 7. Create sparse tensor with new dimensions: (n_classes - 1) x (n_classes - n_leaves) - nrow <- n_classes - 1L - ncol <- n_classes - length(leaf_indices) + if (length(rows) > 0) { + R[cbind(rows, cols)] <- 1L + } - torch::torch_sparse_coo_tensor( - rbind(rows_reindexed, cols_reindexed), - rep(TRUE, length(rows)), - c(nrow, ncol) + # 5. Convert to torch tensor + R_torch <- torch::torch_tensor( + R, + dtype = torch::torch_double(), + device = device ) -} + + R_torch$unsqueeze(1) +} \ No newline at end of file diff --git a/R/model_training.R b/R/model_training.R index f0ff8b0d..ab077faf 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -514,9 +514,9 @@ tabnet_train_supervised <- function(obj, x, y, config = tabnet_config(), epoch_s # provide ancestor to torch tensor in case of hierarchical classification if (!is.null(config$ancestor)) { - if (!config$ancestor$is_sparse()) { - # config is expected to carry the sparse tensor - runtime_error("ancestor was configured. Expecting a sparse tensor but got {.cls {class(config$ancestor)}}") + if (!inherits(config$ancestor, "torch_tensor")) { + # config is expected to carry the tensor + runtime_error("ancestor was configured. Expecting a tensor but got {.cls {class(config$ancestor)}}") } } diff --git a/tests/testthat/test-hierarchical_utils.R b/tests/testthat/test-hierarchical_utils.R index e3f4481b..f4005716 100644 --- a/tests/testthat/test-hierarchical_utils.R +++ b/tests/testthat/test-hierarchical_utils.R @@ -228,25 +228,14 @@ test_that("max_constraint_output handles mixed positive-negative with constraint expect_equal_to_r(result, expected) }) -test_that("build_ancestor_matrix handles basic hierarchy", { - # Tree: Root -> A -> C - # Root -> B -> D - # Edges: R->A, A->C, R->B, B->D - # Pruning Logic: - # 1. Remove Root: Keeps A->C, B->D - # 2. Remove leaves (C, D are not in 'from'): Keeps A->C? No. C is not a parent. - # Keeps B->D? No. D is not a parent. - # Result: No edges match criteria. Empty matrix. - +test_that("build_ancestor_matrix handles basic unrelated hierarchy as a diag matrix", { tree_df <- data.frame(pathString = c("Root/A/C1", "Root/A/C2","Root/B/D1", "Root/B/D2")) tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree)$to_dense() - - # Expectation: No internal nodes exist that are also children (excluding Root) - # A and B are children of Root, but their children (C, D) are leaves. - # Thus A and B are effectively leaves in the "internal structure". - expect_tensor_shape(result, c(6, 3)) + result <- build_ancestor_matrix(tree) + + expect_tensor_shape(result, c(1,2,2)) + expect_equal_to_r(result$squeeze(), diag(2)) }) test_that("build_ancestor_matrix handles linear chain of internal nodes", { @@ -254,11 +243,11 @@ test_that("build_ancestor_matrix handles linear chain of internal nodes", { tree_df <- data.frame(pathString = c("Root/A/B", "Root/A/B/C"), value = 1:2) tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree)$to_dense()$to(torch_long()) + result <- build_ancestor_matrix(tree) - # upper triangular 3 x 3 mat with no diag - expected <- fBasics::Triang(matrix(TRUE, nrow = 3, ncol = 3)) - diag(3) - expect_equal_to_r(result, expected) + # lower triangular 2 x 2 mat + expected <- fBasics::triang(matrix(1, nrow = 2, ncol = 2)) + expect_equal_to_r(result$squeeze(), expected) }) test_that("build_ancestor_matrix calculates transitive closure correctly", { @@ -266,11 +255,11 @@ test_that("build_ancestor_matrix calculates transitive closure correctly", { tree_df <- data.frame(pathString = c("Root/A/B/C", "Root/A/B/C/D"), value = 1:2) tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree)$to_dense()$to(torch_long()) + result <- build_ancestor_matrix(tree) - # upper triangular 4 x 4 mat with no diag - expected <- fBasics::Triang(matrix(TRUE, nrow = 4, ncol = 4)) - diag(4) - expect_equal_to_r(result, expected) + # lower triangular 3 x 3 mat + expected <- fBasics::triang(matrix(TRUE, nrow = 3, ncol = 3)) + expect_equal_to_r(result$squeeze(), expected) }) test_that("build_ancestor_matrix handles branching internal nodes", { @@ -278,21 +267,20 @@ test_that("build_ancestor_matrix handles branching internal nodes", { tree_df <- data.frame(pathString = c("Root/A/C/E1", "Root/A/C/E2", "Root/B/D/E1", "Root/B/D/E3")) tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree)$to_dense()$to(torch_long()) + result <- build_ancestor_matrix(tree) - # two small upper triangular 2 x 2 mat in a 5 x 8 matrix - expected <- matrix(0L, nrow = 8, ncol = 5) - expected[1:2, 2:3] <- fBasics::Triang(matrix(1L, nrow = 2, ncol = 2)) - expected[5:6, 4:5] <- fBasics::Triang(matrix(1L, nrow = 2, ncol = 2)) + # diagonal matrix with 2 ancestors + expected <- diag(4) + expected[2,1] <- 1L + expected[4,3] <- 1L - - expect_equal_to_r(result, expected) + expect_equal_to_r(result$squeeze(), expected) }) test_that("build_ancestor_matrix returns empty for Root-only tree", { tree <- Node$new("Root") result <- build_ancestor_matrix(tree) - expect_equal(result$shape, c(0,0)) + expect_equal(result$shape, c(1,0,0)) }) test_that("build_ancestor_matrix returns empty for Root + Leaf", { @@ -300,7 +288,7 @@ test_that("build_ancestor_matrix returns empty for Root + Leaf", { tree_df <- data.frame(pathString = c("Root/A", "Root/B")) tree <- as.Node(tree_df) result <- build_ancestor_matrix(tree) - expect_equal(result$shape, c(2,1)) + expect_equal(result$shape, c(1,0,0)) }) test_that("node_to_df works ", { From 50dfc842d8a6861f529cada7800cfdefd35f435b Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Tue, 19 May 2026 00:31:33 +0200 Subject: [PATCH 13/21] switch to proper nn_mc_loss() --- NAMESPACE | 20 +++- R/loss.R | 184 ++++++++++++++++++++++++++++++----- R/model_training.R | 53 +++++----- man/build_ancestor_matrix.Rd | 27 +++++ man/get_constr_out.Rd | 22 +++++ man/nn_mc_loss.Rd | 56 +++++++++++ man/nnf_mc_loss.Rd | 54 ++++++++++ 7 files changed, 364 insertions(+), 52 deletions(-) create mode 100644 man/build_ancestor_matrix.Rd create mode 100644 man/get_constr_out.Rd create mode 100644 man/nn_mc_loss.Rd create mode 100644 man/nnf_mc_loss.Rd diff --git a/NAMESPACE b/NAMESPACE index 7cc1064a..7480a26c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,6 +24,7 @@ S3method(tabnet_pretrain,recipe) S3method(update,tabnet) export("%>%") export(attention_width) +export(build_ancestor_matrix) export(cat_emb_dim) export(check_compliant_node) export(checkpoint_epochs) @@ -39,6 +40,8 @@ export(mlp_activation) export(mlp_hidden_multiplier) export(momentum) export(nn_aum_loss) +export(nn_mc_loss) +export(nnf_mc_loss) export(node_to_df) export(num_independent) export(num_independent_decoder) @@ -71,9 +74,20 @@ importFrom(rlang,.data) importFrom(stats,predict) importFrom(stats,update) importFrom(tidyr,replace_na) +importFrom(torch,as_array) +importFrom(torch,nn_module) importFrom(torch,nn_prune_head) -importFrom(torch,torch_int64) -importFrom(torch,torch_ones) -importFrom(torch,torch_sparse_coo_tensor) +importFrom(torch,torch_argsort) +importFrom(torch,torch_cat) +importFrom(torch,torch_double) +importFrom(torch,torch_long) +importFrom(torch,torch_matmul) +importFrom(torch,torch_max) +importFrom(torch,torch_mean) +importFrom(torch,torch_minimum) +importFrom(torch,torch_mul) +importFrom(torch,torch_std) +importFrom(torch,torch_sum) +importFrom(torch,torch_tensor) importFrom(tune,min_grid) importFrom(zeallot,"%<-%") diff --git a/R/loss.R b/R/loss.R index ef018dc3..8b892c25 100644 --- a/R/loss.R +++ b/R/loss.R @@ -4,7 +4,8 @@ #' element in the input \eqn{y_pred} and target \eqn{embedded_x} on the values masked by \eqn{obfuscation_mask}. #' #' @noRd -nn_unsupervised_loss <- torch::nn_module( +#' @importFrom torch torch_mul torch_std torch_matmul torch_mean +nn_unsupervised_loss <- nn_module( "nn_unsupervised_loss", inherit = torch::nn_cross_entropy_loss, @@ -15,15 +16,15 @@ nn_unsupervised_loss <- torch::nn_module( forward = function(y_pred, embedded_x, obfuscation_mask){ errors <- y_pred - embedded_x - reconstruction_errors <- torch::torch_mul(errors, obfuscation_mask) ^ 2 - batch_stds <- torch::torch_std(embedded_x, dim = 1) ^ 2 + self$eps + reconstruction_errors <- torch_mul(errors, obfuscation_mask) ^ 2 + batch_stds <- torch_std(embedded_x, dim = 1) ^ 2 + self$eps # compute the number of obfuscated variables to reconstruct - nb_reconstructed_variables <- torch::torch_sum(obfuscation_mask, dim = 2) + nb_reconstructed_variables <- torch_sum(obfuscation_mask, dim = 2) # take the mean of the reconstructed variable errors - features_loss <- torch::torch_matmul(reconstruction_errors, 1 / batch_stds) / (nb_reconstructed_variables + self$eps) - loss <- torch::torch_mean(features_loss, dim = 1) + features_loss <- torch_matmul(reconstruction_errors, 1 / batch_stds) / (nb_reconstructed_variables + self$eps) + loss <- torch_mean(features_loss, dim = 1) loss } ) @@ -45,7 +46,9 @@ nn_unsupervised_loss <- torch::nn_module( #' output <- loss(input, target) #' output$backward() #' @export -nn_aum_loss <- torch::nn_module( +#' @importFrom torch nn_module torch_sum torch_cat torch_minimum torch_long torch_argsort +#' @importFrom torch torch_tensor as_array +nn_aum_loss <- nn_module( "nn_aum_loss", inherit = torch::nn_mse_loss, initialize = function(){ @@ -57,8 +60,8 @@ nn_aum_loss <- torch::nn_module( is_positive <- label_tensor == label_tensor$max() is_negative <- is_positive$bitwise_not() # manage case when prediction error is null (prevent division by 0) - if(as.logical(torch::torch_sum(is_positive) == 0) || as.logical(torch::torch_sum(is_negative) == 0)){ - return(torch::torch_sum(pred_tensor*0)) + if(as.logical(torch_sum(is_positive) == 0) || as.logical(torch_sum(is_negative) == 0)){ + return(torch_sum(pred_tensor*0)) } # pred tensor may be [prediction, case_wts] when add_case_weight() is used. We keep only prediction @@ -68,10 +71,10 @@ nn_aum_loss <- torch::nn_module( # nominal case fn_diff <- -1L * is_positive - fp_diff <- is_negative$to(dtype = torch::torch_long()) - fp_denom <- torch::torch_sum(is_negative) # or 1 for AUM based on count instead of rate - fn_denom <- torch::torch_sum(is_positive) # or 1 for AUM based on count instead of rate - sorted_pred_ids <- torch::torch_argsort(pred_tensor, dim = 1, descending = TRUE)$squeeze(-1) + fp_diff <- is_negative$to(dtype = torch_long()) + fp_denom <- torch_sum(is_negative) # or 1 for AUM based on count instead of rate + fn_denom <- torch_sum(is_positive) # or 1 for AUM based on count instead of rate + sorted_pred_ids <- torch_argsort(pred_tensor, dim = 1, descending = TRUE)$squeeze(-1) sorted_fp_cum <- fp_diff[sorted_pred_ids]$cumsum(dim = 1) / fp_denom sorted_fn_cum <- -fn_diff[sorted_pred_ids]$flip(1)$cumsum(dim = 1)$flip(1) / fn_denom @@ -79,26 +82,161 @@ nn_aum_loss <- torch::nn_module( sorted_dedup <- sorted_thresh_gr$diff(dim = 1) != 0 # pad to replace removed last element padding <- sorted_dedup$slice(dim = 1, 0, 1) # torch_tensor 1 w same dtype, same shape, same device - sorted_fp_end <- torch::torch_cat(c(sorted_dedup, padding)) - sorted_fn_end <- torch::torch_cat(c(padding, sorted_dedup)) + sorted_fp_end <- torch_cat(c(sorted_dedup, padding)) + sorted_fn_end <- torch_cat(c(padding, sorted_dedup)) uniq_thresh_gr <- sorted_thresh_gr[sorted_fp_end] uniq_fp_after <- sorted_fp_cum[sorted_fp_end] uniq_fn_before <- sorted_fn_cum[sorted_fn_end] if (pred_tensor$ndim == 1) { - FPR <- torch::torch_cat(c(padding$logical_not(), uniq_fp_after)) # FPR with trailing 0 - FNR <- torch::torch_cat(c(uniq_fn_before, padding$logical_not())) # FNR with leading 0 + FPR <- torch_cat(c(padding$logical_not(), uniq_fp_after)) # FPR with trailing 0 + FNR <- torch_cat(c(uniq_fn_before, padding$logical_not())) # FNR with leading 0 self$roc_aum <- list( FPR = FPR, FNR = FNR, TPR = 1 - FNR, - "min(FPR,FNR)" = torch::torch_minimum(FNR, FPR), # full-range min(FNR, FPR) - constant_range_low = torch::torch_cat(c(torch::torch_tensor(-Inf), uniq_thresh_gr)), - constant_range_high = torch::torch_cat(c(uniq_thresh_gr, torch::torch_tensor(Inf))) - ) %>% purrr::map_dfc(torch::as_array) + "min(FPR,FNR)" = torch_minimum(FNR, FPR), # full-range min(FNR, FPR) + constant_range_low = torch_cat(c(torch_tensor(-Inf), uniq_thresh_gr)), + constant_range_high = torch_cat(c(uniq_thresh_gr, torch_tensor(Inf))) + ) %>% purrr::map_dfc(as_array) } - min_FPR_FNR <- torch::torch_minimum(uniq_fp_after[1:-2], uniq_fn_before[2:N]) + min_FPR_FNR <- torch_minimum(uniq_fp_after[1:-2], uniq_fn_before[2:N]) constant_range_gr <- uniq_thresh_gr$diff() # range splits leading to {FPR, FNR } errors (see roc_aum row) - torch::torch_sum(min_FPR_FNR * constant_range_gr, dim = 1) + torch_sum(min_FPR_FNR * constant_range_gr, dim = 1) } ) + +#' Max-Constraint Margin Loss (functional) +#' +#' Computes the hierarchy-constrained loss for multi-label classification. +#' Enforces that if a class is predicted positive, all its ancestors must +#' also be positive, using the ancestor matrix R. +#' +#' The loss combines constrained outputs differently for positive and negative +#' labels: +#' \itemize{ +#' \item For positive labels: uses constrained output of label-weighted predictions +#' \item For negative labels: uses constrained raw predictions (penalizes ancestor violations) +#' } +#' +#' @param output A `torch_tensor` of raw network outputs (pre-sigmoid), +#' shape `(batch_size, n_classes)`. +#' @param target Binary target labels, shape `(batch_size, n_classes)`. +#' @param R Ancestor matrix tensor of shape `(1, n_classes, n_classes)` where +#' `R[1, i, j] = 1` iff class `i` is a descendant of class `j`. +#' @param to_eval Optional logical tensor of shape `(n_classes,)` indicating +#' which classes to include in the loss computation. If `NULL`, all classes +#' are evaluated. +#' @param criterion Loss function to apply after constraint propagation. +#' Default: `nnf_binary_cross_entropy_with_logits` (expects raw logits). +#' @param reduction (string, optional): Specifies the reduction to apply to +#' the output: `'none'` | `'mean'` | `'sum'`. Passed to `criterion`. +#' +#' @return A scalar `torch_tensor` containing the computed loss, or a tensor +#' of shape `(batch_size, n_classes)` if `reduction = "none"`. +#' +#' @seealso [nn_mc_loss()], [get_constr_out()] +#' @export +nnf_mc_loss <- function(output, target, R, to_eval = NULL, + criterion = nnf_binary_cross_entropy_with_logits, + reduction = "mean") { + # Ensure double precision for numerical stability during constraint propagation + output_d <- output$double() + + # 1. Constrained output from raw predictions: max-pool over descendants + constr_output <- get_constr_out(output_d, R) # (batch, n_classes) + + # 2. Label-weighted output, then constrained (for positive label handling) + labeled_output <- target * output_d + train_output <- get_constr_out(labeled_output, R) + + # 3. Blend outputs based on ground-truth labels: + # - Positive labels: use constrained label-weighted output + # - Negative labels: use constrained raw output + blended_output <- (1 - target) * constr_output + target * train_output + + # 4. Select classes to evaluate (if specified) + if (!is.null(to_eval)) { + blended_output <- blended_output[, to_eval, drop = FALSE] + target <- target[, to_eval, drop = FALSE] + } + + # 5. Apply the base loss function (e.g., BCE with logits) + loss <- criterion( + blended_output, + target$double(), + reduction = reduction + ) + + return(loss) +} + + +#' Max-Constraint Margin Loss (module) +#' +#' Module wrapper for [nnf_mc_loss()] with configurable parameters. +#' Stores the ancestor matrix R and evaluation mask for reuse across batches. +#' +#' @param R Ancestor matrix tensor of shape `(1, n_classes, n_classes)`. +#' @param to_eval Optional logical tensor of shape `(n_classes,)` indicating +#' which classes to include in loss computation. +#' @param criterion Loss function module or functional to apply after constraint +#' propagation. Default: `nn_binary_cross_entropy_with_logits()`. +#' @param reduction (string, optional): Reduction method: `'none'` | `'mean'` | `'sum'`. +#' +#' @section Shape: +#' - Input `output`: \eqn{(N, C)} where N = batch size, C = number of classes +#' - Input `target`: \eqn{(N, C)}, same shape as output, binary values +#' - Output: scalar by default. If `reduction = "none"`, then \eqn{(N, C')} +#' where C' is the number of evaluated classes +#' +#' @examples +#' \dontrun{ +#' # Build ancestor matrix from hierarchy +#' R <- build_ancestor_matrix(my_tree, device = "cuda") +#' +#' # Create loss module +#' loss_fn <- nn_mc_loss(R = R, reduction = "mean") +#' +#' # Forward pass +#' output <- model(x) # (batch, n_classes) +#' loss <- loss_fn(output, labels) +#' loss$backward() +#' } +#' +#' @seealso [nnf_mc_loss()], [build_ancestor_matrix()], [get_constr_out()] +#' @export +nn_mc_loss <- nn_module( + "nn_mc_loss", + inherit = torch::nn_l1_loss, + + initialize = function(R, to_eval = NULL, + criterion = torch::nn_bce_with_logits_loss(), + reduction = "mean") { + super$initialize(reduction = reduction) + + # Store ancestor matrix (move to device if needed) + self$R <- R + self$to_eval <- to_eval + self$criterion <- criterion + }, + + forward = function(output, target) { + nnf_mc_loss( + output = output, + target = target, + R = self$R, + to_eval = self$to_eval, + criterion = function(input, target, reduction) { + # Handle both module and functional criterion + if (inherits(self$criterion, "nn_module")) { + self$criterion(input, target, reduction = reduction) + } else { + # Assume functional + self$criterion(input, target, reduction = reduction) + } + }, + reduction = self$reduction + ) + } +) \ No newline at end of file diff --git a/R/model_training.R b/R/model_training.R index ab077faf..b30a33ec 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -227,11 +227,21 @@ tabnet_config <- function(batch_size = 1024^2, ) } -get_constr_output <- function(x, R) { - # MCM of the prediction given the hierarchy constraint expressed in the matrix R """ - c_out <- x$to(dtype = torch::torch_double())$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) +#' Apply hierarchy constraints via max-pooling over descendants (MCM) +#' +#' Given neural network outputs x and ancestor matrix R, enforces that +#' if a class is predicted positive, all its ancestors must also be positive. +#' Implements: final_out[i] = max{x[j] : R[i,j] = 1} +#' +#' @param x A `torch_tensor` of shape `(batch_size, n_classes)`. +#' @param R A `torch_tensor` of shape `(1, n_classes, n_classes)` where +#' `R[1, i, j] = 1` iff class `i` is a descendant of class `j`. +#' @return A `torch_tensor` of shape `(batch_size, n_classes)` with constrained outputs. +#' @importFrom torch torch_max torch_double +get_constr_out <- function(x, R) { + c_out <- x$to(dtype = torch_double())$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) R_batch <- R$expand(c(x$shape[1], R$shape[2], R$shape[2])) - final_out <- torch::torch_max(R_batch * c_out, dim = 3) + final_out <- torch_max(R_batch * c_out, dim = 3) final_out[[1]] } @@ -250,7 +260,9 @@ resolve_loss <- function(config, dtype) { loss_fn <- loss else if (loss %in% c("mse", "auto") && !dtype == torch::torch_long()) loss_fn <- torch::nn_mse_loss() - else if ((loss %in% c("bce", "cross_entropy", "auto") && dtype == torch::torch_long()) || !is.null(config$ancestor)) + else if (!is.null(config$ancestor)) + loss_fn <- nn_mc_loss(R = config$ancestor) + else if ((loss %in% c("bce", "cross_entropy", "auto") && dtype == torch::torch_long())) # cross entropy loss is required loss_fn <- torch::nn_cross_entropy_loss() else @@ -279,27 +291,16 @@ train_batch <- function(network, optimizer, batch, config) { if (max(batch$output_dim$shape) > 1) { # multi-outcome outcome_nlevels <- as.numeric(batch$output_dim$to(device="cpu")) - if (!is.null(config$ancestor)) { - # hierarchical mandates use of `max_constraint_output` - loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( - list( - torch::torch_split(out, outcome_nlevels, dim = 2), - torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) - ), - ~config$loss_fn(max_constraint_output(.x, .y, config$ancestor), .y$squeeze(2)) - )), - dim = 1) - } else { - # use `resolved_loss` - loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( - list( - torch::torch_split(out, outcome_nlevels, dim = 2), - torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) - ), - ~config$loss_fn(.x, .y$squeeze(2)) - )), - dim = 1) - } + + # use `resolved_loss` + loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( + list( + torch::torch_split(out, outcome_nlevels, dim = 2), + torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) + ), + ~config$loss_fn(.x, .y$squeeze(2)) + )), + dim = 1) } else { if (batch$y$dtype == torch::torch_long()) { # classifier needs a squeeze for bce loss diff --git a/man/build_ancestor_matrix.Rd b/man/build_ancestor_matrix.Rd new file mode 100644 index 00000000..5dab48f5 --- /dev/null +++ b/man/build_ancestor_matrix.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hardhat.R +\name{build_ancestor_matrix} +\alias{build_ancestor_matrix} +\title{Build ancestor-descendant matrix for class hierarchy from data.tree Node} +\usage{ +build_ancestor_matrix(x, device = "cpu") +} +\arguments{ +\item{x}{A \code{data.tree::Node} object representing the hierarchy. +Leaves should contain individual observations; intermediate nodes +represent class categories (e.g., Department, JobRole).} + +\item{device}{Target device for the output tensor (e.g., "cpu", "cuda").} +} +\value{ +A \code{torch_tensor} of shape \verb{(1, n_classes, n_classes)} with dtype +\code{torch_double}, where \code{R[i, j] <- 1} if class \code{i} is a descendant of +class \code{j} (including when \code{i == j}). +} +\description{ +Extracts class nodes (non-root, non-leaf) from a hierarchical tree where +leaves contain observations and intermediate nodes represent class categories. +Computes the transitive closure: R\link{i, j} = 1 if class i is a descendant +of class j (including self-loops). Matches the output orientation of the +provided Python/NetworkX snippet. +} diff --git a/man/get_constr_out.Rd b/man/get_constr_out.Rd new file mode 100644 index 00000000..bcfb2298 --- /dev/null +++ b/man/get_constr_out.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/model_training.R +\name{get_constr_out} +\alias{get_constr_out} +\title{Apply hierarchy constraints via max-pooling over descendants (MCM)} +\usage{ +get_constr_out(x, R) +} +\arguments{ +\item{x}{A \code{torch_tensor} of shape \verb{(batch_size, n_classes)}.} + +\item{R}{A \code{torch_tensor} of shape \verb{(1, n_classes, n_classes)} where +\code{R[1, i, j] = 1} iff class \code{i} is a descendant of class \code{j}.} +} +\value{ +A \code{torch_tensor} of shape \verb{(batch_size, n_classes)} with constrained outputs. +} +\description{ +Given neural network outputs x and ancestor matrix R, enforces that +if a class is predicted positive, all its ancestors must also be positive. +Implements: final_out\link{i} = max{x\link{j} : R\link{i,j} = 1} +} diff --git a/man/nn_mc_loss.Rd b/man/nn_mc_loss.Rd new file mode 100644 index 00000000..53dcda69 --- /dev/null +++ b/man/nn_mc_loss.Rd @@ -0,0 +1,56 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loss.R +\name{nn_mc_loss} +\alias{nn_mc_loss} +\title{Max-Constraint Margin Loss (module)} +\usage{ +nn_mc_loss( + R, + to_eval = NULL, + criterion = torch::nn_bce_with_logits_loss(), + reduction = "mean" +) +} +\arguments{ +\item{R}{Ancestor matrix tensor of shape \verb{(1, n_classes, n_classes)}.} + +\item{to_eval}{Optional logical tensor of shape \verb{(n_classes,)} indicating +which classes to include in loss computation.} + +\item{criterion}{Loss function module or functional to apply after constraint +propagation. Default: \code{nn_binary_cross_entropy_with_logits()}.} + +\item{reduction}{(string, optional): Reduction method: \code{'none'} | \code{'mean'} | \code{'sum'}.} +} +\description{ +Module wrapper for \code{\link[=nnf_mc_loss]{nnf_mc_loss()}} with configurable parameters. +Stores the ancestor matrix R and evaluation mask for reuse across batches. +} +\section{Shape}{ + +\itemize{ +\item Input \code{output}: \eqn{(N, C)} where N = batch size, C = number of classes +\item Input \code{target}: \eqn{(N, C)}, same shape as output, binary values +\item Output: scalar by default. If \code{reduction = "none"}, then \eqn{(N, C')} +where C' is the number of evaluated classes +} +} + +\examples{ +\dontrun{ +# Build ancestor matrix from hierarchy +R <- build_ancestor_matrix(my_tree, device = "cuda") + +# Create loss module +loss_fn <- nn_mc_loss(R = R, reduction = "mean") + +# Forward pass +output <- model(x) # (batch, n_classes) +loss <- loss_fn(output, labels) +loss$backward() +} + +} +\seealso{ +\code{\link[=nnf_mc_loss]{nnf_mc_loss()}}, \code{\link[=build_ancestor_matrix]{build_ancestor_matrix()}}, \code{\link[=get_constr_out]{get_constr_out()}} +} diff --git a/man/nnf_mc_loss.Rd b/man/nnf_mc_loss.Rd new file mode 100644 index 00000000..9abb760d --- /dev/null +++ b/man/nnf_mc_loss.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loss.R +\name{nnf_mc_loss} +\alias{nnf_mc_loss} +\title{Max-Constraint Margin Loss (functional)} +\usage{ +nnf_mc_loss( + output, + target, + R, + to_eval = NULL, + criterion = nnf_binary_cross_entropy_with_logits, + reduction = "mean" +) +} +\arguments{ +\item{output}{A \code{torch_tensor} of raw network outputs (pre-sigmoid), +shape \verb{(batch_size, n_classes)}.} + +\item{target}{Binary target labels, shape \verb{(batch_size, n_classes)}.} + +\item{R}{Ancestor matrix tensor of shape \verb{(1, n_classes, n_classes)} where +\code{R[1, i, j] = 1} iff class \code{i} is a descendant of class \code{j}.} + +\item{to_eval}{Optional logical tensor of shape \verb{(n_classes,)} indicating +which classes to include in the loss computation. If \code{NULL}, all classes +are evaluated.} + +\item{criterion}{Loss function to apply after constraint propagation. +Default: \code{nnf_binary_cross_entropy_with_logits} (expects raw logits).} + +\item{reduction}{(string, optional): Specifies the reduction to apply to +the output: \code{'none'} | \code{'mean'} | \code{'sum'}. Passed to \code{criterion}.} +} +\value{ +A scalar \code{torch_tensor} containing the computed loss, or a tensor +of shape \verb{(batch_size, n_classes)} if \code{reduction = "none"}. +} +\description{ +Computes the hierarchy-constrained loss for multi-label classification. +Enforces that if a class is predicted positive, all its ancestors must +also be positive, using the ancestor matrix R. +} +\details{ +The loss combines constrained outputs differently for positive and negative +labels: +\itemize{ +\item For positive labels: uses constrained output of label-weighted predictions +\item For negative labels: uses constrained raw predictions (penalizes ancestor violations) +} +} +\seealso{ +\code{\link[=nn_mc_loss]{nn_mc_loss()}}, \code{\link[=get_constr_out]{get_constr_out()}} +} From 1cf0b9d4c2b8ce118ff8cd9f2fed0eae403c11ef Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Wed, 3 Jun 2026 19:53:59 +0200 Subject: [PATCH 14/21] add the constraint of "No missing Values" to hierarchical labels coalesce missing lables in tests fix `build_ancestor_matrix` --- R/hardhat.R | 81 +++-- R/loss.R | 10 +- R/model_training.R | 60 ++-- R/utils.R | 31 ++ man/build_ancestor_matrix.Rd | 8 +- ...get_constr_out.Rd => get_constr_output.Rd} | 8 +- man/nn_mc_loss.Rd | 2 +- man/nnf_mc_loss.Rd | 2 +- man/node_to_df.Rd | 18 +- tests/testthat/setup.R | 2 + tests/testthat/test-hardhat_hierarchical.R | 21 +- tests/testthat/test-hierarchical_utils.R | 286 +++++++++--------- vignettes/Hierarchical_classification.Rmd | 10 +- 13 files changed, 300 insertions(+), 239 deletions(-) rename man/{get_constr_out.Rd => get_constr_output.Rd} (83%) diff --git a/R/hardhat.R b/R/hardhat.R index e7810b47..46513b1a 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -166,6 +166,7 @@ tabnet_fit.Node <- function(x, tabnet_model = NULL, config = tabnet_config(), .. config <- merge_config_and_dots(config, ...) # add ancestor boolean sparse matrix to config + # check_dag_compliance(xy_df$y) config$ancestor <- build_ancestor_matrix(x) tabnet_bridge(processed, config = config, tabnet_model, from_epoch, task = "supervised") @@ -413,13 +414,17 @@ tabnet_bridge <- function(processed, config = tabnet_config(), tabnet_model, fro #' @importFrom stats predict #' @export predict.tabnet_fit <- function(object, new_data, type = NULL, ..., epoch = NULL) { - if (inherits(new_data, "Node")) { + if (inherits(new_data, "Node") && !is.null(object$fit$config$ancestor)) { new_data_df <- node_to_df(new_data)$x + require_contraint_output <- TRUE } else { new_data_df <- new_data } # Enforces column order, type, column names, etc processed <- hardhat::forge(new_data_df, object$blueprint) + if (require_contraint_output) { + processed$predictors <- get_constr_output(processed$predictors, object$fit$config$ancestor) + } batch_size <- object$fit$config$batch_size out <- predict_tabnet_bridge(type, object, processed$predictors, epoch, batch_size) hardhat::validate_prediction_size(out, new_data_df) @@ -453,6 +458,7 @@ predict_tabnet_bridge <- function(type, object, predictors, epoch, batch_size) { object$fit$network$load_state_dict(m$state_dict()) } + type_multioutcome <- paste0(type, "_", is_multi_outcome) switch( type_multioutcome, @@ -605,7 +611,7 @@ nn_prune_head.tabnet_pretrain <- function(x, head_size) { #' #' Extracts class nodes (non-root, non-leaf) from a hierarchical tree where #' leaves contain observations and intermediate nodes represent class categories. -#' Computes the transitive closure: R[i, j] = 1 if class i is a descendant +#' Computes the transitive closure: `R[i, j] = 1` if class i is a descendant #' of class j (including self-loops). Matches the output orientation of the #' provided Python/NetworkX snippet. #' @@ -613,76 +619,65 @@ nn_prune_head.tabnet_pretrain <- function(x, head_size) { #' Leaves should contain individual observations; intermediate nodes #' represent class categories (e.g., Department, JobRole). #' @param device Target device for the output tensor (e.g., "cpu", "cuda"). +#' @param keep_levels Optional integer vector. If provided, only nodes at +#' these levels are treated as classes. If `NULL`, all non-root/non-leaf +#' nodes are kept. #' @return A `torch_tensor` of shape `(1, n_classes, n_classes)` with dtype #' `torch_double`, where `R[i, j] <- 1` if class `i` is a descendant of #' class `j` (including when `i == j`). #' @importFrom torch torch_tensor torch_double #' @export -build_ancestor_matrix <- function(x, device = "cpu") { - # 1. Extract CLASS nodes using data.tree's filtering to exclude root and leaves - class_nodes <- data.tree::Traverse( - x, - traversal = "pre-order", - filterFun = function(node) !node$isRoot & !node$isLeaf - ) - class_nodes <- unname(class_nodes) +build_ancestor_matrix <- function(x, device = "cpu", keep_levels = NULL) { + # 1. Traverse all nodes + all_nodes <- data.tree::Traverse(x, traversal = "pre-order") + all_nodes <- unname(all_nodes) + + # 2. Filter nodes + is_class <- vapply(all_nodes, function(n) { + !n$isRoot && !n$isLeaf && + (is.null(keep_levels) || n$level %in% keep_levels) + }, logical(1)) + + class_nodes <- all_nodes[is_class] n_classes <- length(class_nodes) - # Handle edge case: no class nodes found if (n_classes == 0L) { - return(torch::torch_zeros( - 1L, 0L, 0L, - dtype = torch::torch_double(), - device = device - )) + return(torch::torch_zeros(1L, 0L, 0L, dtype = torch::torch_double(), device = device)) } - # 2. Create 1-based index mapping + O(1) named lookup for class names - class_names <- vapply(class_nodes, `[[`, "name", FUN.VALUE = character(1)) - class_map <- setNames(seq_len(n_classes), class_names) + # 3. safe mapping using pathString as unique key + class_paths <- vapply(class_nodes, `[[`, "pathString", FUN.VALUE = character(1)) + class_map <- setNames(seq_len(n_classes), class_paths) - # 3. Collect (descendant, ancestor) index pairs via tree climbing + # 4. Collect (descendant, ancestor) pairs row_list <- vector("list", n_classes) col_list <- vector("list", n_classes) for (i in seq_len(n_classes)) { - node <- class_nodes[[i]] - desc_idx <- i - - # Climb up the tree to collect all ancestor CLASS nodes (including self) + current <- class_nodes[[i]] anc_indices <- integer() - current <- node repeat { - # O(1) lookup: check if current node is in our class set - anc_idx <- class_map[current$name] - if (!is.na(anc_idx) && !is.null(anc_idx)) { - anc_indices <- c(anc_indices, anc_idx) + # Lookup using unique pathString + idx <- class_map[current$pathString] + if (!is.na(idx)) { + anc_indices <- c(anc_indices, idx) } - # Stop climbing if we reached root or have no parent if (current$isRoot || is.null(current$parent)) break current <- current$parent } - row_list[[i]] <- rep(desc_idx, length(anc_indices)) + row_list[[i]] <- rep(i, length(anc_indices)) col_list[[i]] <- anc_indices } - # 4. Fill matrix + # 5. Fill matrix R <- matrix(0L, nrow = n_classes, ncol = n_classes) rows <- unlist(row_list, use.names = FALSE) cols <- unlist(col_list, use.names = FALSE) + if (length(rows) > 0) R[cbind(rows, cols)] <- 1L - if (length(rows) > 0) { - R[cbind(rows, cols)] <- 1L - } - - # 5. Convert to torch tensor - R_torch <- torch::torch_tensor( - R, - dtype = torch::torch_double(), - device = device - ) - + # 6. Convert to torch + R_torch <- torch::torch_tensor(R, dtype = torch::torch_double(), device = device) R_torch$unsqueeze(1) } \ No newline at end of file diff --git a/R/loss.R b/R/loss.R index 8b892c25..fb4b3b62 100644 --- a/R/loss.R +++ b/R/loss.R @@ -135,7 +135,7 @@ nn_aum_loss <- nn_module( #' @return A scalar `torch_tensor` containing the computed loss, or a tensor #' of shape `(batch_size, n_classes)` if `reduction = "none"`. #' -#' @seealso [nn_mc_loss()], [get_constr_out()] +#' @seealso [nn_mc_loss()], [get_constr_output()] #' @export nnf_mc_loss <- function(output, target, R, to_eval = NULL, criterion = nnf_binary_cross_entropy_with_logits, @@ -144,11 +144,11 @@ nnf_mc_loss <- function(output, target, R, to_eval = NULL, output_d <- output$double() # 1. Constrained output from raw predictions: max-pool over descendants - constr_output <- get_constr_out(output_d, R) # (batch, n_classes) + constr_output <- get_constr_output(output_d, R) # (batch, n_classes) # 2. Label-weighted output, then constrained (for positive label handling) labeled_output <- target * output_d - train_output <- get_constr_out(labeled_output, R) + train_output <- get_constr_output(labeled_output, R) # 3. Blend outputs based on ground-truth labels: # - Positive labels: use constrained label-weighted output @@ -204,7 +204,7 @@ nnf_mc_loss <- function(output, target, R, to_eval = NULL, #' loss$backward() #' } #' -#' @seealso [nnf_mc_loss()], [build_ancestor_matrix()], [get_constr_out()] +#' @seealso [nnf_mc_loss()], [build_ancestor_matrix()], [get_constr_output()] #' @export nn_mc_loss <- nn_module( "nn_mc_loss", @@ -239,4 +239,4 @@ nn_mc_loss <- nn_module( reduction = self$reduction ) } -) \ No newline at end of file +) diff --git a/R/model_training.R b/R/model_training.R index b30a33ec..ff1d3427 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -231,25 +231,25 @@ tabnet_config <- function(batch_size = 1024^2, #' #' Given neural network outputs x and ancestor matrix R, enforces that #' if a class is predicted positive, all its ancestors must also be positive. -#' Implements: final_out[i] = max{x[j] : R[i,j] = 1} +#' Implements: `final_out[i] = max{x[j] : R[i,j] = 1}` #' #' @param x A `torch_tensor` of shape `(batch_size, n_classes)`. #' @param R A `torch_tensor` of shape `(1, n_classes, n_classes)` where #' `R[1, i, j] = 1` iff class `i` is a descendant of class `j`. #' @return A `torch_tensor` of shape `(batch_size, n_classes)` with constrained outputs. #' @importFrom torch torch_max torch_double -get_constr_out <- function(x, R) { +get_constr_output <- function(x, R) { c_out <- x$to(dtype = torch_double())$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) R_batch <- R$expand(c(x$shape[1], R$shape[2], R$shape[2])) final_out <- torch_max(R_batch * c_out, dim = 3) final_out[[1]] } -max_constraint_output <- function(output, labels, ancestor) { - constr_output <- get_constr_output(output, ancestor) - train_output <- get_constr_output(labels * output, ancestor) - torch::torch_logical_not(labels) * constr_output + labels * train_output -} +# max_constraint_output <- function(output, labels, ancestor) { +# constr_output <- get_constr_output(output, ancestor) +# train_output <- get_constr_output(labels * output, ancestor) +# torch::torch_logical_not(labels) * constr_output + labels * train_output +# } resolve_loss <- function(config, dtype) { loss <- config$loss @@ -287,8 +287,9 @@ train_batch <- function(network, optimizer, batch, config) { out <- M_loss <- NULL # forward pass c(out, M_loss) %<-% network(batch$x, batch$x_na_mask) - # if target is multi-outcome, loss has to be applied to each label-group - if (max(batch$output_dim$shape) > 1) { + + # if target is multi-outcome but not max_constraint loss, loss has to be applied to each label-group + if (max(batch$output_dim$shape) > 1 && is.null(config$ancestor)) { # multi-outcome outcome_nlevels <- as.numeric(batch$output_dim$to(device="cpu")) @@ -301,13 +302,11 @@ train_batch <- function(network, optimizer, batch, config) { ~config$loss_fn(.x, .y$squeeze(2)) )), dim = 1) + } else if (batch$y$dtype == torch::torch_long()) { + # classifier needs a squeeze for bce loss + loss <- config$loss_fn(out, batch$y$squeeze(2)) } else { - if (batch$y$dtype == torch::torch_long()) { - # classifier needs a squeeze for bce loss - loss <- config$loss_fn(out, batch$y$squeeze(2)) - } else { - loss <- config$loss_fn(out, batch$y) - } + loss <- config$loss_fn(out, batch$y) } # Add the overall sparsity loss loss <- loss - config$lambda_sparse * M_loss @@ -334,27 +333,16 @@ valid_batch <- function(network, batch, config) { if (max(batch$output_dim$shape) > 1) { # multi-outcome outcome_nlevels <- as.numeric(batch$output_dim$to(device="cpu")) - if (!is.null(config$ancestor)) { - # hierarchical mandates use of `max_constraint_output` - loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( - list( - torch::torch_split(out, outcome_nlevels, dim = 2), - torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) - ), - ~config$loss_fn(max_constraint_output(.x, .y$squeeze(2), config$ancestor)) - )), - dim = 1) - } else { - # use `resolved_loss` - loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( - list( - torch::torch_split(out, outcome_nlevels, dim = 2), - torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) - ), - ~config$loss_fn(.x, .y$squeeze(2)) - )), - dim = 1) - } + # use `resolved_loss` + loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( + list( + torch::torch_split(out, outcome_nlevels, dim = 2), + torch::torch_split(batch$y, rep(1, length(outcome_nlevels)), dim = 2) + ), + ~config$loss_fn(.x, .y$squeeze(2)) + )), + dim = 1) + } else { if (batch$y$dtype == torch::torch_long()) { # classifier needs a squeeze for bce loss diff --git a/R/utils.R b/R/utils.R index 229c5fae..4c725b13 100644 --- a/R/utils.R +++ b/R/utils.R @@ -74,8 +74,39 @@ check_compliant_node <- function(node) { Please change those names as they will lead to unexpected tabnet behavior.") } + + + invisible(node) } +#' Check that the multi outcomes makes a DAG +#' +#' @param y the y dataframe as the result of `node_to_df(x)$y` +#' +#' @return y if it is compliant, else an Error with the column names to fix +#' @export +#' +#' @examplesIf (require("data.tree") || require("dplyr")) +#' library(dplyr) +#' library(data.tree) +#' data(starwars) +#' starwars_tree_y <- starwars %>% select(species, homeworld) +#' +#' try(check_dag_compliance(starwars_tree_y)) +#' +# check_dag_compliance <- function(y) { +# actual_names <- names(y) +# if (any(actual_names %in% reserved_names)) { +# value_error("The attributes or colnames in the provided hierarchical object use the following reserved names: +# {.vars {actual_names[actual_names %in% reserved_names]}}. +# Please change those names as they will lead to unexpected tabnet behavior.") +# } +# +# +# +# +# invisible(node) +# } #' Turn a Node object into predictor and outcome. #' diff --git a/man/build_ancestor_matrix.Rd b/man/build_ancestor_matrix.Rd index 5dab48f5..9b67b71b 100644 --- a/man/build_ancestor_matrix.Rd +++ b/man/build_ancestor_matrix.Rd @@ -4,7 +4,7 @@ \alias{build_ancestor_matrix} \title{Build ancestor-descendant matrix for class hierarchy from data.tree Node} \usage{ -build_ancestor_matrix(x, device = "cpu") +build_ancestor_matrix(x, device = "cpu", keep_levels = NULL) } \arguments{ \item{x}{A \code{data.tree::Node} object representing the hierarchy. @@ -12,6 +12,10 @@ Leaves should contain individual observations; intermediate nodes represent class categories (e.g., Department, JobRole).} \item{device}{Target device for the output tensor (e.g., "cpu", "cuda").} + +\item{keep_levels}{Optional integer vector. If provided, only nodes at +these levels are treated as classes. If \code{NULL}, all non-root/non-leaf +nodes are kept.} } \value{ A \code{torch_tensor} of shape \verb{(1, n_classes, n_classes)} with dtype @@ -21,7 +25,7 @@ class \code{j} (including when \code{i == j}). \description{ Extracts class nodes (non-root, non-leaf) from a hierarchical tree where leaves contain observations and intermediate nodes represent class categories. -Computes the transitive closure: R\link{i, j} = 1 if class i is a descendant +Computes the transitive closure: \code{R[i, j] = 1} if class i is a descendant of class j (including self-loops). Matches the output orientation of the provided Python/NetworkX snippet. } diff --git a/man/get_constr_out.Rd b/man/get_constr_output.Rd similarity index 83% rename from man/get_constr_out.Rd rename to man/get_constr_output.Rd index bcfb2298..0ca355ea 100644 --- a/man/get_constr_out.Rd +++ b/man/get_constr_output.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_training.R -\name{get_constr_out} -\alias{get_constr_out} +\name{get_constr_output} +\alias{get_constr_output} \title{Apply hierarchy constraints via max-pooling over descendants (MCM)} \usage{ -get_constr_out(x, R) +get_constr_output(x, R) } \arguments{ \item{x}{A \code{torch_tensor} of shape \verb{(batch_size, n_classes)}.} @@ -18,5 +18,5 @@ A \code{torch_tensor} of shape \verb{(batch_size, n_classes)} with constrained o \description{ Given neural network outputs x and ancestor matrix R, enforces that if a class is predicted positive, all its ancestors must also be positive. -Implements: final_out\link{i} = max{x\link{j} : R\link{i,j} = 1} +Implements: \verb{final_out[i] = max\{x[j] : R[i,j] = 1\}} } diff --git a/man/nn_mc_loss.Rd b/man/nn_mc_loss.Rd index 53dcda69..4c21cffc 100644 --- a/man/nn_mc_loss.Rd +++ b/man/nn_mc_loss.Rd @@ -52,5 +52,5 @@ loss$backward() } \seealso{ -\code{\link[=nnf_mc_loss]{nnf_mc_loss()}}, \code{\link[=build_ancestor_matrix]{build_ancestor_matrix()}}, \code{\link[=get_constr_out]{get_constr_out()}} +\code{\link[=nnf_mc_loss]{nnf_mc_loss()}}, \code{\link[=build_ancestor_matrix]{build_ancestor_matrix()}}, \code{\link[=get_constr_output]{get_constr_output()}} } diff --git a/man/nnf_mc_loss.Rd b/man/nnf_mc_loss.Rd index 9abb760d..0991fc12 100644 --- a/man/nnf_mc_loss.Rd +++ b/man/nnf_mc_loss.Rd @@ -50,5 +50,5 @@ labels: } } \seealso{ -\code{\link[=nn_mc_loss]{nn_mc_loss()}}, \code{\link[=get_constr_out]{get_constr_out()}} +\code{\link[=nn_mc_loss]{nn_mc_loss()}}, \code{\link[=get_constr_output]{get_constr_output()}} } diff --git a/man/node_to_df.Rd b/man/node_to_df.Rd index 79e9002d..75d97c24 100644 --- a/man/node_to_df.Rd +++ b/man/node_to_df.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/utils.R \name{node_to_df} \alias{node_to_df} -\title{Turn a Node object into predictor and outcome.} +\title{Check that the multi outcomes makes a DAG} \usage{ node_to_df(x, drop_last_level = TRUE) } @@ -10,19 +10,33 @@ node_to_df(x, drop_last_level = TRUE) \item{x}{Node object} \item{drop_last_level}{TRUE unused} + +\item{y}{the y dataframe as the result of \code{node_to_df(x)$y}} } \value{ +y if it is compliant, else an Error with the column names to fix + a named list of x and y, being respectively the predictor data-frame and the outcomes data-frame, as expected inputs for \code{hardhat::mold()} function. } \description{ -Turn a Node object into predictor and outcome. +Check that the multi outcomes makes a DAG } \examples{ \dontshow{if ((require("data.tree") || require("dplyr"))) withAutoprint(\{ # examplesIf} library(dplyr) library(data.tree) data(starwars) +starwars_tree_y <- starwars \%>\% select(species, homeworld) + +try(check_dag_compliance(starwars_tree_y)) + +Turn a Node object into predictor and outcome. +\dontshow{\}) # examplesIf} +\dontshow{if ((require("data.tree") || require("dplyr"))) withAutoprint(\{ # examplesIf} +library(dplyr) +library(data.tree) +data(starwars) starwars_tree <- starwars \%>\% mutate(pathString = paste("tree", species, homeworld, `name`, sep = "/")) \%>\% as.Node() diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 74c72ae9..95527413 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -42,6 +42,8 @@ acme_df <- data.tree::ToDataFrameTypeCol(acme, acme$attributesAll) %>% # acme2$RemoveAttribute("level_3") attrition_tree <- attrition %>% + # ensure pure tree + filter(!(Department %in% c("Sales", "Research_Development") & JobRole == "Manager")) %>% tibble::rowid_to_column() %>% mutate(pathString = paste("attrition", Department, JobRole, rowid, sep = "/")) %>% select(-Department, -JobRole, -rowid) %>% diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index 1b3d9ef8..88fc6b71 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -63,11 +63,30 @@ test_that("hierarchical classification for {data.tree} Node is explainable", { }) +test_that("Training hierarchical classification for {data.tree} Node for starwars", { + + # try to use starwars dataset with two forbidden column name + starwars_tree <- starwars %>% + rename(`_name` = "name", `_height` = "height") %>% + mutate(species = coalesce(species, "Unknown_Species"), + sex = coalesce(sex, "Unknown_Sex"), + pathString = paste("StarWars_characters", species, sex, `_name`, sep = "/")) %>% + as.Node() + + expect_error( + check_compliant_node(starwars_tree) + ,"reserved names") + + fit <- tabnet_fit(starwars_tree, epochs = 1) +}) + test_that("we properly check non-compliant colnames", { # try to use starwars dataset with two forbidden column name starwars_tree <- starwars %>% - mutate(pathString = paste("tree", species, homeworld, `name`, sep = "/")) + mutate(species = coalesce(species, "Unknown_Species"), + sex = coalesce(sex, "Unknown_Sex"), + pathString = paste("tree", species, homeworld, `name`, sep = "/")) expect_error( check_compliant_node(starwars_tree) ,"reserved names") diff --git a/tests/testthat/test-hierarchical_utils.R b/tests/testthat/test-hierarchical_utils.R index f4005716..97020dd7 100644 --- a/tests/testthat/test-hierarchical_utils.R +++ b/tests/testthat/test-hierarchical_utils.R @@ -1,9 +1,9 @@ test_that("get_constr_output handles basic 2D input with identity constraint", { m <- matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2) - x <- torch_tensor(m, dtype = torch_float32()) - R <- torch_eye(2, dtype = torch_float32()) - result <- get_constr_output(x, R) + x <- torch_tensor(m, dtype = torch::torch_float32()) + R <- torch::torch_eye(2, dtype = torch::torch_float32()) + result <-get_constr_output(x, R) expect_tensor(result) expect_tensor_shape(result, c(2, 2)) expect_equal_to_r(result, m) @@ -11,21 +11,21 @@ test_that("get_constr_output handles basic 2D input with identity constraint", { test_that("get_constr_output applies hierarchy constraint correctly", { x <- torch_tensor(matrix(c(1, 5, - 3, 2), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) + 3, 2), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch::torch_float64()) R <- torch_tensor(matrix(c(1, 1, - 0, 1), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_float64()) - result <- get_constr_output(x, R) + 0, 1), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch::torch_float64()) + result <-get_constr_output(x, R) expect_tensor_shape(result, c(2, 2)) expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) expect_equal_to_r(result, expected, tolerance = 1e-6) }) test_that("get_constr_output preserves input dtype", { - x_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float32()) - x_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float64()) - R <- torch_eye(2) - expect_tensor_dtype(get_constr_output(x_f32, R), torch_float64()) - expect_tensor_dtype(get_constr_output(x_f64, R), torch_float64()) + x_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float32()) + x_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float64()) + R <- torch::torch_eye(2) + expect_tensor_dtype(get_constr_output(x_f32, R), torch::torch_float64()) + expect_tensor_dtype(get_constr_output(x_f64, R), torch::torch_float64()) }) test_that("get_constr_output handles batch dimension correctly", { @@ -34,7 +34,7 @@ test_that("get_constr_output handles batch dimension correctly", { 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) - result <- get_constr_output(x, R) + result <-get_constr_output(x, R) expect_tensor_shape(result, c(3, 4)) for (i in 1:3) { @@ -52,7 +52,7 @@ test_that("get_constr_output works with single sample", { 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) - result <- get_constr_output(x, R) + result <-get_constr_output(x, R) expect_tensor_shape(result, c(1, 4)) expected <- matrix(c(2, 2, 4, 4), nrow = 1, byrow = TRUE) expect_equal_to_r(result, expected) @@ -60,8 +60,8 @@ test_that("get_constr_output works with single sample", { test_that("get_constr_output handles all-zeros constraint matrix", { x <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) - R <- torch_zeros(c(3, 3)) - result <- get_constr_output(x, R) + R <- torch::torch_zeros(c(3, 3)) + result <-get_constr_output(x, R) expect_tensor_shape(result, c(2, 3)) expect_equal_to_r(result, matrix(0, nrow = 2, ncol = 3)) }) @@ -69,8 +69,8 @@ test_that("get_constr_output handles all-zeros constraint matrix", { test_that("get_constr_output handles all-ones constraint matrix", { x <- torch_tensor(matrix(c(1, 5, 3, 2, 4, 6), nrow = 2, ncol = 3, byrow = TRUE)) - R <- torch_ones(c(3, 3)) - result <- get_constr_output(x, R) + R <- torch::torch_ones(c(3, 3)) + result <-get_constr_output(x, R) expect_tensor_shape(result, c(2, 3)) # Each row is filled with its own row-wise maximum expected <- matrix(c(5, 5, 5, @@ -80,7 +80,7 @@ test_that("get_constr_output handles all-ones constraint matrix", { test_that("get_constr_output throws error for dimension mismatch", { x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - R <- torch_eye(3) + R <- torch::torch_eye(3) expect_error(get_constr_output(x, R), "must match the existing size") }) @@ -90,119 +90,119 @@ test_that("get_constr_output throws error for non-2D R", { expect_error(get_constr_output(x, R), "dimension") }) -test_that("max_constraint_output returns original output when ancestor is identity", { - output <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) - labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, - FALSE, TRUE, FALSE), nrow = 2, ncol = 3), dtype = torch_bool()) - ancestor <- torch_eye(3) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 3)) - # With an identity ancestor matrix, constraint propagation is neutral. - # The formula simplifies to: (~labels * output) + (labels * output) == output - expect_equal_to_r(result, matrix(1:6, nrow = 2, ncol = 3)) -}) - -test_that("max_constraint_output applies constraint to positive labels", { - output <- torch_tensor(matrix(c(1, 5, - 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(1, 0, - 1, 0), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, - 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 2)) - # Unlabelled positions get propagated raw max, labelled get propagated masked max - expected <- matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -test_that("max_constraint_output handles all-zero labels", { - output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - labels <- torch_zeros(c(2, 2), dtype = torch_bool()) - ancestor <- torch_eye(2) - result <- max_constraint_output(output, labels, ancestor) - # With all false labels, result equals constr_output. With identity ancestor, constr_output == output - expect_equal_to_r(result, matrix(1:4, nrow = 2, ncol = 2)) -}) - -test_that("max_constraint_output handles all-one labels", { - output <- torch_tensor(matrix(c(1, 5, - 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_ones(c(2, 2), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 2)) - # When all labels are TRUE, (~labels) is 0, so result = train_output. - expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -test_that("max_constraint_output preserves output dtype", { - output_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float32()) - output_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch_float64()) - labels <- torch_ones(c(2, 2), dtype = torch_bool()) - ancestor <- torch_eye(2) - expect_tensor_dtype(max_constraint_output(output_f32, labels, ancestor), torch_float64()) - expect_tensor_dtype(max_constraint_output(output_f64, labels, ancestor), torch_float64()) -}) - - -test_that("max_constraint_output works with complex hierarchy", { - output <- torch_tensor(matrix(c(1, 2, 3, - 4, 5, 6), nrow = 2, ncol = 3, byrow = TRUE)) - labels <- torch_tensor(matrix(c(1, 0, 0, - 0, 1, 0), nrow = 2, ncol = 3, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_triu(torch_ones(c(3,3))) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 3)) - # Row 1: label on col 1 -> train_output[1,1]=1, others get constr_output=3 - # Row 2: label on col 2 -> train_output[2,2]=5, others get constr_output=6 - expected <- matrix(c(1, 3, 3, - 6, 5, 6), nrow = 2, ncol = 3, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -test_that("max_constraint_output handles single element tensors", { - output <- torch_tensor(matrix(5, nrow = 1, ncol = 1)) - labels <- torch_tensor(matrix(TRUE, nrow = 1, ncol = 1), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(1, nrow = 1, ncol = 1)) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(1, 1)) - # Compare against 1x1 matrix instead of scalar to match torch array output - expect_equal_to_r(result, matrix(5, nrow = 1, ncol = 1)) -}) - -test_that("max_constraint_output throws error for dimension mismatch", { - output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - labels <- torch_ones(c(2, 3), dtype = torch_bool()) - ancestor <- torch_eye(2) - expect_error(max_constraint_output(output, labels, ancestor), "dimension") -}) - -test_that("max_constraint_output handles float labels without error", { - # torch_logical_not works on float tensors (0.0 -> TRUE, others -> FALSE) - # No explicit type check exists in the function, so it should run successfully - output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - labels <- torch_ones(c(2, 2), dtype = torch_float32()) - ancestor <- torch_eye(2) - expect_silent(max_constraint_output(output, labels, ancestor)) - result <- max_constraint_output(output, labels, ancestor) - expect_tensor_shape(result, c(2, 2)) -}) - -test_that("get_constr_output and max_constraint_output compose correctly", { - output <- torch_tensor(matrix(c(1, 4, - 2, 3), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(TRUE, FALSE, - TRUE, FALSE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, - 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - direct <- max_constraint_output(output, labels, ancestor) - constr_out <- get_constr_output(output, ancestor) - train_out <- get_constr_output(labels * output, ancestor) - manual <- torch_logical_not(labels) * constr_out + labels * train_out - expect_equal_to_r(direct, as_array(manual)) -}) +# test_that("max_constraint_output returns original output when ancestor is identity", { +# output <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) +# labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, +# FALSE, TRUE, FALSE), nrow = 2, ncol = 3), dtype = torch_bool()) +# ancestor <- torch::torch_eye(3) +# result <- max_constraint_output(output, labels, ancestor) +# expect_tensor_shape(result, c(2, 3)) +# # With an identity ancestor matrix, constraint propagation is neutral. +# # The formula simplifies to: (~labels * output) + (labels * output) == output +# expect_equal_to_r(result, matrix(1:6, nrow = 2, ncol = 3)) +# }) +# +# test_that("max_constraint_output applies constraint to positive labels", { +# output <- torch_tensor(matrix(c(1, 5, +# 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) +# labels <- torch_tensor(matrix(c(1, 0, +# 1, 0), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) +# ancestor <- torch_tensor(matrix(c(1, 1, +# 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) +# result <- max_constraint_output(output, labels, ancestor) +# expect_tensor_shape(result, c(2, 2)) +# # Unlabelled positions get propagated raw max, labelled get propagated masked max +# expected <- matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) +# expect_equal_to_r(result, expected) +# }) +# +# test_that("max_constraint_output handles all-zero labels", { +# output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) +# labels <- torch::torch_zeros(c(2, 2), dtype = torch_bool()) +# ancestor <- torch::torch_eye(2) +# result <- max_constraint_output(output, labels, ancestor) +# # With all false labels, result equals constr_output. With identity ancestor, constr_output == output +# expect_equal_to_r(result, matrix(1:4, nrow = 2, ncol = 2)) +# }) +# +# test_that("max_constraint_output handles all-one labels", { +# output <- torch_tensor(matrix(c(1, 5, +# 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) +# labels <- torch::torch_ones(c(2, 2), dtype = torch_bool()) +# ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) +# result <- max_constraint_output(output, labels, ancestor) +# expect_tensor_shape(result, c(2, 2)) +# # When all labels are TRUE, (~labels) is 0, so result = train_output. +# expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) +# expect_equal_to_r(result, expected) +# }) +# +# test_that("max_constraint_output preserves output dtype", { +# output_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float32()) +# output_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float64()) +# labels <- torch::torch_ones(c(2, 2), dtype = torch_bool()) +# ancestor <- torch::torch_eye(2) +# expect_tensor_dtype(max_constraint_output(output_f32, labels, ancestor), torch_float64()) +# expect_tensor_dtype(max_constraint_output(output_f64, labels, ancestor), torch_float64()) +# }) +# +# +# test_that("max_constraint_output works with complex hierarchy", { +# output <- torch_tensor(matrix(c(1, 2, 3, +# 4, 5, 6), nrow = 2, ncol = 3, byrow = TRUE)) +# labels <- torch_tensor(matrix(c(1, 0, 0, +# 0, 1, 0), nrow = 2, ncol = 3, byrow = TRUE), dtype = torch_bool()) +# ancestor <- torch_triu(torch_ones(c(3,3))) +# result <- max_constraint_output(output, labels, ancestor) +# expect_tensor_shape(result, c(2, 3)) +# # Row 1: label on col 1 -> train_output[1,1]=1, others get constr_output=3 +# # Row 2: label on col 2 -> train_output[2,2]=5, others get constr_output=6 +# expected <- matrix(c(1, 3, 3, +# 6, 5, 6), nrow = 2, ncol = 3, byrow = TRUE) +# expect_equal_to_r(result, expected) +# }) +# +# test_that("max_constraint_output handles single element tensors", { +# output <- torch_tensor(matrix(5, nrow = 1, ncol = 1)) +# labels <- torch_tensor(matrix(TRUE, nrow = 1, ncol = 1), dtype = torch_bool()) +# ancestor <- torch_tensor(matrix(1, nrow = 1, ncol = 1)) +# result <- max_constraint_output(output, labels, ancestor) +# expect_tensor_shape(result, c(1, 1)) +# # Compare against 1x1 matrix instead of scalar to match torch array output +# expect_equal_to_r(result, matrix(5, nrow = 1, ncol = 1)) +# }) +# +# test_that("max_constraint_output throws error for dimension mismatch", { +# output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) +# labels <- torch::torch_ones(c(2, 3), dtype = torch_bool()) +# ancestor <- torch::torch_eye(2) +# expect_error(max_constraint_output(output, labels, ancestor), "dimension") +# }) +# +# test_that("max_constraint_output handles float labels without error", { +# # torch_logical_not works on float tensors (0.0 -> TRUE, others -> FALSE) +# # No explicit type check exists in the function, so it should run successfully +# output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) +# labels <- torch::torch_ones(c(2, 2), dtype = torch::torch_float32()) +# ancestor <- torch::torch_eye(2) +# expect_silent(max_constraint_output(output, labels, ancestor)) +# result <- max_constraint_output(output, labels, ancestor) +# expect_tensor_shape(result, c(2, 2)) +# }) +# +# test_that("get_constr_output and max_constraint_output compose correctly", { +# output <- torch_tensor(matrix(c(1, 4, +# 2, 3), nrow = 2, ncol = 2, byrow = TRUE)) +# labels <- torch_tensor(matrix(c(TRUE, FALSE, +# TRUE, FALSE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) +# ancestor <- torch_tensor(matrix(c(1, 1, +# 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) +# direct <- max_constraint_output(output, labels, ancestor) +# constr_out <-get_constr_output(output, ancestor) +# train_out <-get_constr_output(labels * output, ancestor) +# manual <- torch_logical_not(labels) * constr_out + labels * train_out +# expect_equal_to_r(direct, as_array(manual)) +# }) test_that("get_constr_output handles negative values correctly", { x <- torch_tensor(matrix(c(-5, -1, @@ -215,18 +215,18 @@ test_that("get_constr_output handles negative values correctly", { expect_equal_to_r(result, expected) }) -test_that("max_constraint_output handles mixed positive-negative with constraints", { - output <- torch_tensor(matrix(c(-5, -3, - -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) - labels <- torch_tensor(matrix(c(TRUE, TRUE, - FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) - ancestor <- torch_tensor(matrix(c(1, 1, - 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - result <- max_constraint_output(output, labels, ancestor) - expected <- matrix(c(-3, 0, - 4, 4), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected) -}) +# test_that("max_constraint_output handles mixed positive-negative with constraints", { +# output <- torch_tensor(matrix(c(-5, -3, +# -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) +# labels <- torch_tensor(matrix(c(TRUE, TRUE, +# FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch::torch_bool()) +# ancestor <- torch_tensor(matrix(c(1, 1, +# 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) +# result <- max_constraint_output(output, labels, ancestor) +# expected <- matrix(c(-3, 0, +# 4, 4), nrow = 2, ncol = 2, byrow = TRUE) +# expect_equal_to_r(result, expected) +# }) test_that("build_ancestor_matrix handles basic unrelated hierarchy as a diag matrix", { tree_df <- data.frame(pathString = c("Root/A/C1", "Root/A/C2","Root/B/D1", "Root/B/D2")) diff --git a/vignettes/Hierarchical_classification.Rmd b/vignettes/Hierarchical_classification.Rmd index e4f804d9..b2af4229 100644 --- a/vignettes/Hierarchical_classification.Rmd +++ b/vignettes/Hierarchical_classification.Rmd @@ -98,13 +98,21 @@ The tree should have a single root for all nodes to be consistent. Thus you have The classification will be done **removing the first level of hierarchy** in any case. +### Ensure there is no **missing values** in the hierarchical classes + +Missing values should be replaced. Turning them by an explicit "Unknown_something" is a good approach. + + Now let's have all those rules applied to the `starwars_tree` : ```{r} # demonstration of reserved column modification in Node construction starwars_tree <- starwars %>% rename(`_name` = "name", `_height` = "height") %>% - mutate(pathString = paste("StarWars_characters", species, sex, `_name`, sep = "/")) %>% + mutate( + species = coalesce(species, "Unknown_Species"), + sex = coalesce(sex, "Unknown_Sex"), + pathString = paste("StarWars_characters", species, sex, `_name`, sep = "/")) %>% as.Node() print(starwars_tree, "name", "_name","_height", "mass", "eye_color", limit = 8) ``` From d288e3130983a1abb9b84d3aa65f08ea7653b8b5 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Thu, 4 Jun 2026 00:28:40 +0200 Subject: [PATCH 15/21] fix hardhat_interfaces tests. --- R/hardhat.R | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/R/hardhat.R b/R/hardhat.R index 46513b1a..9ff55180 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -416,14 +416,13 @@ tabnet_bridge <- function(processed, config = tabnet_config(), tabnet_model, fro predict.tabnet_fit <- function(object, new_data, type = NULL, ..., epoch = NULL) { if (inherits(new_data, "Node") && !is.null(object$fit$config$ancestor)) { new_data_df <- node_to_df(new_data)$x - require_contraint_output <- TRUE + processed <- hardhat::forge(new_data_df, object$blueprint) + # Enforces column order, type, column names, etc + processed$predictors <- get_constr_output(processed$predictors, object$fit$config$ancestor) + } else { new_data_df <- new_data - } - # Enforces column order, type, column names, etc - processed <- hardhat::forge(new_data_df, object$blueprint) - if (require_contraint_output) { - processed$predictors <- get_constr_output(processed$predictors, object$fit$config$ancestor) + processed <- hardhat::forge(new_data, object$blueprint) } batch_size <- object$fit$config$batch_size out <- predict_tabnet_bridge(type, object, processed$predictors, epoch, batch_size) From 746c9a648e31149982c87d6eff67f80cc1463586 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sat, 6 Jun 2026 19:01:07 +0200 Subject: [PATCH 16/21] buil_ancestor_matrix is now build_ancestor_matrix_from_outcomes get_constr_output and nnf_multilabel_one_hot are moved in loss.R --- DESCRIPTION | 1 + NAMESPACE | 3 +- R/hardhat.R | 91 ++++---- R/loss.R | 61 ++++- R/model_training.R | 44 ++-- R/utils.R | 28 --- man/build_ancestor_matrix.Rd | 31 --- man/build_ancestor_matrix_from_outcomes.Rd | 23 ++ man/get_constr_output.Rd | 2 +- man/nn_mc_loss.Rd | 4 +- man/nnf_multilabel_one_hot.Rd | 23 ++ man/node_to_df.Rd | 18 +- tests/testthat/test-hardhat_hierarchical.R | 4 +- tests/testthat/test-hierarchical_utils.R | 254 +-------------------- tests/testthat/test-loss.R | 102 +++++++++ 15 files changed, 292 insertions(+), 397 deletions(-) delete mode 100644 man/build_ancestor_matrix.Rd create mode 100644 man/build_ancestor_matrix_from_outcomes.Rd create mode 100644 man/nnf_multilabel_one_hot.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 93bc2b5a..d8976843 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,6 +46,7 @@ Imports: zeallot Suggests: cli, + fBasics, knitr, modeldata, patchwork, diff --git a/NAMESPACE b/NAMESPACE index 7480a26c..ccd9e976 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,7 +24,7 @@ S3method(tabnet_pretrain,recipe) S3method(update,tabnet) export("%>%") export(attention_width) -export(build_ancestor_matrix) +export(build_ancestor_matrix_from_outcomes) export(cat_emb_dim) export(check_compliant_node) export(checkpoint_epochs) @@ -42,6 +42,7 @@ export(momentum) export(nn_aum_loss) export(nn_mc_loss) export(nnf_mc_loss) +export(nnf_multilabel_one_hot) export(node_to_df) export(num_independent) export(num_independent_decoder) diff --git a/R/hardhat.R b/R/hardhat.R index 9ff55180..eeb4139c 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -168,7 +168,8 @@ tabnet_fit.Node <- function(x, tabnet_model = NULL, config = tabnet_config(), .. # add ancestor boolean sparse matrix to config # check_dag_compliance(xy_df$y) config$ancestor <- build_ancestor_matrix(x) - + # make outcomes levels available so that batched y could be one-hot encoded. + config$outcomes <- processed$outcomes tabnet_bridge(processed, config = config, tabnet_model, from_epoch, task = "supervised") } @@ -606,49 +607,51 @@ nn_prune_head.tabnet_pretrain <- function(x, head_size) { } -#' Build ancestor-descendant matrix for class hierarchy from data.tree Node -#' -#' Extracts class nodes (non-root, non-leaf) from a hierarchical tree where -#' leaves contain observations and intermediate nodes represent class categories. -#' Computes the transitive closure: `R[i, j] = 1` if class i is a descendant -#' of class j (including self-loops). Matches the output orientation of the -#' provided Python/NetworkX snippet. -#' -#' @param x A `data.tree::Node` object representing the hierarchy. -#' Leaves should contain individual observations; intermediate nodes -#' represent class categories (e.g., Department, JobRole). -#' @param device Target device for the output tensor (e.g., "cpu", "cuda"). -#' @param keep_levels Optional integer vector. If provided, only nodes at -#' these levels are treated as classes. If `NULL`, all non-root/non-leaf -#' nodes are kept. -#' @return A `torch_tensor` of shape `(1, n_classes, n_classes)` with dtype -#' `torch_double`, where `R[i, j] <- 1` if class `i` is a descendant of -#' class `j` (including when `i == j`). -#' @importFrom torch torch_tensor torch_double + +#' Build ancestor matrix aligned with observed outcome classes +#' +#' Extracts class names from the outcome tibble (factor levels) and builds +#' the ancestor matrix only for classes that actually appear in the data. +#' +#' @param x A `data.tree::Node` object. +#' @param outcomes A tibble with factor columns (one per hierarchy level), +#' as returned by `hardhat::mold()$outcomes`. +#' @param device Torch device ("cpu" or "cuda"). +#' @return A `torch_tensor` of shape `(1, n_classes, n_classes)`. #' @export -build_ancestor_matrix <- function(x, device = "cpu", keep_levels = NULL) { - # 1. Traverse all nodes - all_nodes <- data.tree::Traverse(x, traversal = "pre-order") - all_nodes <- unname(all_nodes) - - # 2. Filter nodes - is_class <- vapply(all_nodes, function(n) { - !n$isRoot && !n$isLeaf && - (is.null(keep_levels) || n$level %in% keep_levels) - }, logical(1)) - - class_nodes <- all_nodes[is_class] - n_classes <- length(class_nodes) +build_ancestor_matrix_from_outcomes <- function(x, outcomes, device = "cpu") { + # 1. Extract all class names from factor levels (preserving order) + # outcomes is a tibble with one factor column per hierarchy level + level_cols <- names(outcomes) + all_class_names <- unlist(lapply(outcomes, levels), use.names = FALSE) + n_classes <- length(all_class_names) if (n_classes == 0L) { - return(torch::torch_zeros(1L, 0L, 0L, dtype = torch::torch_double(), device = device)) + runtime_error("No factor levels found in outcomes : {str(outcomes)}") } - # 3. safe mapping using pathString as unique key - class_paths <- vapply(class_nodes, `[[`, "pathString", FUN.VALUE = character(1)) - class_map <- setNames(seq_len(n_classes), class_paths) + # 2. Build a lookup: class_name -> data.tree Node + all_nodes <- data.tree::Traverse(x, traversal = "pre-order") + all_nodes <- unname(all_nodes) + level_lengths <- lengths(lapply(outcomes, levels)) + lvl_vector <- rep(seq_along(level_cols) + 1L, level_lengths) + + # 3. Resolve each class name to its Node + class_nodes <- lapply(seq_along(all_class_names), function(k) { + nm <- all_class_names[k] + lvl <- lvl_vector[k] + + candidates <- Filter(function(n) n$level == lvl && n$name == nm, all_nodes) + if (length(candidates) == 0) { + runtime_error("Factor level {.var {nm}} not found at tree level {lvl} (outcomes column {.var {level_cols[lvl - 1L]}})") + } + candidates[[1]] + }) + + # 4. Create 1-based index mapping + class_map <- setNames(seq_len(n_classes), all_class_names) - # 4. Collect (descendant, ancestor) pairs + # 5. Collect (descendant, ancestor) pairs by climbing up row_list <- vector("list", n_classes) col_list <- vector("list", n_classes) @@ -657,9 +660,8 @@ build_ancestor_matrix <- function(x, device = "cpu", keep_levels = NULL) { anc_indices <- integer() repeat { - # Lookup using unique pathString - idx <- class_map[current$pathString] - if (!is.na(idx)) { + idx <- class_map[current$name] + if (!is.null(idx)) { anc_indices <- c(anc_indices, idx) } if (current$isRoot || is.null(current$parent)) break @@ -670,13 +672,14 @@ build_ancestor_matrix <- function(x, device = "cpu", keep_levels = NULL) { col_list[[i]] <- anc_indices } - # 5. Fill matrix + # 6. Fill matrix R <- matrix(0L, nrow = n_classes, ncol = n_classes) rows <- unlist(row_list, use.names = FALSE) cols <- unlist(col_list, use.names = FALSE) if (length(rows) > 0) R[cbind(rows, cols)] <- 1L - # 6. Convert to torch + # 7. Convert to torch R_torch <- torch::torch_tensor(R, dtype = torch::torch_double(), device = device) R_torch$unsqueeze(1) -} \ No newline at end of file +} + diff --git a/R/loss.R b/R/loss.R index fb4b3b62..98b359c0 100644 --- a/R/loss.R +++ b/R/loss.R @@ -193,7 +193,7 @@ nnf_mc_loss <- function(output, target, R, to_eval = NULL, #' @examples #' \dontrun{ #' # Build ancestor matrix from hierarchy -#' R <- build_ancestor_matrix(my_tree, device = "cuda") +#' R <- build_ancestor_matrix_from_outcomes(my_tree, processed$outcomes, device = "cuda") #' #' # Create loss module #' loss_fn <- nn_mc_loss(R = R, reduction = "mean") @@ -204,7 +204,7 @@ nnf_mc_loss <- function(output, target, R, to_eval = NULL, #' loss$backward() #' } #' -#' @seealso [nnf_mc_loss()], [build_ancestor_matrix()], [get_constr_output()] +#' @seealso [nnf_mc_loss()], [build_ancestor_matrix_from_outcomes()], [get_constr_output()] #' @export nn_mc_loss <- nn_module( "nn_mc_loss", @@ -240,3 +240,60 @@ nn_mc_loss <- nn_module( ) } ) + +#' Apply hierarchy constraints via max-pooling over descendants (MCM) +#' +#' Given neural network outputs x and ancestor matrix R, enforces that +#' if a class is predicted positive, all its ancestors must also be positive. +#' Implements: `final_out[i] = max{x[j] : R[i,j] = 1}` +#' +#' @param x A `torch_tensor` of shape `(batch_size, n_classes)`. +#' @param R A `torch_tensor` of shape `(1, n_classes, n_classes)` where +#' `R[1, i, j] = 1` iff class `i` is a descendant of class `j`. +#' @return A `torch_tensor` of shape `(batch_size, n_classes)` with constrained outputs. +#' @importFrom torch torch_max torch_double +get_constr_output <- function(x, R) { + c_out <- x$to(dtype = torch_double())$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) + R_batch <- R$expand(c(x$shape[1], R$shape[2], R$shape[2])) + final_out <- torch_max(torch_matmul(R_batch, c_out), dim = 3) + final_out[[1]] +} + + +#' Convert class_id tensor to binary one-hot tensor +#' +#' Transforms a tensor of class indices (one column per hierarchy level) +#' into a binary tensor where each column corresponds to a class. +#' +#' @param y A `torch_tensor` of shape `(batch_size, n_levels)` containing +#' 1-based class indices. +#' @param outcomes A tibble with factor columns (as from `hardhat::mold()$outcomes`). +#' @param device Torch device. +#' @return A `torch_tensor` of shape `(batch_size, n_classes)` with binary values. +#' @export +nnf_multilabel_one_hot <- function(y, outcomes, device = "cpu") { + batch_size <- y$shape[1] + n_levels <- y$shape[2] + + # Number of classes per level + n_per_level <- lengths(lapply(outcomes, levels)) + n_classes <- sum(n_per_level) + + one_hot_list <- vector("list", n_levels) + + for (lvl in seq_len(n_levels)) { + level_ids <- y[, lvl]$to(dtype = torch::torch_long()) + + # Encode one-hot of each levels + one_hot_list[[lvl]] <- torch::nnf_one_hot( + level_ids, + num_classes = n_per_level[lvl] + ) + } + # concatenate along the columns axis) + torch::torch_cat(one_hot_list, dim = 2)$to( + dtype = torch::torch_double(), + device = device + ) +} + diff --git a/R/model_training.R b/R/model_training.R index ff1d3427..f57984a6 100644 --- a/R/model_training.R +++ b/R/model_training.R @@ -227,30 +227,6 @@ tabnet_config <- function(batch_size = 1024^2, ) } -#' Apply hierarchy constraints via max-pooling over descendants (MCM) -#' -#' Given neural network outputs x and ancestor matrix R, enforces that -#' if a class is predicted positive, all its ancestors must also be positive. -#' Implements: `final_out[i] = max{x[j] : R[i,j] = 1}` -#' -#' @param x A `torch_tensor` of shape `(batch_size, n_classes)`. -#' @param R A `torch_tensor` of shape `(1, n_classes, n_classes)` where -#' `R[1, i, j] = 1` iff class `i` is a descendant of class `j`. -#' @return A `torch_tensor` of shape `(batch_size, n_classes)` with constrained outputs. -#' @importFrom torch torch_max torch_double -get_constr_output <- function(x, R) { - c_out <- x$to(dtype = torch_double())$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) - R_batch <- R$expand(c(x$shape[1], R$shape[2], R$shape[2])) - final_out <- torch_max(R_batch * c_out, dim = 3) - final_out[[1]] -} - -# max_constraint_output <- function(output, labels, ancestor) { -# constr_output <- get_constr_output(output, ancestor) -# train_output <- get_constr_output(labels * output, ancestor) -# torch::torch_logical_not(labels) * constr_output + labels * train_output -# } - resolve_loss <- function(config, dtype) { loss <- config$loss @@ -290,7 +266,7 @@ train_batch <- function(network, optimizer, batch, config) { # if target is multi-outcome but not max_constraint loss, loss has to be applied to each label-group if (max(batch$output_dim$shape) > 1 && is.null(config$ancestor)) { - # multi-outcome + # standard multi-outcome outcome_nlevels <- as.numeric(batch$output_dim$to(device="cpu")) # use `resolved_loss` @@ -302,6 +278,13 @@ train_batch <- function(network, optimizer, batch, config) { ~config$loss_fn(.x, .y$squeeze(2)) )), dim = 1) + } else if (!is.null(config$ancestor)) { + # multi-outcome max_constraint loss ned one-hot encoding of targets + loss <- config$loss_fn(out, nnf_multilabel_one_hot( + y = batch$y, + outcomes = config$outcomes, + device = out$device + )) } else if (batch$y$dtype == torch::torch_long()) { # classifier needs a squeeze for bce loss loss <- config$loss_fn(out, batch$y$squeeze(2)) @@ -330,8 +313,8 @@ valid_batch <- function(network, batch, config) { # forward pass c(out, M_loss) %<-% network(batch$x, batch$x_na_mask) # loss has to be applied to each label-group when output_dim is a vector - if (max(batch$output_dim$shape) > 1) { - # multi-outcome + if (max(batch$output_dim$shape) > 1 && is.null(config$ancestor)) { + # standard multi-outcome outcome_nlevels <- as.numeric(batch$output_dim$to(device="cpu")) # use `resolved_loss` loss <- torch::torch_sum(torch::torch_stack(purrr::pmap( @@ -343,6 +326,13 @@ valid_batch <- function(network, batch, config) { )), dim = 1) + } else if (!is.null(config$ancestor)) { + # multi-outcome max_constraint loss ned one-hot encoding of targets + loss <- config$loss_fn(out, nnf_multilabel_one_hot( + y = batch$y, + outcomes = config$outcomes, + device = out$device + )) } else { if (batch$y$dtype == torch::torch_long()) { # classifier needs a squeeze for bce loss diff --git a/R/utils.R b/R/utils.R index 4c725b13..9526a145 100644 --- a/R/utils.R +++ b/R/utils.R @@ -79,34 +79,6 @@ check_compliant_node <- function(node) { invisible(node) } -#' Check that the multi outcomes makes a DAG -#' -#' @param y the y dataframe as the result of `node_to_df(x)$y` -#' -#' @return y if it is compliant, else an Error with the column names to fix -#' @export -#' -#' @examplesIf (require("data.tree") || require("dplyr")) -#' library(dplyr) -#' library(data.tree) -#' data(starwars) -#' starwars_tree_y <- starwars %>% select(species, homeworld) -#' -#' try(check_dag_compliance(starwars_tree_y)) -#' -# check_dag_compliance <- function(y) { -# actual_names <- names(y) -# if (any(actual_names %in% reserved_names)) { -# value_error("The attributes or colnames in the provided hierarchical object use the following reserved names: -# {.vars {actual_names[actual_names %in% reserved_names]}}. -# Please change those names as they will lead to unexpected tabnet behavior.") -# } -# -# -# -# -# invisible(node) -# } #' Turn a Node object into predictor and outcome. #' diff --git a/man/build_ancestor_matrix.Rd b/man/build_ancestor_matrix.Rd deleted file mode 100644 index 9b67b71b..00000000 --- a/man/build_ancestor_matrix.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hardhat.R -\name{build_ancestor_matrix} -\alias{build_ancestor_matrix} -\title{Build ancestor-descendant matrix for class hierarchy from data.tree Node} -\usage{ -build_ancestor_matrix(x, device = "cpu", keep_levels = NULL) -} -\arguments{ -\item{x}{A \code{data.tree::Node} object representing the hierarchy. -Leaves should contain individual observations; intermediate nodes -represent class categories (e.g., Department, JobRole).} - -\item{device}{Target device for the output tensor (e.g., "cpu", "cuda").} - -\item{keep_levels}{Optional integer vector. If provided, only nodes at -these levels are treated as classes. If \code{NULL}, all non-root/non-leaf -nodes are kept.} -} -\value{ -A \code{torch_tensor} of shape \verb{(1, n_classes, n_classes)} with dtype -\code{torch_double}, where \code{R[i, j] <- 1} if class \code{i} is a descendant of -class \code{j} (including when \code{i == j}). -} -\description{ -Extracts class nodes (non-root, non-leaf) from a hierarchical tree where -leaves contain observations and intermediate nodes represent class categories. -Computes the transitive closure: \code{R[i, j] = 1} if class i is a descendant -of class j (including self-loops). Matches the output orientation of the -provided Python/NetworkX snippet. -} diff --git a/man/build_ancestor_matrix_from_outcomes.Rd b/man/build_ancestor_matrix_from_outcomes.Rd new file mode 100644 index 00000000..96ab70ac --- /dev/null +++ b/man/build_ancestor_matrix_from_outcomes.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hardhat.R +\name{build_ancestor_matrix_from_outcomes} +\alias{build_ancestor_matrix_from_outcomes} +\title{Build ancestor matrix aligned with observed outcome classes} +\usage{ +build_ancestor_matrix_from_outcomes(x, outcomes, device = "cpu") +} +\arguments{ +\item{x}{A \code{data.tree::Node} object.} + +\item{outcomes}{A tibble with factor columns (one per hierarchy level), +as returned by \code{hardhat::mold()$outcomes}.} + +\item{device}{Torch device ("cpu" or "cuda").} +} +\value{ +A \code{torch_tensor} of shape \verb{(1, n_classes, n_classes)}. +} +\description{ +Extracts class names from the outcome tibble (factor levels) and builds +the ancestor matrix only for classes that actually appear in the data. +} diff --git a/man/get_constr_output.Rd b/man/get_constr_output.Rd index 0ca355ea..92941eb2 100644 --- a/man/get_constr_output.Rd +++ b/man/get_constr_output.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model_training.R +% Please edit documentation in R/loss.R \name{get_constr_output} \alias{get_constr_output} \title{Apply hierarchy constraints via max-pooling over descendants (MCM)} diff --git a/man/nn_mc_loss.Rd b/man/nn_mc_loss.Rd index 4c21cffc..eb3dee75 100644 --- a/man/nn_mc_loss.Rd +++ b/man/nn_mc_loss.Rd @@ -39,7 +39,7 @@ where C' is the number of evaluated classes \examples{ \dontrun{ # Build ancestor matrix from hierarchy -R <- build_ancestor_matrix(my_tree, device = "cuda") +R <- build_ancestor_matrix_from_outcomes(my_tree, processed$outcomes, device = "cuda") # Create loss module loss_fn <- nn_mc_loss(R = R, reduction = "mean") @@ -52,5 +52,5 @@ loss$backward() } \seealso{ -\code{\link[=nnf_mc_loss]{nnf_mc_loss()}}, \code{\link[=build_ancestor_matrix]{build_ancestor_matrix()}}, \code{\link[=get_constr_output]{get_constr_output()}} +\code{\link[=nnf_mc_loss]{nnf_mc_loss()}}, \code{\link[=build_ancestor_matrix_from_outcomes]{build_ancestor_matrix_from_outcomes()}}, \code{\link[=get_constr_output]{get_constr_output()}} } diff --git a/man/nnf_multilabel_one_hot.Rd b/man/nnf_multilabel_one_hot.Rd new file mode 100644 index 00000000..aceee864 --- /dev/null +++ b/man/nnf_multilabel_one_hot.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loss.R +\name{nnf_multilabel_one_hot} +\alias{nnf_multilabel_one_hot} +\title{Convert class_id tensor to binary one-hot tensor} +\usage{ +nnf_multilabel_one_hot(y, outcomes, device = "cpu") +} +\arguments{ +\item{y}{A \code{torch_tensor} of shape \verb{(batch_size, n_levels)} containing +1-based class indices.} + +\item{outcomes}{A tibble with factor columns (as from \code{hardhat::mold()$outcomes}).} + +\item{device}{Torch device.} +} +\value{ +A \code{torch_tensor} of shape \verb{(batch_size, n_classes)} with binary values. +} +\description{ +Transforms a tensor of class indices (one column per hierarchy level) +into a binary tensor where each column corresponds to a class. +} diff --git a/man/node_to_df.Rd b/man/node_to_df.Rd index 75d97c24..79e9002d 100644 --- a/man/node_to_df.Rd +++ b/man/node_to_df.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/utils.R \name{node_to_df} \alias{node_to_df} -\title{Check that the multi outcomes makes a DAG} +\title{Turn a Node object into predictor and outcome.} \usage{ node_to_df(x, drop_last_level = TRUE) } @@ -10,33 +10,19 @@ node_to_df(x, drop_last_level = TRUE) \item{x}{Node object} \item{drop_last_level}{TRUE unused} - -\item{y}{the y dataframe as the result of \code{node_to_df(x)$y}} } \value{ -y if it is compliant, else an Error with the column names to fix - a named list of x and y, being respectively the predictor data-frame and the outcomes data-frame, as expected inputs for \code{hardhat::mold()} function. } \description{ -Check that the multi outcomes makes a DAG +Turn a Node object into predictor and outcome. } \examples{ \dontshow{if ((require("data.tree") || require("dplyr"))) withAutoprint(\{ # examplesIf} library(dplyr) library(data.tree) data(starwars) -starwars_tree_y <- starwars \%>\% select(species, homeworld) - -try(check_dag_compliance(starwars_tree_y)) - -Turn a Node object into predictor and outcome. -\dontshow{\}) # examplesIf} -\dontshow{if ((require("data.tree") || require("dplyr"))) withAutoprint(\{ # examplesIf} -library(dplyr) -library(data.tree) -data(starwars) starwars_tree <- starwars \%>\% mutate(pathString = paste("tree", species, homeworld, `name`, sep = "/")) \%>\% as.Node() diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index 88fc6b71..e0ce1972 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -73,9 +73,7 @@ test_that("Training hierarchical classification for {data.tree} Node for starwar pathString = paste("StarWars_characters", species, sex, `_name`, sep = "/")) %>% as.Node() - expect_error( - check_compliant_node(starwars_tree) - ,"reserved names") + expect_no_error(check_compliant_node(starwars_tree)) fit <- tabnet_fit(starwars_tree, epochs = 1) }) diff --git a/tests/testthat/test-hierarchical_utils.R b/tests/testthat/test-hierarchical_utils.R index 97020dd7..4216a300 100644 --- a/tests/testthat/test-hierarchical_utils.R +++ b/tests/testthat/test-hierarchical_utils.R @@ -1,273 +1,43 @@ -test_that("get_constr_output handles basic 2D input with identity constraint", { - m <- matrix(c(1, 2, - 3, 4), nrow = 2, ncol = 2) - x <- torch_tensor(m, dtype = torch::torch_float32()) - R <- torch::torch_eye(2, dtype = torch::torch_float32()) - result <-get_constr_output(x, R) - expect_tensor(result) - expect_tensor_shape(result, c(2, 2)) - expect_equal_to_r(result, m) -}) - -test_that("get_constr_output applies hierarchy constraint correctly", { - x <- torch_tensor(matrix(c(1, 5, - 3, 2), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch::torch_float64()) - R <- torch_tensor(matrix(c(1, 1, - 0, 1), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch::torch_float64()) - result <-get_constr_output(x, R) - expect_tensor_shape(result, c(2, 2)) - expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected, tolerance = 1e-6) -}) - -test_that("get_constr_output preserves input dtype", { - x_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float32()) - x_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float64()) - R <- torch::torch_eye(2) - expect_tensor_dtype(get_constr_output(x_f32, R), torch::torch_float64()) - expect_tensor_dtype(get_constr_output(x_f64, R), torch::torch_float64()) -}) - -test_that("get_constr_output handles batch dimension correctly", { - x <- torch_tensor(matrix(1:12, nrow = 3, ncol = 4)) - R <- torch_tensor(matrix(c(1, 1, 0, 0, - 1, 1, 0, 0, - 0, 0, 1, 1, - 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) - result <-get_constr_output(x, R) - expect_tensor_shape(result, c(3, 4)) - - for (i in 1:3) { - row_result <- as_array(result[i, ]) - max_grp1 <- max(as_array(x[i, 1:2])) - max_grp2 <- max(as_array(x[i, 3:4])) - - expect_equal(row_result[1:2], rep(max_grp1, 2), tolerance = 1e-6) - expect_equal(row_result[3:4], rep(max_grp2, 2), tolerance = 1e-6) - } -}) -test_that("get_constr_output works with single sample", { - x <- torch_tensor(matrix(c(2, 1, 4, 3), nrow = 1, ncol = 4, byrow = TRUE)) - R <- torch_tensor(matrix(c(1, 1, 0, 0, - 1, 1, 0, 0, - 0, 0, 1, 1, - 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) - result <-get_constr_output(x, R) - expect_tensor_shape(result, c(1, 4)) - expected <- matrix(c(2, 2, 4, 4), nrow = 1, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -test_that("get_constr_output handles all-zeros constraint matrix", { - x <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) - R <- torch::torch_zeros(c(3, 3)) - result <-get_constr_output(x, R) - expect_tensor_shape(result, c(2, 3)) - expect_equal_to_r(result, matrix(0, nrow = 2, ncol = 3)) -}) - -test_that("get_constr_output handles all-ones constraint matrix", { - x <- torch_tensor(matrix(c(1, 5, 3, - 2, 4, 6), nrow = 2, ncol = 3, byrow = TRUE)) - R <- torch::torch_ones(c(3, 3)) - result <-get_constr_output(x, R) - expect_tensor_shape(result, c(2, 3)) - # Each row is filled with its own row-wise maximum - expected <- matrix(c(5, 5, 5, - 6, 6, 6), nrow = 2, ncol = 3, byrow = TRUE) - expect_equal_to_r(result, expected, tolerance = 1e-6) -}) - -test_that("get_constr_output throws error for dimension mismatch", { - x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - R <- torch::torch_eye(3) - expect_error(get_constr_output(x, R), "must match the existing size") -}) - -test_that("get_constr_output throws error for non-2D R", { - x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) - R <- torch_tensor(array(1:8, dim = c(1, 2, 2, 2))) - expect_error(get_constr_output(x, R), "dimension") -}) - -# test_that("max_constraint_output returns original output when ancestor is identity", { -# output <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) -# labels <- torch_tensor(matrix(c(TRUE, FALSE, TRUE, -# FALSE, TRUE, FALSE), nrow = 2, ncol = 3), dtype = torch_bool()) -# ancestor <- torch::torch_eye(3) -# result <- max_constraint_output(output, labels, ancestor) -# expect_tensor_shape(result, c(2, 3)) -# # With an identity ancestor matrix, constraint propagation is neutral. -# # The formula simplifies to: (~labels * output) + (labels * output) == output -# expect_equal_to_r(result, matrix(1:6, nrow = 2, ncol = 3)) -# }) -# -# test_that("max_constraint_output applies constraint to positive labels", { -# output <- torch_tensor(matrix(c(1, 5, -# 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) -# labels <- torch_tensor(matrix(c(1, 0, -# 1, 0), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) -# ancestor <- torch_tensor(matrix(c(1, 1, -# 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) -# result <- max_constraint_output(output, labels, ancestor) -# expect_tensor_shape(result, c(2, 2)) -# # Unlabelled positions get propagated raw max, labelled get propagated masked max -# expected <- matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) -# expect_equal_to_r(result, expected) -# }) -# -# test_that("max_constraint_output handles all-zero labels", { -# output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) -# labels <- torch::torch_zeros(c(2, 2), dtype = torch_bool()) -# ancestor <- torch::torch_eye(2) -# result <- max_constraint_output(output, labels, ancestor) -# # With all false labels, result equals constr_output. With identity ancestor, constr_output == output -# expect_equal_to_r(result, matrix(1:4, nrow = 2, ncol = 2)) -# }) -# -# test_that("max_constraint_output handles all-one labels", { -# output <- torch_tensor(matrix(c(1, 5, -# 3, 2), nrow = 2, ncol = 2, byrow = TRUE)) -# labels <- torch::torch_ones(c(2, 2), dtype = torch_bool()) -# ancestor <- torch_tensor(matrix(c(1, 1, 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) -# result <- max_constraint_output(output, labels, ancestor) -# expect_tensor_shape(result, c(2, 2)) -# # When all labels are TRUE, (~labels) is 0, so result = train_output. -# expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) -# expect_equal_to_r(result, expected) -# }) -# -# test_that("max_constraint_output preserves output dtype", { -# output_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float32()) -# output_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float64()) -# labels <- torch::torch_ones(c(2, 2), dtype = torch_bool()) -# ancestor <- torch::torch_eye(2) -# expect_tensor_dtype(max_constraint_output(output_f32, labels, ancestor), torch_float64()) -# expect_tensor_dtype(max_constraint_output(output_f64, labels, ancestor), torch_float64()) -# }) -# -# -# test_that("max_constraint_output works with complex hierarchy", { -# output <- torch_tensor(matrix(c(1, 2, 3, -# 4, 5, 6), nrow = 2, ncol = 3, byrow = TRUE)) -# labels <- torch_tensor(matrix(c(1, 0, 0, -# 0, 1, 0), nrow = 2, ncol = 3, byrow = TRUE), dtype = torch_bool()) -# ancestor <- torch_triu(torch_ones(c(3,3))) -# result <- max_constraint_output(output, labels, ancestor) -# expect_tensor_shape(result, c(2, 3)) -# # Row 1: label on col 1 -> train_output[1,1]=1, others get constr_output=3 -# # Row 2: label on col 2 -> train_output[2,2]=5, others get constr_output=6 -# expected <- matrix(c(1, 3, 3, -# 6, 5, 6), nrow = 2, ncol = 3, byrow = TRUE) -# expect_equal_to_r(result, expected) -# }) -# -# test_that("max_constraint_output handles single element tensors", { -# output <- torch_tensor(matrix(5, nrow = 1, ncol = 1)) -# labels <- torch_tensor(matrix(TRUE, nrow = 1, ncol = 1), dtype = torch_bool()) -# ancestor <- torch_tensor(matrix(1, nrow = 1, ncol = 1)) -# result <- max_constraint_output(output, labels, ancestor) -# expect_tensor_shape(result, c(1, 1)) -# # Compare against 1x1 matrix instead of scalar to match torch array output -# expect_equal_to_r(result, matrix(5, nrow = 1, ncol = 1)) -# }) -# -# test_that("max_constraint_output throws error for dimension mismatch", { -# output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) -# labels <- torch::torch_ones(c(2, 3), dtype = torch_bool()) -# ancestor <- torch::torch_eye(2) -# expect_error(max_constraint_output(output, labels, ancestor), "dimension") -# }) -# -# test_that("max_constraint_output handles float labels without error", { -# # torch_logical_not works on float tensors (0.0 -> TRUE, others -> FALSE) -# # No explicit type check exists in the function, so it should run successfully -# output <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) -# labels <- torch::torch_ones(c(2, 2), dtype = torch::torch_float32()) -# ancestor <- torch::torch_eye(2) -# expect_silent(max_constraint_output(output, labels, ancestor)) -# result <- max_constraint_output(output, labels, ancestor) -# expect_tensor_shape(result, c(2, 2)) -# }) -# -# test_that("get_constr_output and max_constraint_output compose correctly", { -# output <- torch_tensor(matrix(c(1, 4, -# 2, 3), nrow = 2, ncol = 2, byrow = TRUE)) -# labels <- torch_tensor(matrix(c(TRUE, FALSE, -# TRUE, FALSE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch_bool()) -# ancestor <- torch_tensor(matrix(c(1, 1, -# 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) -# direct <- max_constraint_output(output, labels, ancestor) -# constr_out <-get_constr_output(output, ancestor) -# train_out <-get_constr_output(labels * output, ancestor) -# manual <- torch_logical_not(labels) * constr_out + labels * train_out -# expect_equal_to_r(direct, as_array(manual)) -# }) - -test_that("get_constr_output handles negative values correctly", { - x <- torch_tensor(matrix(c(-5, -1, - -3, -2), nrow = 2, ncol = 2, byrow = TRUE)) - R <- torch_tensor(matrix(c(1, 1, - 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) - result <- get_constr_output(x, R) - expected <- matrix(c(-1, 0, - -2, 0), nrow = 2, ncol = 2, byrow = TRUE) - expect_equal_to_r(result, expected) -}) - -# test_that("max_constraint_output handles mixed positive-negative with constraints", { -# output <- torch_tensor(matrix(c(-5, -3, -# -1, 4), nrow = 2, ncol = 2, byrow = TRUE)) -# labels <- torch_tensor(matrix(c(TRUE, TRUE, -# FALSE, TRUE), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch::torch_bool()) -# ancestor <- torch_tensor(matrix(c(1, 1, -# 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) -# result <- max_constraint_output(output, labels, ancestor) -# expected <- matrix(c(-3, 0, -# 4, 4), nrow = 2, ncol = 2, byrow = TRUE) -# expect_equal_to_r(result, expected) -# }) - -test_that("build_ancestor_matrix handles basic unrelated hierarchy as a diag matrix", { +test_that("build_ancestor_matrix_from_outcomes handles basic unrelated hierarchy as a diag matrix", { tree_df <- data.frame(pathString = c("Root/A/C1", "Root/A/C2","Root/B/D1", "Root/B/D2")) tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree) + result <- build_ancestor_matrix_from_outcomes(tree) expect_tensor_shape(result, c(1,2,2)) expect_equal_to_r(result$squeeze(), diag(2)) }) -test_that("build_ancestor_matrix handles linear chain of internal nodes", { +test_that("build_ancestor_matrix_from_outcomes handles linear chain of internal nodes", { tree_df <- data.frame(pathString = c("Root/A/B", "Root/A/B/C"), value = 1:2) tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree) + result <- build_ancestor_matrix_from_outcomes(tree) # lower triangular 2 x 2 mat expected <- fBasics::triang(matrix(1, nrow = 2, ncol = 2)) expect_equal_to_r(result$squeeze(), expected) }) -test_that("build_ancestor_matrix calculates transitive closure correctly", { +test_that("build_ancestor_matrix_from_outcomes calculates transitive closure correctly", { tree_df <- data.frame(pathString = c("Root/A/B/C", "Root/A/B/C/D"), value = 1:2) tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree) + result <- build_ancestor_matrix_from_outcomes(tree) # lower triangular 3 x 3 mat expected <- fBasics::triang(matrix(TRUE, nrow = 3, ncol = 3)) expect_equal_to_r(result$squeeze(), expected) }) -test_that("build_ancestor_matrix handles branching internal nodes", { +test_that("build_ancestor_matrix_from_outcomes handles branching internal nodes", { tree_df <- data.frame(pathString = c("Root/A/C/E1", "Root/A/C/E2", "Root/B/D/E1", "Root/B/D/E3")) tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree) + result <- build_ancestor_matrix_from_outcomes(tree) # diagonal matrix with 2 ancestors expected <- diag(4) @@ -277,17 +47,17 @@ test_that("build_ancestor_matrix handles branching internal nodes", { expect_equal_to_r(result$squeeze(), expected) }) -test_that("build_ancestor_matrix returns empty for Root-only tree", { +test_that("build_ancestor_matrix_from_outcomes returns empty for Root-only tree", { tree <- Node$new("Root") - result <- build_ancestor_matrix(tree) + result <- build_ancestor_matrix_from_outcomes(tree) expect_equal(result$shape, c(1,0,0)) }) -test_that("build_ancestor_matrix returns empty for Root + Leaf", { +test_that("build_ancestor_matrix_from_outcomes returns empty for Root + Leaf", { tree_df <- data.frame(pathString = c("Root/A", "Root/B")) tree <- as.Node(tree_df) - result <- build_ancestor_matrix(tree) + result <- build_ancestor_matrix_from_outcomes(tree) expect_equal(result$shape, c(1,0,0)) }) diff --git a/tests/testthat/test-loss.R b/tests/testthat/test-loss.R index cff90a32..9684a4f2 100644 --- a/tests/testthat/test-loss.R +++ b/tests/testthat/test-loss.R @@ -71,3 +71,105 @@ test_that("nn_aum_loss works as expected with {n, 2} shape prediction", { }) +test_that("get_constr_output handles basic 2D input with identity constraint", { + m <- matrix(c(1, 2, + 3, 4), nrow = 2, ncol = 2) + x <- torch_tensor(m, dtype = torch::torch_float32()) + R <- torch::torch_eye(2, dtype = torch::torch_float32()) + result <-get_constr_output(x, R) + expect_tensor(result) + expect_tensor_shape(result, c(2, 2)) + expect_equal_to_r(result, m) +}) + +test_that("get_constr_output applies hierarchy constraint correctly", { + x <- torch_tensor(matrix(c(1, 5, + 3, 2), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch::torch_float64()) + R <- torch_tensor(matrix(c(1, 1, + 0, 1), nrow = 2, ncol = 2, byrow = TRUE), dtype = torch::torch_float64()) + result <-get_constr_output(x, R) + expect_tensor_shape(result, c(2, 2)) + expected <- matrix(c(5, 5, 3, 2), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected, tolerance = 1e-6) +}) + +test_that("get_constr_output preserves input dtype", { + x_f32 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float32()) + x_f64 <- torch_tensor(matrix(1:4, nrow = 2), dtype = torch::torch_float64()) + R <- torch::torch_eye(2) + expect_tensor_dtype(get_constr_output(x_f32, R), torch::torch_float64()) + expect_tensor_dtype(get_constr_output(x_f64, R), torch::torch_float64()) +}) + +test_that("get_constr_output handles batch dimension correctly", { + x <- torch_tensor(matrix(1:12, nrow = 3, ncol = 4)) + R <- torch_tensor(matrix(c(1, 1, 0, 0, + 1, 1, 0, 0, + 0, 0, 1, 1, + 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) + result <-get_constr_output(x, R) + expect_tensor_shape(result, c(3, 4)) + + for (i in 1:3) { + row_result <- as_array(result[i, ]) + max_grp1 <- max(as_array(x[i, 1:2])) + max_grp2 <- max(as_array(x[i, 3:4])) + + expect_equal(row_result[1:2], rep(max_grp1, 2), tolerance = 1e-6) + expect_equal(row_result[3:4], rep(max_grp2, 2), tolerance = 1e-6) + } +}) +test_that("get_constr_output works with single sample", { + x <- torch_tensor(matrix(c(2, 1, 4, 3), nrow = 1, ncol = 4, byrow = TRUE)) + R <- torch_tensor(matrix(c(1, 1, 0, 0, + 1, 1, 0, 0, + 0, 0, 1, 1, + 0, 0, 1, 1), nrow = 4, ncol = 4, byrow = TRUE)) + result <-get_constr_output(x, R) + expect_tensor_shape(result, c(1, 4)) + expected <- matrix(c(2, 2, 4, 4), nrow = 1, byrow = TRUE) + expect_equal_to_r(result, expected) +}) + +test_that("get_constr_output handles all-zeros constraint matrix", { + x <- torch_tensor(matrix(1:6, nrow = 2, ncol = 3)) + R <- torch::torch_zeros(c(3, 3)) + result <-get_constr_output(x, R) + expect_tensor_shape(result, c(2, 3)) + expect_equal_to_r(result, matrix(0, nrow = 2, ncol = 3)) +}) + +test_that("get_constr_output handles all-ones constraint matrix", { + x <- torch_tensor(matrix(c(1, 5, 3, + 2, 4, 6), nrow = 2, ncol = 3, byrow = TRUE)) + R <- torch::torch_ones(c(3, 3)) + result <-get_constr_output(x, R) + expect_tensor_shape(result, c(2, 3)) + # Each row is filled with its own row-wise maximum + expected <- matrix(c(5, 5, 5, + 6, 6, 6), nrow = 2, ncol = 3, byrow = TRUE) + expect_equal_to_r(result, expected, tolerance = 1e-6) +}) + +test_that("get_constr_output throws error for dimension mismatch", { + x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + R <- torch::torch_eye(3) + expect_error(get_constr_output(x, R), "must match the existing size") +}) + +test_that("get_constr_output throws error for non-2D R", { + x <- torch_tensor(matrix(1:4, nrow = 2, ncol = 2)) + R <- torch_tensor(array(1:8, dim = c(1, 2, 2, 2))) + expect_error(get_constr_output(x, R), "dimension") +}) + +test_that("get_constr_output handles negative values correctly", { + x <- torch_tensor(matrix(c(-5, -1, + -3, -2), nrow = 2, ncol = 2, byrow = TRUE)) + R <- torch_tensor(matrix(c(1, 1, + 0, 1), nrow = 2, ncol = 2, byrow = TRUE)) + result <- get_constr_output(x, R) + expected <- matrix(c(-1, 0, + -2, 0), nrow = 2, ncol = 2, byrow = TRUE) + expect_equal_to_r(result, expected) +}) From c945839288cbcf408acd4859ac1c39d384c364d9 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sun, 7 Jun 2026 11:32:15 +0200 Subject: [PATCH 17/21] loss test passing [ FAIL 0 | WARN 0 | SKIP 0 | PASS 36 ]23.552 sec elapsed hierarchical_utils test passing [ FAIL 0 | WARN 0 | SKIP 0 | PASS 62 ]25.31 sec elapsed --- R/hardhat.R | 2 +- R/loss.R | 2 +- tests/testthat/test-hierarchical_utils.R | 209 ++++++++++++++++------- tests/testthat/test-loss.R | 2 +- 4 files changed, 152 insertions(+), 63 deletions(-) diff --git a/R/hardhat.R b/R/hardhat.R index eeb4139c..af3b83b3 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -167,7 +167,7 @@ tabnet_fit.Node <- function(x, tabnet_model = NULL, config = tabnet_config(), .. config <- merge_config_and_dots(config, ...) # add ancestor boolean sparse matrix to config # check_dag_compliance(xy_df$y) - config$ancestor <- build_ancestor_matrix(x) + config$ancestor <- build_ancestor_matrix_from_outcomes(x, processed$outcomes) # make outcomes levels available so that batched y could be one-hot encoded. config$outcomes <- processed$outcomes tabnet_bridge(processed, config = config, tabnet_model, from_epoch, task = "supervised") diff --git a/R/loss.R b/R/loss.R index 98b359c0..4a50d6da 100644 --- a/R/loss.R +++ b/R/loss.R @@ -255,7 +255,7 @@ nn_mc_loss <- nn_module( get_constr_output <- function(x, R) { c_out <- x$to(dtype = torch_double())$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) R_batch <- R$expand(c(x$shape[1], R$shape[2], R$shape[2])) - final_out <- torch_max(torch_matmul(R_batch, c_out), dim = 3) + final_out <- torch_max(R_batch * c_out, dim = 3) final_out[[1]] } diff --git a/tests/testthat/test-hierarchical_utils.R b/tests/testthat/test-hierarchical_utils.R index 4216a300..41d34ec5 100644 --- a/tests/testthat/test-hierarchical_utils.R +++ b/tests/testthat/test-hierarchical_utils.R @@ -1,87 +1,176 @@ -test_that("build_ancestor_matrix_from_outcomes handles basic unrelated hierarchy as a diag matrix", { - tree_df <- data.frame(pathString = c("Root/A/C1", "Root/A/C2","Root/B/D1", "Root/B/D2")) +test_that("returns correct shape and type for a simple 2-level hierarchy", { + # Arbre : Root -> {A, B}, A -> {C1, C2}, B -> {D1, D2} + tree_df <- data.frame(pathString = c( + "Root/A/C1", "Root/A/C2", "Root/B/D1", "Root/B/D2" + )) tree <- as.Node(tree_df) - result <- build_ancestor_matrix_from_outcomes(tree) - - expect_tensor_shape(result, c(1,2,2)) - expect_equal_to_r(result$squeeze(), diag(2)) + outcomes <- tibble::tibble( + level_2 = factor(c("A", "A", "B", "B")), + level_3 = factor(c("C1", "C2", "D1", "D2")) + ) + + result <- build_ancestor_matrix_from_outcomes(tree, outcomes) + + # 2 level_2 classes + 4 level_3 = 6 classes + expect_tensor(result) + expect_tensor_shape(result, c(1, 6, 6)) + expect_tensor_dtype(result, torch_double()) }) -test_that("build_ancestor_matrix_from_outcomes handles linear chain of internal nodes", { +test_that("handles ghost classes (present in tree but absent from outcomes)", { + # Tree with a "C" branch not in the outcomes + tree_df <- data.frame(pathString = c( + "Root/A/C1", "Root/A/C2", + "Root/B/D1", "Root/B/D2", + "Root/C/E1", "Root/C/E2" + )) + tree <- as.Node(tree_df) + + # Outcomes shall only contain A and B (C is a "ghost class") + outcomes <- tibble::tibble( + level_2 = factor(c("A", "A", "B", "B")), + level_3 = factor(c("C1", "C2", "D1", "D2")) + ) + + result <- build_ancestor_matrix_from_outcomes(tree, outcomes) + expect_tensor_shape(result, c(1, 6, 6)) + + # Check of transitive loop : A(1) is ancestor of C1(3) and C2(4) + # Order : A(1), B(2), C1(3), C2(4), D1(5), D2(6) + expect_equal_to_r(result[1, 3, 1], 1) + expect_equal_to_r(result[1, 4, 1], 1) + expect_equal_to_r(result[1, 5, 2], 1) + expect_equal_to_r(result[1, 6, 2], 1) + expect_equal_to_r(result[1, 3, 3], 1) # Self-loop +}) - tree_df <- data.frame(pathString = c("Root/A/B", "Root/A/B/C"), value = 1:2) +test_that("handles non-unique names across different hierarchy levels", { + # "Manager" may exist at level_2 (Department) and level_3 (JobRole) + tree_df <- data.frame(pathString = c( + "Root/Manager/Rep", + "Root/IT/Manager" + )) tree <- as.Node(tree_df) - result <- build_ancestor_matrix_from_outcomes(tree) + outcomes <- tibble::tibble( + level_2 = factor(c("Manager", "IT")), + level_3 = factor(c("Rep", "Manager")) + ) + + result <- build_ancestor_matrix_from_outcomes(tree, outcomes) + + # 2 + 2 = 4 classes + expect_tensor_shape(result, c(1L, 4L, 4L)) - # lower triangular 2 x 2 mat - expected <- fBasics::triang(matrix(1, nrow = 2, ncol = 2)) - expect_equal_to_r(result$squeeze(), expected) + # Order : Manager_lvl2(1), IT(2), Rep(3), Manager_lvl3(4) + # Manager_lvl2(1) is ancestor of Rep(3) + expect_equal_to_r(result[1, 3, 1], 1) + # IT(2) is ancestor of Manager_lvl3(4) + expect_equal_to_r(result[1, 4, 2], 1) }) -test_that("build_ancestor_matrix_from_outcomes calculates transitive closure correctly", { - - tree_df <- data.frame(pathString = c("Root/A/B/C", "Root/A/B/C/D"), value = 1:2) +test_that("throws an explicit error when a factor level is missing from the tree", { + tree_df <- data.frame(pathString = c("Root/A/C1", "Root/A/C2")) tree <- as.Node(tree_df) - result <- build_ancestor_matrix_from_outcomes(tree) + outcomes <- tibble::tibble( + level_2 = factor(c("A", "X")), # "X" is not in the tree + level_3 = factor(c("C1", "C2")) + ) - # lower triangular 3 x 3 mat - expected <- fBasics::triang(matrix(TRUE, nrow = 3, ncol = 3)) - expect_equal_to_r(result$squeeze(), expected) + expect_error( + build_ancestor_matrix_from_outcomes(tree, outcomes), + "not found" + ) }) -test_that("build_ancestor_matrix_from_outcomes handles branching internal nodes", { - - tree_df <- data.frame(pathString = c("Root/A/C/E1", "Root/A/C/E2", "Root/B/D/E1", "Root/B/D/E3")) +test_that("throws an error when outcomes contains no factor levels", { + tree_df <- data.frame(pathString = c("Root/A/C1")) tree <- as.Node(tree_df) - result <- build_ancestor_matrix_from_outcomes(tree) + outcomes <- tibble::tibble( + level_2 = factor(character(0)), + level_3 = factor(character(0)) + ) - # diagonal matrix with 2 ancestors - expected <- diag(4) - expected[2,1] <- 1L - expected[4,3] <- 1L - - expect_equal_to_r(result$squeeze(), expected) + expect_error( + build_ancestor_matrix_from_outcomes(tree, outcomes), + "No factor levels" + ) }) -test_that("build_ancestor_matrix_from_outcomes returns empty for Root-only tree", { - tree <- Node$new("Root") - result <- build_ancestor_matrix_from_outcomes(tree) - expect_equal(result$shape, c(1,0,0)) -}) +test_that("preserves the exact class order defined in outcomes factors", { + # Dans l'arbre, B est défini avant A + tree_df <- data.frame(pathString = c( + "Root/B/D1", "Root/B/D2", + "Root/A/C1", "Root/A/C2" + )) + tree <- as.Node(tree_df) + + # Mais dans outcomes, A est explicitement avant B + outcomes <- tibble::tibble( + level_2 = factor(c("A", "A", "B", "B"), levels = c("A", "B")), + level_3 = factor(c("C1", "C2", "D1", "D2"), levels = c("C1", "C2", "D1", "D2")) + ) + + result <- build_ancestor_matrix_from_outcomes(tree, outcomes) -test_that("build_ancestor_matrix_from_outcomes returns empty for Root + Leaf", { + # Order is given by outcomes : A(1), B(2), C1(3), C2(4), D1(5), D2(6) + # A(1) is ancestor of C1(3) et C2(4) + expect_equal_to_r(result[1, 3, 1], 1) + expect_equal_to_r(result[1, 4, 1], 1) + + # B(2) is ancestor of D1(5) et D2(6) + expect_equal_to_r(result[1, 5, 2], 1) + expect_equal_to_r(result[1, 6, 2], 1) +}) - tree_df <- data.frame(pathString = c("Root/A", "Root/B")) +test_that("handles a flat single-level hierarchy correctly", { + tree_df <- data.frame(pathString = c("Root/A", "Root/B", "Root/C")) tree <- as.Node(tree_df) - result <- build_ancestor_matrix_from_outcomes(tree) - expect_equal(result$shape, c(1,0,0)) + + outcomes <- tibble::tibble( + level_2 = factor(c("A", "B", "C")) + ) + + result <- build_ancestor_matrix_from_outcomes(tree, outcomes) + expect_equal(result$shape, c(1L, 3L, 3L)) + + # no hierarchy, only self-loops + expect_equal_to_r(result$squeeze(1), diag(3)) }) -test_that("node_to_df works ", { - expect_no_error( - node_to_df(acme) - ) - expect_no_error( - attrition_df <- node_to_df(attrition_tree) +test_that("computes full transitive closure for deep hierarchies (3+ levels)", { + tree_df <- data.frame(pathString = c( + "Root/L1_A/L2_A1/L3_A1a", + "Root/L1_A/L2_A1/L3_A1b", + "Root/L1_A/L2_A2/L3_A2a", + "Root/L1_B/L2_B1/L3_B1a" + )) + tree <- as.Node(tree_df) + + outcomes <- tibble::tibble( + level_2 = factor(c("L1_A", "L1_A", "L1_A", "L1_B")), + level_3 = factor(c("L2_A1","L2_A1", "L2_A2", "L2_B1")), + level_4 = factor(c("L3_A1a", "L3_A1b", "L3_A2a", "L3_B1a")) ) - # node_to_df removes first and last level of the hierarchy - outcome_levels <- paste0("level_", seq(2, attrition_tree$height - 1)) - expect_equal(names(attrition_df$y), outcome_levels) - - # node_to_df do not shuffle outcome rows - df <- tibble(pred_1 = seq(1,26), pred_2 = seq(26,1), - level_2 = factor(LETTERS[1:26]), level_3 = factor(letters[26:1])) - df_node_df <- df %>% - mutate(pathString = paste("synth", level_2, level_3, level_3, sep = "/")) %>% - select(-level_2, -level_3) %>% - as.Node() %>% - node_to_df() - - expect_equal(df_node_df$y %>% as_tibble(), df %>% select(starts_with("level_"))) - expect_equal(df_node_df$x %>% as_tibble(), df %>% select(starts_with("pred_"))) -}) + result <- build_ancestor_matrix_from_outcomes(tree, outcomes) + expect_equal(result$shape, c(1L, 9L, 9L)) + + # Order : L1_A(1), L1_B(2), L2_A1(3), L2_A2(4), L2_B1(5), + # L3_A1a(6), L3_A1b(7), L3_A2a(8), L3_B1a(9) + + # L1_A(1) is a transitive ancestor of all the sub-tree A + expect_equal_to_r(result[1, 3, 1], 1) # -> L2_A1 + expect_equal_to_r(result[1, 6, 1], 1) # -> L3_A1a + expect_equal_to_r(result[1, 8, 1], 1) # -> L3_A2a + + # L2_A1(3) is an ancestor of all its direct children + expect_equal_to_r(result[1, 6, 3], 1) # -> L3_A1a + expect_equal_to_r(result[1, 7, 3], 1) # -> L3_A1b + + # Self-loops on the diagonal (substracting the eye don't go to negative values) + expect_true((result$squeeze() - torch_eye(9))$min()$item() >= 0) +}) \ No newline at end of file diff --git a/tests/testthat/test-loss.R b/tests/testthat/test-loss.R index 9684a4f2..9e1a9e95 100644 --- a/tests/testthat/test-loss.R +++ b/tests/testthat/test-loss.R @@ -75,7 +75,7 @@ test_that("get_constr_output handles basic 2D input with identity constraint", { m <- matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2) x <- torch_tensor(m, dtype = torch::torch_float32()) - R <- torch::torch_eye(2, dtype = torch::torch_float32()) + R <- torch::torch_eye(2) result <-get_constr_output(x, R) expect_tensor(result) expect_tensor_shape(result, c(2, 2)) From 0233c708fe55ee08730da13b15c8b2e09c66c4d9 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sun, 7 Jun 2026 14:41:18 +0200 Subject: [PATCH 18/21] improve `nn_mc_loss` robustness to different criterion --- R/loss.R | 76 +++++++++++++++++++++++++++++--------- man/nn_mc_loss.Rd | 2 +- man/nnf_mc_loss.Rd | 6 +-- tests/testthat/test-loss.R | 76 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 136 insertions(+), 24 deletions(-) diff --git a/R/loss.R b/R/loss.R index 4a50d6da..0306d7cd 100644 --- a/R/loss.R +++ b/R/loss.R @@ -129,8 +129,6 @@ nn_aum_loss <- nn_module( #' are evaluated. #' @param criterion Loss function to apply after constraint propagation. #' Default: `nnf_binary_cross_entropy_with_logits` (expects raw logits). -#' @param reduction (string, optional): Specifies the reduction to apply to -#' the output: `'none'` | `'mean'` | `'sum'`. Passed to `criterion`. #' #' @return A scalar `torch_tensor` containing the computed loss, or a tensor #' of shape `(batch_size, n_classes)` if `reduction = "none"`. @@ -138,8 +136,7 @@ nn_aum_loss <- nn_module( #' @seealso [nn_mc_loss()], [get_constr_output()] #' @export nnf_mc_loss <- function(output, target, R, to_eval = NULL, - criterion = nnf_binary_cross_entropy_with_logits, - reduction = "mean") { + criterion = nnf_binary_cross_entropy_with_logits) { # Ensure double precision for numerical stability during constraint propagation output_d <- output$double() @@ -164,8 +161,7 @@ nnf_mc_loss <- function(output, target, R, to_eval = NULL, # 5. Apply the base loss function (e.g., BCE with logits) loss <- criterion( blended_output, - target$double(), - reduction = reduction + target$double() ) return(loss) @@ -211,14 +207,15 @@ nn_mc_loss <- nn_module( inherit = torch::nn_l1_loss, initialize = function(R, to_eval = NULL, - criterion = torch::nn_bce_with_logits_loss(), + criterion = torch::nnf_binary_cross_entropy_with_logits, reduction = "mean") { super$initialize(reduction = reduction) # Store ancestor matrix (move to device if needed) self$R <- R self$to_eval <- to_eval - self$criterion <- criterion + # Resolve criterion based on its type + self$criterion_fn <- .resolve_mc_criterion(criterion, reduction) }, forward = function(output, target) { @@ -227,20 +224,63 @@ nn_mc_loss <- nn_module( target = target, R = self$R, to_eval = self$to_eval, - criterion = function(input, target, reduction) { - # Handle both module and functional criterion - if (inherits(self$criterion, "nn_module")) { - self$criterion(input, target, reduction = reduction) - } else { - # Assume functional - self$criterion(input, target, reduction = reduction) - } - }, - reduction = self$reduction + criterion = self$criterion_fn ) } ) +#' Resolve criterion into a callable function(input, target, reduction) +#' @keywords internal +.resolve_mc_criterion <- function(criterion, reduction) { + # Case 1: Already an nn_module instance + if (inherits(criterion, "nn_module")) { + module_reduction <- criterion$reduction + if (!is.null(module_reduction) && module_reduction != reduction) { + warn( + c( + "The criterion module has reduction={.val {module_reduction}}", + "but nn_mc_loss was called with reduction={.val {reduction}}.", + "i" = "The module's reduction will be used." + ), + class = "mc_loss_reduction_mismatch" + ) + } + return(function(input, target) criterion(input, target)) + } + + # Case 2: A function (could be functional nnf_* or constructor nn_*) + if (rlang::is_function(criterion)) { + # Try to detect if it's a constructor by calling with just reduction + # Constructors return nn_module, functionals need input/target + maybe_module <- tryCatch( + { + result <- criterion(reduction = reduction) + if (inherits(result, "nn_module")) result else NULL + }, + error = function(e) NULL + ) + + if (!is.null(maybe_module)) { + # It's a constructor (e.g., nn_bce_with_logits_loss) + return(function(input, target) maybe_module(input, target)) + } + + # It's a functional (e.g., nnf_binary_cross_entropy_with_logits) + return(function(input, target) { + criterion(input, target, reduction = reduction) + }) + } + + # Invalid type + value_error( + c( + "`criterion` must be a function or an `nn_module`.", + "x" = "Got: {.class {class(criterion)[1]}}" + ), + class = "mc_loss_invalid_criterion" + ) +} + #' Apply hierarchy constraints via max-pooling over descendants (MCM) #' #' Given neural network outputs x and ancestor matrix R, enforces that diff --git a/man/nn_mc_loss.Rd b/man/nn_mc_loss.Rd index eb3dee75..37a5ab02 100644 --- a/man/nn_mc_loss.Rd +++ b/man/nn_mc_loss.Rd @@ -7,7 +7,7 @@ nn_mc_loss( R, to_eval = NULL, - criterion = torch::nn_bce_with_logits_loss(), + criterion = torch::nnf_binary_cross_entropy_with_logits, reduction = "mean" ) } diff --git a/man/nnf_mc_loss.Rd b/man/nnf_mc_loss.Rd index 0991fc12..bc514e38 100644 --- a/man/nnf_mc_loss.Rd +++ b/man/nnf_mc_loss.Rd @@ -9,8 +9,7 @@ nnf_mc_loss( target, R, to_eval = NULL, - criterion = nnf_binary_cross_entropy_with_logits, - reduction = "mean" + criterion = nnf_binary_cross_entropy_with_logits ) } \arguments{ @@ -28,9 +27,6 @@ are evaluated.} \item{criterion}{Loss function to apply after constraint propagation. Default: \code{nnf_binary_cross_entropy_with_logits} (expects raw logits).} - -\item{reduction}{(string, optional): Specifies the reduction to apply to -the output: \code{'none'} | \code{'mean'} | \code{'sum'}. Passed to \code{criterion}.} } \value{ A scalar \code{torch_tensor} containing the computed loss, or a tensor diff --git a/tests/testthat/test-loss.R b/tests/testthat/test-loss.R index 9e1a9e95..3bc5e675 100644 --- a/tests/testthat/test-loss.R +++ b/tests/testthat/test-loss.R @@ -173,3 +173,79 @@ test_that("get_constr_output handles negative values correctly", { -2, 0), nrow = 2, ncol = 2, byrow = TRUE) expect_equal_to_r(result, expected) }) + +test_that("nn_mc_loss resolves functional criterion at initialization", { + R <- torch::torch_eye(3)$unsqueeze(1) + + # Functional criterion + loss_fn <- nn_mc_loss( + R = R, + criterion = torch::nnf_binary_cross_entropy_with_logits, + reduction = "mean" + ) + + expect_true(rlang::is_function(loss_fn$criterion_fn)) + + output <- torch::torch_randn(2, 3, requires_grad = TRUE) + target <- torch::torch_randint(0, 2, c(2, 3))$to(dtype = torch::torch_double()) + + expect_no_error(loss <- loss_fn(output, target)) + expect_tensor(loss) +}) + +test_that("nn_mc_loss resolves nn_module criterion at initialization (default)", { + R <- torch::torch_eye(3)$unsqueeze(1) + + # Functional criterion + loss_fn <- nn_mc_loss(R = R) + + expect_true(rlang::is_function(loss_fn$criterion_fn)) + + output <- torch::torch_randn(2, 3, requires_grad = TRUE) + target <- torch::torch_randint(0, 2, c(2, 3))$to(dtype = torch::torch_double()) + + expect_no_error(loss <- loss_fn(output, target)) + expect_tensor(loss) +}) + +test_that("nn_mc_loss can use already instanciated nn_module criterion", { + R <- torch::torch_eye(3)$unsqueeze(1) + + # Module criterion + loss_fn <- nn_mc_loss( + R = R, + criterion = torch::nn_bce_with_logits_loss(), + reduction = "mean" + ) + + expect_true(rlang::is_function(loss_fn$criterion_fn)) + + output <- torch::torch_randn(2, 3, requires_grad = TRUE) + target <- torch::torch_randint(0, 2, c(2, 3))$to(dtype = torch::torch_double()) + + expect_no_error(loss <- loss_fn(output, target)) + expect_tensor(loss) +}) + +test_that("nn_mc_loss errors on invalid criterion type", { + R <- torch::torch_eye(3)$unsqueeze(1)$to(dtype = torch::torch_double()) + + expect_error( + nn_mc_loss(R = R, criterion = "not_a_valid_criterion"), + "must be a function or an" + ) +}) + +test_that("nn_mc_loss warns on reduction mismatch for module criterion", { + R <- torch::torch_eye(3)$unsqueeze(1)$to(dtype = torch::torch_double()) + + # Module with 'sum' reduction, but loss asks for 'mean' + expect_warning( + nn_mc_loss( + R = R, + criterion = torch::nn_bce_with_logits_loss(reduction = "sum"), + reduction = "mean" + ), + "The criterion module has reduction" + ) +}) \ No newline at end of file From 125cd9364bcda8f7ed40a3bfab6a0af54bd9690c Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sun, 7 Jun 2026 16:11:43 +0200 Subject: [PATCH 19/21] clone final_out before $max to prevent `variables needed for gradient computation has been modified by an inplace operation` --- NAMESPACE | 2 -- R/loss.R | 39 +++++++++++----------- tests/testthat/test-hardhat_hierarchical.R | 4 ++- tests/testthat/test-loss.R | 23 +++++++++++-- 4 files changed, 43 insertions(+), 25 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index ccd9e976..0bb1617c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -80,10 +80,8 @@ importFrom(torch,nn_module) importFrom(torch,nn_prune_head) importFrom(torch,torch_argsort) importFrom(torch,torch_cat) -importFrom(torch,torch_double) importFrom(torch,torch_long) importFrom(torch,torch_matmul) -importFrom(torch,torch_max) importFrom(torch,torch_mean) importFrom(torch,torch_minimum) importFrom(torch,torch_mul) diff --git a/R/loss.R b/R/loss.R index 0306d7cd..89eed651 100644 --- a/R/loss.R +++ b/R/loss.R @@ -106,6 +106,25 @@ nn_aum_loss <- nn_module( } ) + +#' Apply hierarchy constraints via max-pooling over descendants (MCM) +#' +#' Given neural network outputs x and ancestor matrix R, enforces that +#' if a class is predicted positive, all its ancestors must also be positive. +#' Implements: `final_out[i] = max{x[j] : R[i,j] = 1}` +#' +#' @param x A `torch_tensor` of shape `(batch_size, n_classes)`. +#' @param R A `torch_tensor` of shape `(1, n_classes, n_classes)` where +#' `R[1, i, j] = 1` iff class `i` is a descendant of class `j`. +#' @return A `torch_tensor` of shape `(batch_size, n_classes)` with constrained outputs. +get_constr_output <- function(x, R) { + c_out <- x$double()$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) + R_batch <- R$expand(c(x$shape[1], R$shape[2], R$shape[2])) + final_out <- (R_batch * c_out)$clone()$max(dim = 3) + final_out[[1]] +} + + #' Max-Constraint Margin Loss (functional) #' #' Computes the hierarchy-constrained loss for multi-label classification. @@ -231,6 +250,7 @@ nn_mc_loss <- nn_module( #' Resolve criterion into a callable function(input, target, reduction) #' @keywords internal +#' @noRd .resolve_mc_criterion <- function(criterion, reduction) { # Case 1: Already an nn_module instance if (inherits(criterion, "nn_module")) { @@ -281,25 +301,6 @@ nn_mc_loss <- nn_module( ) } -#' Apply hierarchy constraints via max-pooling over descendants (MCM) -#' -#' Given neural network outputs x and ancestor matrix R, enforces that -#' if a class is predicted positive, all its ancestors must also be positive. -#' Implements: `final_out[i] = max{x[j] : R[i,j] = 1}` -#' -#' @param x A `torch_tensor` of shape `(batch_size, n_classes)`. -#' @param R A `torch_tensor` of shape `(1, n_classes, n_classes)` where -#' `R[1, i, j] = 1` iff class `i` is a descendant of class `j`. -#' @return A `torch_tensor` of shape `(batch_size, n_classes)` with constrained outputs. -#' @importFrom torch torch_max torch_double -get_constr_output <- function(x, R) { - c_out <- x$to(dtype = torch_double())$unsqueeze(2)$expand(c(x$shape[1], R$shape[2], R$shape[2])) - R_batch <- R$expand(c(x$shape[1], R$shape[2], R$shape[2])) - final_out <- torch_max(R_batch * c_out, dim = 3) - final_out[[1]] -} - - #' Convert class_id tensor to binary one-hot tensor #' #' Transforms a tensor of class indices (one column per hierarchy level) diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index e0ce1972..88fc6b71 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -73,7 +73,9 @@ test_that("Training hierarchical classification for {data.tree} Node for starwar pathString = paste("StarWars_characters", species, sex, `_name`, sep = "/")) %>% as.Node() - expect_no_error(check_compliant_node(starwars_tree)) + expect_error( + check_compliant_node(starwars_tree) + ,"reserved names") fit <- tabnet_fit(starwars_tree, epochs = 1) }) diff --git a/tests/testthat/test-loss.R b/tests/testthat/test-loss.R index 3bc5e675..4fb7db5b 100644 --- a/tests/testthat/test-loss.R +++ b/tests/testthat/test-loss.R @@ -62,12 +62,10 @@ test_that("nn_aum_loss works as expected with {n, 2} shape prediction", { output <- aum_loss(pred_tensor, label_tensor) output$backward() - expect_tensor(output) expect_equal_to_r(output >= 0, TRUE) expect_false(rlang::is_null(output$grad_fn)) expect_equal(output$dim(), 0) - }) @@ -76,7 +74,7 @@ test_that("get_constr_output handles basic 2D input with identity constraint", { 3, 4), nrow = 2, ncol = 2) x <- torch_tensor(m, dtype = torch::torch_float32()) R <- torch::torch_eye(2) - result <-get_constr_output(x, R) + result <- get_constr_output(x, R) expect_tensor(result) expect_tensor_shape(result, c(2, 2)) expect_equal_to_r(result, m) @@ -248,4 +246,23 @@ test_that("nn_mc_loss warns on reduction mismatch for module criterion", { ), "The criterion module has reduction" ) +}) + +test_that("nn_mc_loss backward pass works without inplace errors", { + R <- torch::torch_eye(3)$unsqueeze(1)$to(dtype = torch::torch_double()) + + loss_fn <- nn_mc_loss(R = R, reduction = "mean") + + output <- torch::torch_randn(2, 3, requires_grad = TRUE) + target <- torch::torch_randint(0, 2, c(2, 3))$to(dtype = torch::torch_double()) + + # Forward + loss <- loss_fn(output, target) + + # Backward should not throw inplace error + expect_no_error(loss$backward()) + + # Gradients should be computed + expect_true(!is.null(output$grad)) + expect_tensor_shape(output$grad, output$shape) }) \ No newline at end of file From d6bb927bb5431a2fc6322f040aa4d650f993a78d Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sun, 7 Jun 2026 16:42:22 +0200 Subject: [PATCH 20/21] fix hardhat_hierarchical tests [ FAIL 0 | WARN 0 | SKIP 0 | PASS 24 ]52.92 sec elapsed --- R/hardhat.R | 3 +-- tests/testthat/test-hardhat_hierarchical.R | 10 ++-------- tests/testthat/test-hierarchical_utils.R | 4 ++-- 3 files changed, 5 insertions(+), 12 deletions(-) diff --git a/R/hardhat.R b/R/hardhat.R index af3b83b3..456d0a14 100644 --- a/R/hardhat.R +++ b/R/hardhat.R @@ -417,9 +417,8 @@ tabnet_bridge <- function(processed, config = tabnet_config(), tabnet_model, fro predict.tabnet_fit <- function(object, new_data, type = NULL, ..., epoch = NULL) { if (inherits(new_data, "Node") && !is.null(object$fit$config$ancestor)) { new_data_df <- node_to_df(new_data)$x - processed <- hardhat::forge(new_data_df, object$blueprint) # Enforces column order, type, column names, etc - processed$predictors <- get_constr_output(processed$predictors, object$fit$config$ancestor) + processed <- hardhat::forge(new_data_df, object$blueprint) } else { new_data_df <- new_data diff --git a/tests/testthat/test-hardhat_hierarchical.R b/tests/testthat/test-hardhat_hierarchical.R index 88fc6b71..91a7d4b2 100644 --- a/tests/testthat/test-hardhat_hierarchical.R +++ b/tests/testthat/test-hardhat_hierarchical.R @@ -23,8 +23,7 @@ test_that("Training hierarchical classification for {data.tree} Node with valida expect_no_error( fit <- tabnet_fit(attrition_tree, valid_split = 0.2, epochs = 1) ) - expect_named(fit$fit$config, "ancestor") - expect_true(fit$fit$config$ancestor$is_sparse()) + expect_true( "ancestor" %in% names(fit$fit$config)) expect_no_error( result <- predict(fit, attrition_tree, type = "prob") @@ -65,7 +64,6 @@ test_that("hierarchical classification for {data.tree} Node is explainable", { test_that("Training hierarchical classification for {data.tree} Node for starwars", { - # try to use starwars dataset with two forbidden column name starwars_tree <- starwars %>% rename(`_name` = "name", `_height` = "height") %>% mutate(species = coalesce(species, "Unknown_Species"), @@ -73,11 +71,7 @@ test_that("Training hierarchical classification for {data.tree} Node for starwar pathString = paste("StarWars_characters", species, sex, `_name`, sep = "/")) %>% as.Node() - expect_error( - check_compliant_node(starwars_tree) - ,"reserved names") - - fit <- tabnet_fit(starwars_tree, epochs = 1) + expect_no_error( fit <- tabnet_fit(starwars_tree, epochs = 1)) }) test_that("we properly check non-compliant colnames", { diff --git a/tests/testthat/test-hierarchical_utils.R b/tests/testthat/test-hierarchical_utils.R index 41d34ec5..b84ba267 100644 --- a/tests/testthat/test-hierarchical_utils.R +++ b/tests/testthat/test-hierarchical_utils.R @@ -15,7 +15,7 @@ test_that("returns correct shape and type for a simple 2-level hierarchy", { # 2 level_2 classes + 4 level_3 = 6 classes expect_tensor(result) expect_tensor_shape(result, c(1, 6, 6)) - expect_tensor_dtype(result, torch_double()) + expect_tensor_dtype(result, torch::torch_double()) }) test_that("handles ghost classes (present in tree but absent from outcomes)", { @@ -172,5 +172,5 @@ test_that("computes full transitive closure for deep hierarchies (3+ levels)", { expect_equal_to_r(result[1, 7, 3], 1) # -> L3_A1b # Self-loops on the diagonal (substracting the eye don't go to negative values) - expect_true((result$squeeze() - torch_eye(9))$min()$item() >= 0) + expect_true((result$squeeze() - torch::torch_eye(9))$min()$item() >= 0) }) \ No newline at end of file From d2bbfc4bf2a360656ef0196d85733dfca7815b20 Mon Sep 17 00:00:00 2001 From: "C. Regouby" Date: Sun, 7 Jun 2026 19:16:47 +0200 Subject: [PATCH 21/21] update news --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS.md b/NEWS.md index 88951d32..1c5b1f25 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # tabnet (development version) +## Bugfixes + +* Ancestor matrix is now taken into account for hierarchical classification (#188). + # tabnet 0.8.0 ## New features