From 5ddfcf9930a79a53a969b3bd4758b2dee484c44e Mon Sep 17 00:00:00 2001 From: topepo Date: Tue, 29 Jul 2025 17:22:02 -0400 Subject: [PATCH 1/2] Changes for #180 --- DESCRIPTION | 2 +- tests/testthat/_snaps/cal-plot.md | 243 ++++++++++++++++++++++++++++++ tests/testthat/test-cal-plot.R | 50 ++---- 3 files changed, 260 insertions(+), 35 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 868d1a7..44f5438 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,7 +25,7 @@ Imports: dplyr (>= 1.1.0), furrr, generics (>= 0.1.3), - ggplot2, + ggplot2 (>= 3.5.2), hardhat, pillar, purrr, diff --git a/tests/testthat/_snaps/cal-plot.md b/tests/testthat/_snaps/cal-plot.md index 64c8c1a..c0fba43 100644 --- a/tests/testthat/_snaps/cal-plot.md +++ b/tests/testthat/_snaps/cal-plot.md @@ -1,5 +1,44 @@ # Binary breaks functions work with group argument + Code + get_labs(res) + Output + $colour + [1] "id" + + $fill + [1] "id" + + $x.sec + NULL + + $x + [1] "Bin Midpoint" + + $y + [1] "Event Rate" + + $y.sec + NULL + + $intercept + [1] "intercept" + + $slope + [1] "slope" + + $ymin + [1] "lower" + + $ymax + [1] "upper" + + $alt + [1] "" + + +--- + x `.by` cannot select more than one column. i The following 2 columns were selected: i group1 and group2 @@ -11,6 +50,45 @@ # Binary logistic functions work with group argument + Code + get_labs(res) + Output + $colour + [1] "id" + + $fill + [1] "id" + + $x.sec + NULL + + $x + [1] "Probability" + + $y + [1] "Predicted Event Rate" + + $y.sec + NULL + + $intercept + [1] "intercept" + + $slope + [1] "slope" + + $ymin + [1] "lower" + + $ymax + [1] "upper" + + $alt + [1] "" + + +--- + x `.by` cannot select more than one column. i The following 2 columns were selected: i group1 and group2 @@ -33,6 +111,171 @@ Caused by error: ! Invalid `event_level` entry: invalid. Valid entries are "first", "second", or "auto". +# regression functions work + + Code + get_labs(res) + Output + $x.sec + NULL + + $x + [1] "Observed" + + $y + [1] "Predicted" + + $y.sec + NULL + + $intercept + [1] "intercept" + + $slope + [1] "slope" + + $colour + [1] "colour" + + $fill + [1] "fill" + + $alt + [1] "" + + +--- + + Code + get_labs(res) + Output + $x.sec + NULL + + $x + [1] "Observed" + + $y + [1] "Predicted" + + $y.sec + NULL + + $intercept + [1] "intercept" + + $slope + [1] "slope" + + $colour + [1] "colour" + + $fill + [1] "fill" + + $alt + [1] "" + + +--- + + Code + get_labs(res) + Output + $x.sec + NULL + + $x + [1] "Observed" + + $y + [1] "Predicted" + + $y.sec + NULL + + $intercept + [1] "intercept" + + $slope + [1] "slope" + + $colour + [1] "colour" + + $fill + [1] "fill" + + $alt + [1] "" + + +--- + + Code + get_labs(res) + Output + $x.sec + NULL + + $x + [1] "Observed" + + $y + [1] "Predicted" + + $y.sec + NULL + + $intercept + [1] "intercept" + + $slope + [1] "slope" + + $colour + [1] "colour" + + $fill + [1] "fill" + + $alt + [1] "" + + +--- + + Code + get_labs(res) + Output + $x.sec + NULL + + $x + [1] "Observed" + + $y + [1] "Predicted" + + $y.sec + NULL + + $intercept + [1] "intercept" + + $slope + [1] "slope" + + $colour + [1] "colour" + + $fill + [1] "fill" + + $alt + [1] "" + + # regression plot function errors - grouped_df x This function does not work with grouped data frames. diff --git a/tests/testthat/test-cal-plot.R b/tests/testthat/test-cal-plot.R index cc15b44..0f0c82d 100644 --- a/tests/testthat/test-cal-plot.R +++ b/tests/testthat/test-cal-plot.R @@ -57,10 +57,9 @@ test_that("Binary breaks functions work with group argument", { rlang::expr_text(res$mapping$fill), "~id" ) - expect_equal( - res$labels, - list(x = "Bin Midpoint", y = "Event Rate") - ) + + expect_snapshot(get_labs(res)) + expect_equal(length(res$layers), 4) expect_snapshot_error( @@ -253,10 +252,9 @@ test_that("Binary logistic functions work with group argument", { rlang::expr_text(res$mapping$fill), "~id" ) - expect_equal( - res$labels, - list(x = "Probability", y = "Predicted Event Rate") - ) + + expect_snapshot(get_labs(res)) + expect_equal(length(res$layers), 3) expect_snapshot_error( @@ -510,12 +508,9 @@ test_that("regression functions work", { expect_null(res$mapping$colour) expect_null(res$mapping$fill) - expect_equal( - res$labels, - list(x = "Observed", y = "Predicted") - ) - expect_equal(length(res$layers), 3) + expect_snapshot(get_labs(res)) + expect_equal(length(res$layers), 3) res <- cal_plot_regression(boosting_predictions_oob, outcome, .pred, .by = id) expect_s3_class(res, "ggplot") @@ -536,12 +531,9 @@ test_that("regression functions work", { expect_null(res$mapping$colour) expect_null(res$mapping$fill) - expect_equal( - res$labels, - list(x = "Observed", y = "Predicted") - ) - expect_equal(length(res$layers), 3) + expect_snapshot(get_labs(res)) + expect_equal(length(res$layers), 3) res <- cal_plot_regression(obj) expect_s3_class(res, "ggplot") @@ -565,12 +557,9 @@ test_that("regression functions work", { expect_null(res$mapping$colour) expect_null(res$mapping$fill) - expect_equal( - res$labels, - list(x = "Observed", y = "Predicted") - ) - expect_equal(length(res$layers), 3) + expect_snapshot(get_labs(res)) + expect_equal(length(res$layers), 3) res <- print(cal_plot_regression(obj), alpha = 1 / 5, smooth = FALSE) expect_s3_class(res, "ggplot") @@ -594,12 +583,9 @@ test_that("regression functions work", { expect_null(res$mapping$colour) expect_null(res$mapping$fill) - expect_equal( - res$labels, - list(x = "Observed", y = "Predicted") - ) - expect_equal(length(res$layers), 3) + expect_snapshot(get_labs(res)) + expect_equal(length(res$layers), 3) res <- cal_plot_regression(boosting_predictions_oob, outcome, .pred, smooth = FALSE) expect_s3_class(res, "ggplot") @@ -621,13 +607,9 @@ test_that("regression functions work", { expect_null(res$mapping$colour) expect_null(res$mapping$fill) - expect_equal( - res$labels, - list(x = "Observed", y = "Predicted") - ) - expect_equal(length(res$layers), 3) - + expect_snapshot(get_labs(res)) + expect_equal(length(res$layers), 3) }) test_that("regression plot function errors - grouped_df", { From ff0fa4aec19143314af1bb7b94b09eef085a58bd Mon Sep 17 00:00:00 2001 From: topepo Date: Tue, 29 Jul 2025 17:22:09 -0400 Subject: [PATCH 2/2] other test updates --- tests/testthat/_snaps/cal-estimate.md | 53 +++++++++++++++++++++++ tests/testthat/test-cal-estimate.R | 18 ++++---- tests/testthat/test-conformal-intervals.R | 4 +- 3 files changed, 63 insertions(+), 12 deletions(-) diff --git a/tests/testthat/_snaps/cal-estimate.md b/tests/testthat/_snaps/cal-estimate.md index f82ddfd..396d78b 100644 --- a/tests/testthat/_snaps/cal-estimate.md +++ b/tests/testthat/_snaps/cal-estimate.md @@ -123,6 +123,24 @@ `.pred_class_1` ==> class_1 `.pred_class_2` ==> class_2 +# Logistic spline switches to linear if too few unique + + Code + sl_gam <- cal_estimate_logistic(segment_logistic, Class, smooth = TRUE) + Condition + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + +--- + + Code + sl_gam <- cal_estimate_logistic(segment_logistic, Class, .by = id, smooth = TRUE) + Condition + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + # Isotonic estimates work - data.frame Code @@ -523,6 +541,41 @@ Warning: Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. +--- + + Code + sl_gam <- cal_estimate_linear(boosting_predictions_oob, outcome, smooth = TRUE) + Condition + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + +--- + + Code + sl_gam <- cal_estimate_linear(boosting_predictions_oob, outcome, .by = id, + smooth = TRUE) + Condition + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + Warning: + Too few unique observations for spline-based calibrator. Setting `smooth = FALSE`. + # Multinomial spline switches to linear if too few unique Code diff --git a/tests/testthat/test-cal-estimate.R b/tests/testthat/test-cal-estimate.R index 2261181..67f65fd 100644 --- a/tests/testthat/test-cal-estimate.R +++ b/tests/testthat/test-cal-estimate.R @@ -121,7 +121,6 @@ test_that("Logistic spline estimates work - tune_results", { test_that("Logistic spline switches to linear if too few unique", { skip_if_not_installed("modeldata") - skip("until refactored") segment_logistic$.pred_good <- rep( x = 1, @@ -134,8 +133,8 @@ test_that("Logistic spline switches to linear if too few unique", { sl_lm <- cal_estimate_logistic(segment_logistic, Class, smooth = FALSE) expect_identical( - sl_gam, - sl_lm + sl_gam$estimates[[1]]$estimate[[1]], + sl_lm$estimates[[1]]$estimate[[1]] ) segment_logistic$id <- rep( @@ -148,8 +147,8 @@ test_that("Logistic spline switches to linear if too few unique", { sl_lm <- cal_estimate_logistic(segment_logistic, Class, .by = id, smooth = FALSE) expect_identical( - sl_gam, - sl_lm + sl_gam$estimates[[1]]$estimate[[1]], + sl_lm$estimates[[1]]$estimate[[1]] ) }) @@ -619,7 +618,6 @@ test_that("Linear spline estimates work - tune_results", { test_that("Linear spline switches to linear if too few unique", { skip_if_not_installed("modeldata") - skip("until refactored") boosting_predictions_oob$.pred <- rep( x = 1:5, @@ -632,8 +630,8 @@ test_that("Linear spline switches to linear if too few unique", { sl_lm <- cal_estimate_linear(boosting_predictions_oob, outcome, smooth = FALSE) expect_identical( - sl_gam, - sl_lm + sl_gam$estimates[[1]]$estimate[[1]], + sl_lm$estimates[[1]]$estimate[[1]] ) expect_snapshot( @@ -642,8 +640,8 @@ test_that("Linear spline switches to linear if too few unique", { sl_lm <- cal_estimate_linear(boosting_predictions_oob, outcome, .by = id, smooth = FALSE) expect_identical( - sl_gam, - sl_lm + sl_gam$estimates[[1]]$estimate[[1]], + sl_lm$estimates[[1]]$estimate[[1]] ) }) diff --git a/tests/testthat/test-conformal-intervals.R b/tests/testthat/test-conformal-intervals.R index 27c22a3..467fada 100644 --- a/tests/testthat/test-conformal-intervals.R +++ b/tests/testthat/test-conformal-intervals.R @@ -185,7 +185,7 @@ test_that("conformal intervals", { parsnip::linear_reg() |> fit_resamples(outcome ~ ., cv, control = ctrl) grid_res <- parsnip::mlp(penalty = tune()) |> - set_mode("regression") |> + parsnip::set_mode("regression") |> tune_grid(outcome ~ ., cv, grid = 2, control = ctrl) # ---------------------------------------------------------------------------- @@ -258,7 +258,7 @@ test_that("group resampling to conformal CV intervals", { set.seed(484) nnet_wflow <- - workflow(y ~ x, mlp(hidden_units = 2) |> set_mode("regression")) + workflow(y ~ x, parsnip::mlp(hidden_units = 2) |> parsnip::set_mode("regression")) group_folds <- group_vfold_cv(train_data, group = color)