fix seed forwarding and stats shape in save_model()

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

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)

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

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,36 +79,36 @@ 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."
     )
   }
 
   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)
   }
 

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,15 +42,15 @@ 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."
     )
   }
 
   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,29 +71,56 @@ 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."
     )
   }
 
   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."
     )
   }
 
   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
   }

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"
+  )
+})

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)

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)