Fix score percentile clamping for out-of-range values

R/helpers.R

@@ -57,7 +57,7 @@ get_inv <- function(X) {
 # Get percentile for new samples
 get_new_percentile <- function(ref, x_new, grid) {
   res <- approx(ref, grid, xout = x_new)$y
-  res[x_new < min(ref, na.rm = TRUE)] <- 0
-  res[x_new > max(ref, na.rm = TRUE)] <- 1
+  res[x_new < min(ref, na.rm = TRUE)] <- min(grid, na.rm = TRUE)
+  res[x_new > max(ref, na.rm = TRUE)] <- max(grid, na.rm = TRUE)
   res
 }

tests/testthat/test-isolation-score.R

@@ -16,3 +16,18 @@ test_that("scoring isolation forests", {
   raw_res <- unname(predict(res_df$model, cells_te))
   expect_equal(raw_res, score_te$score)
 })
+
+test_that("isolation score percentiles clamp to 100 for extreme scores", {
+  skip_if_not_installed("isotree")
+
+  mod <- apd_isolation(iris[, 1:4], nthreads = 1)
+  new_data <- tibble::tibble(
+    Sepal.Length = 1e9,
+    Sepal.Width = 1e9,
+    Petal.Length = 1e9,
+    Petal.Width = 1e9
+  )
+
+  res <- score(mod, new_data)
+  expect_equal(res$score_pctl, 100)
+})

tests/testthat/test-pca-score.R

@@ -78,3 +78,14 @@ test_that("`score_apd_pca_bridge` output is correct", {
     expected
   )
 })
+
+test_that("`score` percentiles clamp to 100 for extreme PCA values", {
+  model <- apd_pca(mtcars)
+  predictors <- mtcars[1, , drop = FALSE]
+  predictors[] <- predictors[] * 1000
+
+  pctls <- score(model, predictors) |>
+    dplyr::select(dplyr::ends_with("_pctl"))
+
+  expect_true(all(unlist(pctls, use.names = FALSE) == 100))
+})