trans_models_t: smaller model objs, tables

Author: mmyrte

R/evoland_db_tables.R

@@ -182,7 +182,7 @@ evoland_db$set("active", "trans_models_t", function(x) {
     self,
     "trans_models_t",
     as_trans_models_t,
-    key_cols = c("id_trans"),
+    key_cols = c("id_trans", "fit_call"),
     map_cols = c("model_params", "goodness_of_fit")
   )(x)
 })

R/trans_models_glm.R

@@ -30,10 +30,21 @@ fit_glm <- function(data, result_col = "result", ...) {
   formula_str <- paste(result_col, "~", paste(pred_cols, collapse = " + "))
   formula <- as.formula(formula_str)
 
-  # Fit GLM with quasibinomial family (handles overdispersion better)
   model <- glm(formula, data = data, family = quasibinomial())
 
-  # Butcher the model if package is available (reduces memory footprint)
+  # clean up the object
+  model[["model"]] <- NULL
+  model[["residuals"]] <- NULL
+  model[["fitted.values"]] <- NULL
+  model[["effects"]] <- NULL
+  model[["qr"]][["qr"]] <- NULL
+  model[["linear.predictors"]] <- NULL
+  model[["weights"]] <- NULL
+  model[["prior.weights"]] <- NULL
+  model[["y"]] <- NULL
+  attr(model[["formula"]], ".Environment") <- NULL
+
+  # just to be sure
   if (requireNamespace("butcher", quietly = TRUE)) {
     model <- butcher::butcher(model)
   }

R/trans_models_rf.R

@@ -27,7 +27,7 @@
 #' - min.node.size = 1
 #'
 #' @export
-fit_ranger <- function(data, result_col = "result", ...) {
+fit_ranger <- function(data, result_col = "result", num.trees = 500, ...) {
   if (!requireNamespace("ranger", quietly = TRUE)) {
     stop(
       "Package 'ranger' is required but is not installed.\n",
@@ -58,10 +58,7 @@ fit_ranger <- function(data, result_col = "result", ...) {
     x = x,
     y = y,
     num.trees = num.trees,
-    min.node.size = min.min.node.size,
     case.weights = weights,
-    # Stratified sampling by class
-    sample.fraction = c(nmin / class_counts[1], nmin / class_counts[2]),
     probability = TRUE, # For probability predictions
     importance = "impurity",
     ...

R/trans_models_t.R

@@ -13,7 +13,6 @@
 #'   - `model_family`: Model family (e.g., "rf", "glm", "bayesian")
 #'   - `model_params`: Map of model (hyper) parameters
 #'   - `goodness_of_fit`: Map of various measures of fit (e.g., ROC AUC, RMSE)
-#'   - `sampled_coords`: data.table with id_coord/id_period pairs used for training
 #'   - `fit_call`: Character string of the original fit function call for reproducibility
 #'   - `model_obj_part`: BLOB of serialized model object for validation
 #'   - `model_obj_full`: BLOB of serialized model object for extrapolation
@@ -25,7 +24,6 @@ as_trans_models_t <- function(x) {
       model_family = character(0),
       model_params = list(),
       goodness_of_fit = list(),
-      sampled_coords = list(),
       fit_call = character(0),
       model_obj_part = list(),
       model_obj_full = list()
@@ -144,9 +142,6 @@ evoland_db$set(
           train_data <- trans_pred_data_full[train_idx, ]
           test_data <- trans_pred_data_full[test_idx, ]
 
-          # Record sampled coordinates for reproducibility
-          sampled_coords <- train_data[, .(id_coord, id_period)]
-
           message(glue::glue(
             "  Training on {nrow(train_data)} observations ",
             "({n_train_true} TRUE, {n_train_false} FALSE)"
@@ -184,8 +179,7 @@ evoland_db$set(
           goodness_of_fit <- gof_fun(
             model = model,
             test_data = test_data,
-            result_col = "result",
-            ...
+            result_col = "result"
           )
 
           # Extract model family
@@ -201,7 +195,8 @@ evoland_db$set(
           model_params <- list(
             n_predictors = length(pred_cols),
             n_train = nrow(train_data),
-            sample_pct = sample_pct
+            sample_pct = sample_pct,
+            ...
           )
 
           # Serialize partial model
@@ -218,7 +213,6 @@ evoland_db$set(
             model_family = model_family,
             model_params = list(model_params),
             goodness_of_fit = list(goodness_of_fit),
-            sampled_coords = list(sampled_coords),
             fit_call = fit_call,
             model_obj_part = model_obj_part,
             model_obj_full = list(NULL)
@@ -356,7 +350,6 @@ evoland_db$set(
             model_family = best_models$model_family[i],
             model_params = list(best_models$model_params[[i]]),
             goodness_of_fit = list(best_models$goodness_of_fit[[i]]),
-            sampled_coords = list(best_models$sampled_coords[[i]]),
             fit_call = best_models$fit_call[i],
             model_obj_part = list(best_models$model_obj_part[[i]]),
             model_obj_full = model_obj_full
@@ -393,7 +386,6 @@ validate.trans_models_t <- function(x, ...) {
       "model_family",
       "model_params",
       "goodness_of_fit",
-      "sampled_coords",
       "fit_call",
       "model_obj_part",
       "model_obj_full"
@@ -410,7 +402,6 @@ validate.trans_models_t <- function(x, ...) {
     is.character(x[["model_family"]]),
     is.list(x[["model_params"]]),
     is.list(x[["goodness_of_fit"]]),
-    is.list(x[["sampled_coords"]]),
     is.character(x[["fit_call"]]),
     is.list(x[["model_obj_part"]]),
     is.list(x[["model_obj_full"]]),

inst/tinytest/test_trans_models_t.R

@@ -6,7 +6,7 @@ expect_stdout(print(trans_models_empty), "Transition Models Table")
 expect_equal(nrow(trans_models_empty), 0L)
 expect_true(inherits(trans_models_empty, "trans_models_t"))
 
-# Test creation with data (updated structure with sampled_coords and fit_call)
+# Test creation with data
 trans_models_t <- as_trans_models_t(data.table::data.table(
   id_trans = 1L,
   model_family = "rf",
@@ -16,9 +16,6 @@ trans_models_t <- as_trans_models_t(data.table::data.table(
   goodness_of_fit = list(
     list(auc = 0.8, rmse = 0.15)
   ),
-  sampled_coords = list(
-    data.table::data.table(id_coord = 1:10, id_period = rep(1L, 10))
-  ),
   fit_call = "fit_fun(data = data, result_col = \"result\")",
   model_obj_part = list(
     charToRaw("partial model data")
@@ -195,52 +192,35 @@ expect_message(
     gof_fun = gof_mock,
     sample_pct = 70,
     seed = 123,
-    na_value = 0
+    na_value = 0,
+    other_param = "nonce"
   ),
   "Fitting partial model"
 )
-
-# test DB round trip
-expect_silent(db_tm$trans_models_t <- partial_models)
-expect_equivalent(db_tm$trans_models_t, partial_models)
-
-expect_true(inherits(partial_models, "trans_models_t"))
-expect_true(nrow(partial_models) > 0L)
-expect_true(all(partial_models$id_trans > 0))
-
-# Check that partial models are present
-expect_true(all(!vapply(partial_models$model_obj_part, is.null, logical(1))))
-
-# Check that full models are NULL
-expect_true(all(vapply(partial_models$model_obj_full, is.null, logical(1))))
-
-# Check that sampled_coords is present
-expect_true(all(!vapply(partial_models$sampled_coords, is.null, logical(1))))
-first_sampled <- partial_models$sampled_coords[[1]]
-expect_true(inherits(first_sampled, "data.table"))
-expect_true("id_coord" %in% names(first_sampled))
-expect_true("id_period" %in% names(first_sampled))
-
-# Check that fit_call is present and is character string
-expect_true(all(nchar(partial_models$fit_call) > 0))
-expect_true(is.character(partial_models$fit_call))
-
-# Check that fit_call contains the function name
-first_call <- partial_models$fit_call[1]
-expect_true(grepl("fit_mock_glm", first_call))
-expect_true(grepl("data.*result_col", first_call))
-
-# Check that goodness_of_fit is populated
-first_gof <- partial_models$goodness_of_fit[[1]]
-expect_true(length(first_gof) > 0)
-expect_true("cor" %in% names(first_gof) || "mse" %in% names(first_gof))
+expect_equal(
+  partial_models$fit_call[1],
+  r"{fit_mock_glm(data = data, result_col = "result", other_param = "nonce")}"
+)
+expect_equal(
+  partial_models$model_params[[1]],
+  list(n_predictors = 3, n_train = 17, sample_pct = 70, other_param = "nonce")
+)
+expect_true(all(
+  !vapply(partial_models$model_obj_part, is.null, logical(1))
+))
+expect_equal(
+  partial_models$goodness_of_fit[[1]],
+  list(cor = 0.6917245, mse = 0.1610296, n_test = 5),
+  tolerance = 1e07
+)
 
 # Test that model deserialization works
 first_model_part <- qs2::qs_deserialize(partial_models$model_obj_part[[1]])
 expect_true(inherits(first_model_part, "glm"))
 
-# Note: Reproducibility with seed can be affected by RNG state from previous operations
-# Skipping reproducibility test for now
+# test DB round trip
+expect_silent(db_tm$trans_models_t <- partial_models)
+expect_equivalent(db_tm$trans_models_t, partial_models)
 
 # Test fit_full_models
 expect_message(
@@ -257,7 +237,6 @@ expect_message(
 expect_silent(db_tm$trans_models_t <- full_models)
 expect_identical(db_tm$trans_models_t, full_models)
 
-
 expect_true(inherits(full_models, "trans_models_t"))
 expect_true(nrow(full_models) > 0L)
 
@@ -430,7 +409,6 @@ expect_equal(
     "model_family",
     "model_params",
     "goodness_of_fit",
-    "sampled_coords",
     "fit_call",
     "model_obj_part",
     "model_obj_full"