diff --git a/DESCRIPTION b/DESCRIPTION index 247429f..4819704 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -49,10 +49,11 @@ Imports: tibble, tidyr (>= 1.0), tidyselect -Suggests: +Suggests: testthat (>= 2.1.0), knitr, - rmarkdown + rmarkdown, + kernlab Encoding: UTF-8 LazyData: true VignetteBuilder: knitr, rmarkdown diff --git a/NAMESPACE b/NAMESPACE index b57e424..9e83e72 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -41,6 +41,7 @@ importFrom(ggplot2,ggplot) importFrom(ggplot2,labs) importFrom(ggplot2,scale_color_manual) importFrom(ggplot2,theme_minimal) +importFrom(lifecycle,deprecate_stop) importFrom(lifecycle,deprecate_warn) importFrom(lifecycle,deprecated) importFrom(lifecycle,is_present) diff --git a/NEWS.md b/NEWS.md index e9a8106..2ed2b97 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,11 @@ # waves -# waves 0.2.8 (development version) +# waves 0.3.0 (development version) -* Deprecated arguments in `train_spectra()` and `test_spectra()` now throw errors instead of warnings. +* Bug fix: `save_model()` now correctly forwards `seed` to `test_spectra()`. Previously the argument was accepted but silently ignored, so every call ran with the default `seed = 1` regardless of the value supplied. This is the same class of bug fixed for `test_spectra()` in 0.2.7, one level up. Users who set a non-default `seed` in `save_model()` will see different (correctly seeded) results after this change. +* `save_model()` now returns and writes model statistics in a consistent shape regardless of how many pretreatments are supplied. Previously a single pretreatment produced three rows (`mean`/`sd`/`mode`) with plain metric names, while multiple pretreatments produced one row with `_mean`/`_sd`/`_mode` suffixes. Both now produce the one-row suffixed form. Code that read `$best.model.stats$RMSEp` from a single-pretreatment call should now read `$best.model.stats$RMSEp_mean`. +* Deprecated arguments in `train_spectra()`, `test_spectra()`, and `save_model()` now throw errors instead of warnings. In `save_model()` these are `save.model`, `wavelengths`, `autoselect.preprocessing`, and `preprocessing.method`. +* `kernlab` is now listed under `Suggests`; it is required at runtime by the `svmLinear` and `svmRadial` model methods. * `train_spectra()` and `test_spectra()` now return variable importance for `svmLinear` models. Importance is computed from the primal weight vector (absolute values of `w = X_sv^T * alpha`). # waves 0.2.7 diff --git a/R/save_model.R b/R/save_model.R index 32f2cdd..0b565fb 100644 --- a/R/save_model.R +++ b/R/save_model.R @@ -26,7 +26,7 @@ #' #' @importFrom utils write.csv #' @importFrom rlang abort -#' @importFrom lifecycle deprecated is_present deprecate_warn +#' @importFrom lifecycle deprecated is_present deprecate_stop #' @importFrom tibble add_column #' @importFrom magrittr %>% #' @@ -79,27 +79,27 @@ save_model <- function(df, autoselect.preprocessing = lifecycle::deprecated(), preprocessing.method = lifecycle::deprecated()) { - # Deprecate warnings + # Deprecated arguments -- these now throw errors, consistent with + # train_spectra() and test_spectra() (see handle_deprecations()). if (lifecycle::is_present(save.model)) { - lifecycle::deprecate_warn( - when = "0.2.0", + lifecycle::deprecate_stop( + when = "0.3.0", what = "save_model(save.model)", with = "save_model(write.model)" ) - write.model <- save.model } if (lifecycle::is_present(wavelengths)) { - lifecycle::deprecate_warn( - when = "0.2.0", + lifecycle::deprecate_stop( + when = "0.3.0", what = "save_model(wavelengths)", details = "Wavelength specification is now inferred from column names." ) } if (lifecycle::is_present(autoselect.preprocessing)) { - lifecycle::deprecate_warn( - when = "0.2.0", + lifecycle::deprecate_stop( + when = "0.3.0", what = "save_model(autoselect.preprocessing)", details = "If multiple pretreatment methods are supplied, the best will be selected automatically." @@ -107,8 +107,8 @@ save_model <- function(df, } if (lifecycle::is_present(preprocessing.method)) { - lifecycle::deprecate_warn( - when = "0.2.0", + lifecycle::deprecate_stop( + when = "0.3.0", what = "save_model(preprocessing.method)", with = "save_model(pretreatment)" ) @@ -154,14 +154,19 @@ save_model <- function(df, trial2 = trial2, trial3 = trial3, split.test = FALSE, + seed = seed, verbose = verbose ) if (length(pretreatment) == 1) { best.model <- training.results$model + # Widen to a single row so the returned and saved statistics have the same + # shape regardless of how many pretreatments were supplied. test_spectra() + # already returns the wide form when multiple pretreatments are used. best.model.stats <- training.results$summary.model.performance %>% tibble::add_column(Pretreatment = methods.list[pretreatment], - .before = "SummaryType") + .before = "SummaryType") %>% + widen_summary() if (verbose) print(best.model.stats) } diff --git a/R/utils.R b/R/utils.R index 0412a30..52bc5f0 100644 --- a/R/utils.R +++ b/R/utils.R @@ -30,7 +30,7 @@ get_mode <- function(vector.input) { #' @param return.model Deprecated; kept for compatibility #' @return `NULL` (warnings are issued as side effects) #' @keywords internal -#' @importFrom lifecycle is_present deprecate_warn +#' @importFrom lifecycle is_present deprecate_stop #' @noRd handle_deprecations <- function(function_name, wavelengths = lifecycle::deprecated(), @@ -42,7 +42,7 @@ handle_deprecations <- function(function_name, if (lifecycle::is_present(wavelengths)) { lifecycle::deprecate_stop( - when = "0.2.8", + when = "0.3.0", what = paste0(function_name, "(wavelengths)"), details = "Wavelength specification is now inferred from column names." ) @@ -50,7 +50,7 @@ handle_deprecations <- function(function_name, if (lifecycle::is_present(preprocessing)) { lifecycle::deprecate_stop( - when = "0.2.8", + when = "0.3.0", what = paste0(function_name, "(preprocessing)"), details = paste( "Argument `preprocessing` is deprecated.", @@ -62,7 +62,7 @@ handle_deprecations <- function(function_name, if (lifecycle::is_present(rf.variable.importance)) { lifecycle::deprecate_stop( - when = "0.2.8", + when = "0.3.0", what = paste0(function_name, "(rf.variable.importance)"), details = "Variable importance is now output by default when `model.method` is set to `pls`, `rf`, or `svmLinear`." @@ -71,7 +71,7 @@ handle_deprecations <- function(function_name, if (lifecycle::is_present(output.summary)) { lifecycle::deprecate_stop( - when = "0.2.8", + when = "0.3.0", what = paste0(function_name, "(output.summary)"), details = "Summary output is now returned by default." ) @@ -79,7 +79,7 @@ handle_deprecations <- function(function_name, if (lifecycle::is_present(save.model)) { lifecycle::deprecate_stop( - when = "0.2.8", + when = "0.3.0", what = paste0(function_name, "(save.model)"), details = "Models are now saved by default." ) @@ -87,13 +87,40 @@ handle_deprecations <- function(function_name, if (lifecycle::is_present(return.model)) { lifecycle::deprecate_stop( - when = "0.2.8", + when = "0.3.0", what = paste0(function_name, "(return.model)"), details = "Trained models are now returned by default." ) } } +#' Internal: widen a summary performance data.frame to one row +#' +#' Collapses the three-row (mean/sd/mode) summary produced by [train_spectra()] +#' into a single row whose columns are suffixed with the summary type, e.g. +#' `RMSEp_mean`, `RMSEp_sd`, `RMSEp_mode`. Metric and tuning columns are +#' selected by excluding the identifier columns, so the helper does not need to +#' be updated when the set of reported statistics changes. +#' +#' @param summary.df A summary performance `data.frame` containing +#' `Pretreatment`, `SummaryType`, and `ModelType` columns +#' @return A one-row `data.frame` keyed by `Pretreatment` +#' @keywords internal +#' @importFrom tidyr pivot_longer pivot_wider +#' @importFrom magrittr %>% +#' @noRd +widen_summary <- function(summary.df) { + summary.df %>% + tidyr::pivot_longer( + cols = !c("Pretreatment", "SummaryType", "ModelType") + ) %>% + tidyr::pivot_wider( + id_cols = "Pretreatment", + names_from = c("name", "SummaryType"), + names_sep = "_" + ) +} + #' Internal: validate common inputs for spectral functions #' #' Basic sanity checks used by training and testing workflows. @@ -620,13 +647,7 @@ aggregate_pretreatment_results <- function(training.results.i, } # Reformat summary statistics data.frame for multiple pretreatments - summary.i <- training.results.i$summary.model.performance %>% - tidyr::pivot_longer(cols = "RMSEp":"best.mtry") %>% - tidyr::pivot_wider( - id_cols = "Pretreatment", - names_from = c("name", "SummaryType"), - names_sep = "_" - ) + summary.i <- widen_summary(training.results.i$summary.model.performance) } else { summary.i <- training.results.i$summary.model.performance } diff --git a/tests/testthat/test-save_model.R b/tests/testthat/test-save_model.R new file mode 100644 index 0000000..062d84e --- /dev/null +++ b/tests/testthat/test-save_model.R @@ -0,0 +1,82 @@ +library(waves) +library(magrittr) + +test_df <- ikeogu.2017 %>% + dplyr::filter(study.name == "C16Mcal") %>% + dplyr::rename(reference = DMC.oven, unique.id = sample.id) %>% + dplyr::select(unique.id, reference, dplyr::starts_with("X")) %>% + na.omit() + +# ── Seed forwarding ──────────────────────────────────────────────────────────── + +test_that("save_model forwards seed to test_spectra", { + skip_on_cran() + r1 <- save_model(test_df, write.model = FALSE, pretreatment = 1, + tune.length = 3, num.iterations = 3, seed = 1, + verbose = FALSE) + r2 <- save_model(test_df, write.model = FALSE, pretreatment = 1, + tune.length = 3, num.iterations = 3, seed = 99999, + verbose = FALSE) + expect_false(identical(r1$best.model.stats$RMSEp_mean, + r2$best.model.stats$RMSEp_mean)) +}) + +test_that("save_model is reproducible with the same seed", { + skip_on_cran() + r1 <- save_model(test_df, write.model = FALSE, pretreatment = 1, + tune.length = 3, num.iterations = 3, seed = 42, + verbose = FALSE) + r2 <- save_model(test_df, write.model = FALSE, pretreatment = 1, + tune.length = 3, num.iterations = 3, seed = 42, + verbose = FALSE) + expect_identical(r1$best.model.stats$RMSEp_mean, r2$best.model.stats$RMSEp_mean) +}) + +# ── Output contract ──────────────────────────────────────────────────────────── + +test_that("save_model writes the file pair predict_spectra consumes", { + skip_on_cran() + tmp <- tempdir() + save_model(test_df, write.model = TRUE, pretreatment = 1, + model.save.folder = tmp, model.name = "sm_contract", + tune.length = 3, num.iterations = 2, verbose = FALSE) + expect_true(file.exists(file.path(tmp, "sm_contract.Rds"))) + expect_true(file.exists(file.path(tmp, "sm_contract_stats.csv"))) + # predict_spectra reads Pretreatment from the stats file + stats <- utils::read.csv(file.path(tmp, "sm_contract_stats.csv")) + expect_true("Pretreatment" %in% names(stats)) +}) + +test_that("save_model selects a single best model across pretreatments", { + skip_on_cran() + result <- save_model(test_df, write.model = FALSE, pretreatment = 1:3, + tune.length = 3, num.iterations = 2, verbose = FALSE) + expect_equal(nrow(result$best.model.stats), 1) + expect_false(inherits(result$best.model, "list")) +}) + +test_that("save_model stats have the same shape for one or many pretreatments", { + skip_on_cran() + one <- save_model(test_df, write.model = FALSE, pretreatment = 1, + tune.length = 3, num.iterations = 2, verbose = FALSE) + many <- save_model(test_df, write.model = FALSE, pretreatment = 1:3, + tune.length = 3, num.iterations = 2, verbose = FALSE) + expect_equal(nrow(one$best.model.stats), 1) + expect_equal(nrow(many$best.model.stats), 1) + expect_identical(names(one$best.model.stats), names(many$best.model.stats)) +}) + +# ── Deprecated arguments now error ───────────────────────────────────────────── + +test_that("save_model deprecated arguments throw errors", { + expect_error( + save_model(test_df, write.model = FALSE, num.iterations = 2, + save.model = TRUE), + class = "lifecycle_error_deprecated" + ) + expect_error( + save_model(test_df, write.model = FALSE, num.iterations = 2, + autoselect.preprocessing = TRUE), + class = "lifecycle_error_deprecated" + ) +}) diff --git a/tests/testthat/test-test_spectra.R b/tests/testthat/test-test_spectra.R index 8d61f99..6e0c868 100644 --- a/tests/testthat/test-test_spectra.R +++ b/tests/testthat/test-test_spectra.R @@ -48,6 +48,7 @@ test_that("test_spectra accepts both valid best.model.metric values without erro test_that("test_spectra svmLinear returns importance with multiple pretreatments", { skip_on_cran() + skip_if_not_installed("kernlab") result <- test_spectra(test_df, num.iterations = 2, tune.length = 3, pretreatment = 1:2, model.method = "svmLinear", verbose = FALSE) diff --git a/tests/testthat/test-train_spectra.R b/tests/testthat/test-train_spectra.R index daf3bce..c89ae77 100644 --- a/tests/testthat/test-train_spectra.R +++ b/tests/testthat/test-train_spectra.R @@ -59,6 +59,7 @@ test_that("train_spectra RF final model uses modal best mtry from iterations", { test_that("train_spectra SVM final model does not include unique.id as predictor", { skip_on_cran() + skip_if_not_installed("kernlab") result <- train_spectra(test_df, num.iterations = 3, tune.length = 3, model.method = "svmLinear", verbose = FALSE) expect_false("unique.id" %in% result$model$coefnames)