Test that all models work with as_parsed_model() (#163)

EmilHvitfeldt · web-flow · commit 3fb36945fdd0 · 2025-11-04T10:02:52.000-08:00
diff --git a/R/model-cubist.R b/R/model-cubist.R
@@ -64,13 +64,33 @@ parse_model.cubist <- function(model) {
     }
   )
   comm <- purrr::list_flatten(committees2)
+
+  if (model$committees == 1) {
+    ommittee_id <- rep(1, length(comm))
+  } else {
+    model_print <- utils::capture.output(print(model))
+    model_print <- model_print[grep(
+      "Number of rules per committee",
+      model_print
+    )]
+    model_print <- regmatches(
+      model_print,
+      m = gregexpr("[0-9]+", model_print)
+    )[[
+      1
+    ]]
+    ommittee_id <- as.integer(model_print)
+    ommittee_id <- rep(seq_along(ommittee_id), times = ommittee_id)
+  }
+
   pm <- list(
     general = list(
       model = "cubist",
       type = "tree",
-      version = 2,
+      version = 3,
       mode = "ifelse",
-      divisor = model$committees
+      n_committees = model$committees,
+      ommittee_id = ommittee_id
     ),
     trees = list(comm)
   )
@@ -80,28 +100,15 @@ parse_model.cubist <- function(model) {
 #' @export
 tidypredict_fit.cubist <- function(model) {
   parsedmodel <- parse_model(model)
+  tidypredict_fit_cubist(parsedmodel)
+}
+
+tidypredict_fit_cubist <- function(parsedmodel) {
   rules <- generate_tree_nodes(parsedmodel$trees[[1]], parsedmodel$general$mode)
   paths <- lapply(parsedmodel$trees[[1]], function(x) path_formulas(x$path))
 
-  n_committees <- model$committees
-
-  if (n_committees == 1) {
-    ommittee_id <- rep(1, length(rules))
-  } else {
-    model_print <- utils::capture.output(print(model))
-    model_print <- model_print[grep(
-      "Number of rules per committee",
-      model_print
-    )]
-    model_print <- regmatches(
-      model_print,
-      m = gregexpr("[0-9]+", model_print)
-    )[[
-      1
-    ]]
-    ommittee_id <- as.integer(model_print)
-    ommittee_id <- rep(seq_along(ommittee_id), times = ommittee_id)
-  }
+  n_committees <- parsedmodel$general$n_committees
+  ommittee_id <- parsedmodel$general$ommittee_id
 
   committees <- purrr::map2(
     split(rules, ommittee_id),
diff --git a/R/model-rf.R b/R/model-rf.R
@@ -86,6 +86,10 @@ parse_model.randomForest <- function(model) {
 #' @export
 tidypredict_fit.randomForest <- function(model) {
   parsedmodel <- parse_model(model)
+  tidypredict_fit_randomForest(parsedmodel)
+}
+
+tidypredict_fit_randomForest <- function(parsedmodel) {
   res <- generate_case_when_trees(parsedmodel)
   res <- reduce_addition(res)
   n_trees <- length(parsedmodel$trees)
diff --git a/R/predict-fit.R b/R/predict-fit.R
@@ -21,7 +21,16 @@ tidypredict_fit.pm_regression <- function(model) {
 
 #' @export
 tidypredict_fit.pm_tree <- function(model) {
-  generate_case_when_trees(model)
+  if (model$general$model == "cubist") {
+    return(tidypredict_fit_cubist(model))
+  }
+  if (model$general$model == "randomForest") {
+    return(tidypredict_fit_randomForest(model))
+  }
+
+  res <- generate_case_when_trees(model)
+
+  reduce_addition(res)
 }
 
 #' @export
diff --git a/tests/testthat/_snaps/model-cubist.md b/tests/testthat/_snaps/model-cubist.md
@@ -5,15 +5,6 @@
     Output
       [1] "(37.2 + hp * -0.0318 + wt * -3.88 + (ifelse(disp > 95.099998, \n    14.89 + hp * -0.0406 + drat * 2.4, 0) + ifelse(disp <= 95.099998, \n    33.06, 0))/((disp > 95.099998) + (disp <= 95.099998)) + (37.26 + \n    wt * -5.28))/3"
 
-# Model can be saved and re-loaded
-
-    Code
-      tidypredict_fit(pm)
-    Output
-      (37.2 + hp * -0.0318 + wt * -3.88 + ifelse(disp > 95.099998, 
-          14.89 + hp * -0.0406 + drat * 2.4, 0) + ifelse(disp <= 95.099998, 
-          33.06, 0) + (37.26 + wt * -5.28))/3
-
 # formulas produces correct predictions
 
     Code
diff --git a/tests/testthat/_snaps/model-earth.md b/tests/testthat/_snaps/model-earth.md
@@ -5,14 +5,6 @@
     Output
       [1] "20.534817535821 + (ifelse(disp < 145, 145 - disp, 0) * 0.148589866311) + \n    (ifelse(disp > 145, disp - 145, 0) * -0.025012854678)"
 
-# Model can be saved and re-loaded
-
-    Code
-      tidypredict_fit(pm)
-    Output
-      20.5348175 + (ifelse(disp < 145, 145 - disp, 0) * 0.1485899) + 
-          (ifelse(disp > 145, disp - 145, 0) * -0.0250129)
-
 # formulas produces correct predictions
 
     Code
diff --git a/tests/testthat/_snaps/model-glm.md b/tests/testthat/_snaps/model-glm.md
@@ -5,13 +5,6 @@
     Output
       [1] "1.520331147866 + (wt * -0.372988616484) + (cyl * 0.013885491477)"
 
-# Model can be saved and re-loaded
-
-    Code
-      tidypredict_fit(pm)
-    Output
-      1.5203311 + (wt * -0.3729886) + (cyl * 0.0138855)
-
 # formulas produces correct predictions
 
     Code
diff --git a/tests/testthat/_snaps/model-lm.md b/tests/testthat/_snaps/model-lm.md
@@ -5,13 +5,6 @@
     Output
       [1] "1.520331147866 + (wt * -0.372988616484) + (cyl * 0.013885491477)"
 
-# Model can be saved and re-loaded
-
-    Code
-      tidypredict_fit(pm)
-    Output
-      1.5203311 + (wt * -0.3729886) + (cyl * 0.0138855)
-
 # formulas produces correct predictions
 
     Code
diff --git a/tests/testthat/_snaps/model-partykit.md b/tests/testthat/_snaps/model-partykit.md
@@ -5,16 +5,6 @@
     Output
       [1] "case_when(cyl <= 4 ~ 26.6636363636364, cyl <= 6 & cyl > 4 ~ 19.7428571428571, \n    cyl > 6 & cyl > 4 ~ 15.1)"
 
-# Model can be saved and re-loaded
-
-    Code
-      tidypredict_fit(pm)
-    Output
-      [[1]]
-      case_when(cyl <= 4 ~ 26.6636364, cyl <= 6 & cyl > 4 ~ 19.7428571, 
-          cyl > 6 & cyl > 4 ~ 15.1)
-      
-
 # formulas produces correct predictions
 
     Code
diff --git a/tests/testthat/_snaps/model-ranger.md b/tests/testthat/_snaps/model-ranger.md
@@ -5,27 +5,6 @@
     Output
       [1] "case_when(Petal.Length < 2.6 ~ \"setosa\", Sepal.Length < 6.25 & \n    Petal.Length >= 2.6 ~ \"versicolor\", Sepal.Length >= 6.25 & \n    Petal.Length >= 2.6 ~ \"virginica\") + case_when(Petal.Width < \n    0.75 ~ \"setosa\", Petal.Width < 1.75 & Petal.Width >= 0.75 ~ \n    \"versicolor\", Petal.Width >= 1.75 & Petal.Width >= 0.75 ~ \n    \"virginica\") + case_when(Petal.Length < 2.35 ~ \"setosa\", \n    Petal.Length < 4.75 & Petal.Length >= 2.35 ~ \"versicolor\", \n    Petal.Length >= 4.75 & Petal.Length >= 2.35 ~ \"virginica\")"
 
-# Model can be saved and re-loaded
-
-    Code
-      tidypredict_fit(pm)
-    Output
-      [[1]]
-      case_when(Petal.Length < 2.6 ~ "setosa", Sepal.Length < 6.25 & 
-          Petal.Length >= 2.6 ~ "versicolor", Sepal.Length >= 6.25 & 
-          Petal.Length >= 2.6 ~ "virginica")
-      
-      [[2]]
-      case_when(Petal.Width < 0.75 ~ "setosa", Petal.Width < 1.75 & 
-          Petal.Width >= 0.75 ~ "versicolor", Petal.Width >= 1.75 & 
-          Petal.Width >= 0.75 ~ "virginica")
-      
-      [[3]]
-      case_when(Petal.Length < 2.35 ~ "setosa", Petal.Length < 4.75 & 
-          Petal.Length >= 2.35 ~ "versicolor", Petal.Length >= 4.75 & 
-          Petal.Length >= 2.35 ~ "virginica")
-      
-
 # formulas produces correct predictions
 
     Code
diff --git a/tests/testthat/_snaps/model-rf.md b/tests/testthat/_snaps/model-rf.md
@@ -5,54 +5,6 @@
     Output
       [1] "(case_when(disp < 78.85 & wt < 2.3325 ~ 33.525, disp >= 78.85 & \n    wt < 2.3325 ~ 27.425, disp >= 281 & wt >= 2.3325 ~ 14.1, \n    drat < 3.695 & cyl < 5 & disp < 281 & wt >= 2.3325 ~ 24.4, \n    drat >= 3.695 & cyl < 5 & disp < 281 & wt >= 2.3325 ~ 22.3666666666667, \n    disp < 152.5 & wt < 3.3275 & cyl >= 5 & disp < 281 & wt >= \n        2.3325 ~ 19.7, disp >= 152.5 & wt < 3.3275 & cyl >= 5 & \n        disp < 281 & wt >= 2.3325 ~ 21.1, disp < 196.3 & wt >= \n        3.3275 & cyl >= 5 & disp < 281 & wt >= 2.3325 ~ 18.92, \n    disp >= 196.3 & wt >= 3.3275 & cyl >= 5 & disp < 281 & wt >= \n        2.3325 ~ 18.1) + case_when(hp < 80.5 & disp < 266.9 ~ \n    28.5333333333333, drat < 3.035 & disp >= 266.9 ~ 10.4, carb < \n    2.5 & drat >= 3.035 & disp >= 266.9 ~ 18.7, wt < 1.989 & \n    hp < 118 & hp >= 80.5 & disp < 266.9 ~ 30.4, qsec < 18.6 & \n    hp >= 118 & hp >= 80.5 & disp < 266.9 ~ 19.6, qsec >= 18.6 & \n    hp >= 118 & hp >= 80.5 & disp < 266.9 ~ 17.8, drat >= 3.635 & \n    carb >= 2.5 & drat >= 3.035 & disp >= 266.9 ~ 13.3, hp < \n    96 & wt >= 1.989 & hp < 118 & hp >= 80.5 & disp < 266.9 ~ \n    22.8, wt < 4.5625 & drat < 3.635 & carb >= 2.5 & drat >= \n    3.035 & disp >= 266.9 ~ 15.04, wt >= 4.5625 & drat < 3.635 & \n    carb >= 2.5 & drat >= 3.035 & disp >= 266.9 ~ 14.7, qsec < \n    19.725 & hp >= 96 & wt >= 1.989 & hp < 118 & hp >= 80.5 & \n    disp < 266.9 ~ 21.4, qsec >= 19.725 & hp >= 96 & wt >= 1.989 & \n    hp < 118 & hp >= 80.5 & disp < 266.9 ~ 21.5) + case_when(wt < \n    3.4725 & drat < 3.75 ~ 20.8333333333333, qsec < 16.23 & wt >= \n    3.4725 & drat < 3.75 ~ 13.3, disp < 78.85 & disp < 130.55 & \n    drat >= 3.75 ~ 32.2333333333333, disp >= 78.85 & disp < 130.55 & \n    drat >= 3.75 ~ 27.75, cyl < 5 & disp >= 130.55 & drat >= \n    3.75 ~ 22.8, disp >= 456 & qsec >= 16.23 & wt >= 3.4725 & \n    drat < 3.75 ~ 10.4, qsec < 17.66 & cyl >= 5 & disp >= 130.55 & \n    drat >= 3.75 ~ 21, qsec >= 17.66 & cyl >= 5 & disp >= 130.55 & \n    drat >= 3.75 ~ 19.2, qsec < 17.225 & disp < 456 & qsec >= \n    16.23 & wt >= 3.4725 & drat < 3.75 ~ 19.2, wt < 4.7075 & \n    qsec >= 17.225 & disp < 456 & qsec >= 16.23 & wt >= 3.4725 & \n    drat < 3.75 ~ 16.34, wt >= 4.7075 & qsec >= 17.225 & disp < \n    456 & qsec >= 16.23 & wt >= 3.4725 & drat < 3.75 ~ 14.7))/3L"
 
-# Model can be saved and re-loaded
-
-    Code
-      tidypredict_fit(pm)
-    Output
-      [[1]]
-      case_when(disp < 78.85 & wt < 2.3325 ~ 33.525, disp >= 78.85 & 
-          wt < 2.3325 ~ 27.425, disp >= 281 & wt >= 2.3325 ~ 14.1, 
-          drat < 3.695 & cyl < 5 & disp < 281 & wt >= 2.3325 ~ 24.4, 
-          drat >= 3.695 & cyl < 5 & disp < 281 & wt >= 2.3325 ~ 22.3666667, 
-          disp < 152.5 & wt < 3.3275 & cyl >= 5 & disp < 281 & wt >= 
-              2.3325 ~ 19.7, disp >= 152.5 & wt < 3.3275 & cyl >= 5 & 
-              disp < 281 & wt >= 2.3325 ~ 21.1, disp < 196.3 & wt >= 
-              3.3275 & cyl >= 5 & disp < 281 & wt >= 2.3325 ~ 18.92, 
-          disp >= 196.3 & wt >= 3.3275 & cyl >= 5 & disp < 281 & wt >= 
-              2.3325 ~ 18.1)
-      
-      [[2]]
-      case_when(hp < 80.5 & disp < 266.9 ~ 28.5333333, drat < 3.035 & 
-          disp >= 266.9 ~ 10.4, carb < 2.5 & drat >= 3.035 & disp >= 
-          266.9 ~ 18.7, wt < 1.989 & hp < 118 & hp >= 80.5 & disp < 
-          266.9 ~ 30.4, qsec < 18.6 & hp >= 118 & hp >= 80.5 & disp < 
-          266.9 ~ 19.6, qsec >= 18.6 & hp >= 118 & hp >= 80.5 & disp < 
-          266.9 ~ 17.8, drat >= 3.635 & carb >= 2.5 & drat >= 3.035 & 
-          disp >= 266.9 ~ 13.3, hp < 96 & wt >= 1.989 & hp < 118 & 
-          hp >= 80.5 & disp < 266.9 ~ 22.8, wt < 4.5625 & drat < 3.635 & 
-          carb >= 2.5 & drat >= 3.035 & disp >= 266.9 ~ 15.04, wt >= 
-          4.5625 & drat < 3.635 & carb >= 2.5 & drat >= 3.035 & disp >= 
-          266.9 ~ 14.7, qsec < 19.725 & hp >= 96 & wt >= 1.989 & hp < 
-          118 & hp >= 80.5 & disp < 266.9 ~ 21.4, qsec >= 19.725 & 
-          hp >= 96 & wt >= 1.989 & hp < 118 & hp >= 80.5 & disp < 266.9 ~ 
-          21.5)
-      
-      [[3]]
-      case_when(wt < 3.4725 & drat < 3.75 ~ 20.8333333, qsec < 16.23 & 
-          wt >= 3.4725 & drat < 3.75 ~ 13.3, disp < 78.85 & disp < 
-          130.55 & drat >= 3.75 ~ 32.2333333, disp >= 78.85 & disp < 
-          130.55 & drat >= 3.75 ~ 27.75, cyl < 5 & disp >= 130.55 & 
-          drat >= 3.75 ~ 22.8, disp >= 456 & qsec >= 16.23 & wt >= 
-          3.4725 & drat < 3.75 ~ 10.4, qsec < 17.66 & cyl >= 5 & disp >= 
-          130.55 & drat >= 3.75 ~ 21, qsec >= 17.66 & cyl >= 5 & disp >= 
-          130.55 & drat >= 3.75 ~ 19.2, qsec < 17.225 & disp < 456 & 
-          qsec >= 16.23 & wt >= 3.4725 & drat < 3.75 ~ 19.2, wt < 4.7075 & 
-          qsec >= 17.225 & disp < 456 & qsec >= 16.23 & wt >= 3.4725 & 
-          drat < 3.75 ~ 16.34, wt >= 4.7075 & qsec >= 17.225 & disp < 
-          456 & qsec >= 16.23 & wt >= 3.4725 & drat < 3.75 ~ 14.7)
-      
-
 # formulas produces correct predictions
 
     Code
diff --git a/tests/testthat/_snaps/model-xgboost.md b/tests/testthat/_snaps/model-xgboost.md
@@ -5,25 +5,6 @@
     Output
       [1] "case_when((qsec < 19.9549999 | is.na(qsec)) & (wt < 3.18000007 | \n    is.na(wt)) ~ 0.138461545, qsec >= 19.9549999 & (wt < 3.18000007 | \n    is.na(wt)) ~ -0.100000009, (hp < 290 | is.na(hp)) & wt >= \n    3.18000007 ~ -0.141666666, hp >= 290 & wt >= 3.18000007 ~ \n    0.075000003) + case_when((qsec < 19.9549999 | is.na(qsec)) & \n    (wt < 3.01250005 | is.na(wt)) ~ 0.0994230807, qsec >= 19.9549999 & \n    (wt < 3.01250005 | is.na(wt)) ~ -0.0599999987, (hp < 254.5 | \n    is.na(hp)) & wt >= 3.01250005 ~ -0.102500007, hp >= 254.5 & \n    wt >= 3.01250005 ~ 0.0786538497) + case_when((gear < 3.5 | \n    is.na(gear)) ~ -0.0735312551, (wt < 3.01250005 | is.na(wt)) & \n    gear >= 3.5 ~ 0.0720817298, wt >= 3.01250005 & gear >= 3.5 ~ \n    -0.0186758228) + case_when((gear < 3.5 | is.na(gear)) ~ -0.0528505854, \n    (qsec < 19.9500008 | is.na(qsec)) & gear >= 3.5 ~ 0.0427994467, \n    qsec >= 19.9500008 & gear >= 3.5 ~ -0.0515981652) + 0.5"
 
-# Model can be saved and re-loaded
-
-    Code
-      tidypredict_fit(pm)
-    Output
-      case_when((qsec < 19.9549999 | is.na(qsec)) & (wt < 3.1800001 | 
-          is.na(wt)) ~ 0.1384615, qsec >= 19.9549999 & (wt < 3.1800001 | 
-          is.na(wt)) ~ -0.1, (hp < 290 | is.na(hp)) & wt >= 3.1800001 ~ 
-          -0.1416667, hp >= 290 & wt >= 3.1800001 ~ 0.075) + case_when((qsec < 
-          19.9549999 | is.na(qsec)) & (wt < 3.0125 | is.na(wt)) ~ 0.0994231, 
-          qsec >= 19.9549999 & (wt < 3.0125 | is.na(wt)) ~ -0.06, (hp < 
-              254.5 | is.na(hp)) & wt >= 3.0125 ~ -0.1025, hp >= 254.5 & 
-              wt >= 3.0125 ~ 0.0786538) + case_when((gear < 3.5 | is.na(gear)) ~ 
-          -0.0735313, (wt < 3.0125 | is.na(wt)) & gear >= 3.5 ~ 0.0720817, 
-          wt >= 3.0125 & gear >= 3.5 ~ -0.0186758) + case_when((gear < 
-          3.5 | is.na(gear)) ~ -0.0528506, (qsec < 19.9500008 | is.na(qsec)) & 
-          gear >= 3.5 ~ 0.0427994, qsec >= 19.9500008 & gear >= 3.5 ~ 
-          -0.0515982) + 0.5
-
 # formulas produces correct predictions
 
     Code
diff --git a/tests/testthat/helper-printing.R b/tests/testthat/helper-printing.R
@@ -0,0 +1,14 @@
+round_print <- function(x, digits = 7) {
+  x <- expr_text(x)
+  x <- gsub("[ \t\r\n]+", " ", x)
+  old_values <- regmatches(x, gregexpr("[0-9]+\\.?[0-9]+", x))
+  new_values <- lapply(old_values, function(x) signif(as.numeric(x), digits))
+
+  old_values <- unlist(old_values, use.names = FALSE)
+  new_values <- unlist(new_values, use.names = FALSE)
+
+  for (i in seq_along(old_values)) {
+    x <- sub(old_values[i], new_values[i], x)
+  }
+  x
+}
diff --git a/tests/testthat/test-list.R b/tests/testthat/test-list.R
diff --git a/tests/testthat/test-model-cubist.R b/tests/testthat/test-model-cubist.R
@@ -13,15 +13,14 @@ test_that("returns the right output", {
   expect_equal(length(pm), 2)
   expect_equal(length(pm$trees), 1)
   expect_equal(pm$general$model, "cubist")
-  expect_equal(pm$general$version, 2)
+  expect_equal(pm$general$version, 3)
 
   expect_snapshot(
     rlang::expr_text(tf)
   )
 })
 
 test_that("Model can be saved and re-loaded", {
-  skip("https://github.com/tidymodels/tidypredict/issues/148")
   model <- Cubist::cubist(
     x = mtcars[, -1],
     y = mtcars$mpg,
@@ -32,7 +31,11 @@ test_that("Model can be saved and re-loaded", {
   yaml::write_yaml(pm, mp)
   l <- yaml::read_yaml(mp)
   pm <- as_parsed_model(l)
-  expect_snapshot(tidypredict_fit(pm))
+
+  expect_identical(
+    tidypredict_fit(model),
+    tidypredict_fit(pm)
+  )
 })
 
 test_that("formulas produces correct predictions", {
diff --git a/tests/testthat/test-model-earth.R b/tests/testthat/test-model-earth.R
@@ -18,14 +18,18 @@ test_that("returns the right output", {
 
 test_that("Model can be saved and re-loaded", {
   model <- earth::earth(mpg ~ ., data = mtcars)
-  model$coefficients <- round(model$coefficients, 12)
+  model$coefficients <- round(model$coefficients, 7)
 
   pm <- parse_model(model)
   mp <- tempfile(fileext = ".yml")
   yaml::write_yaml(pm, mp)
   l <- yaml::read_yaml(mp)
   pm <- as_parsed_model(l)
-  expect_snapshot(tidypredict_fit(pm))
+
+  expect_identical(
+    tidypredict_fit(model),
+    tidypredict_fit(pm)
+  )
 })
 
 test_that("formulas produces correct predictions", {
diff --git a/tests/testthat/test-model-glm.R b/tests/testthat/test-model-glm.R
@@ -22,12 +22,18 @@ test_that("returns the right output", {
 test_that("Model can be saved and re-loaded", {
   model <- glm(am ~ wt + cyl, data = mtcars, family = "gaussian")
 
+  model$coefficients <- round(model$coefficients, 7)
+
   pm <- parse_model(model)
   mp <- tempfile(fileext = ".yml")
   yaml::write_yaml(pm, mp)
   l <- yaml::read_yaml(mp)
   pm <- as_parsed_model(l)
-  expect_snapshot(tidypredict_fit(pm))
+
+  expect_identical(
+    tidypredict_fit(model),
+    tidypredict_fit(pm)
+  )
 })
 
 test_that("formulas produces correct predictions", {
diff --git a/tests/testthat/test-model-lm.R b/tests/testthat/test-model-lm.R
diff --git a/tests/testthat/test-model-partykit.R b/tests/testthat/test-model-partykit.R
diff --git a/tests/testthat/test-model-ranger.R b/tests/testthat/test-model-ranger.R
diff --git a/tests/testthat/test-model-rf.R b/tests/testthat/test-model-rf.R
diff --git a/tests/testthat/test-model-xgboost.R b/tests/testthat/test-model-xgboost.R
