Support glmnet models with base-R families (#890)

* add methods for `glmnetfit` objects

there objects result from using base-R families

* use `type = "response"` for all log reg prediction

because `type = "class"` is not available in glmnet for `glmnetfit` objects

* add NEWS bullet

* bump version for tests in extratests

Author: hfrick

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: parsnip
 Title: A Common API to Modeling and Analysis Functions
-Version: 1.0.4.9001
+Version: 1.0.4.9002
 Authors@R: c(
     person("Max", "Kuhn", , "[email protected]", role = c("aut", "cre")),
     person("Davis", "Vaughan", , "[email protected]", role = "aut"),
@@ -34,7 +34,7 @@ Imports:
     rlang (>= 0.3.1),
     stats,
     tibble (>= 2.1.1),
-    tidyr (>= 1.0.0),
+    tidyr (>= 1.3.0),
     utils,
     vctrs (>= 0.4.1),
     withr

NAMESPACE

@@ -16,6 +16,7 @@ S3method(has_multi_predict,workflow)
 S3method(multi_predict,"_C5.0")
 S3method(multi_predict,"_earth")
 S3method(multi_predict,"_elnet")
+S3method(multi_predict,"_glmnetfit")
 S3method(multi_predict,"_lognet")
 S3method(multi_predict,"_multnet")
 S3method(multi_predict,"_torch_mlp")
@@ -27,25 +28,30 @@ S3method(multi_predict_args,model_fit)
 S3method(multi_predict_args,workflow)
 S3method(nullmodel,default)
 S3method(predict,"_elnet")
+S3method(predict,"_glmnetfit")
 S3method(predict,"_lognet")
 S3method(predict,"_multnet")
 S3method(predict,censoring_model_reverse_km)
 S3method(predict,model_fit)
 S3method(predict,model_spec)
 S3method(predict,nullmodel)
+S3method(predict_class,"_glmnetfit")
 S3method(predict_class,"_lognet")
 S3method(predict_class,"_multnet")
 S3method(predict_class,model_fit)
+S3method(predict_classprob,"_glmnetfit")
 S3method(predict_classprob,"_lognet")
 S3method(predict_classprob,"_multnet")
 S3method(predict_classprob,model_fit)
 S3method(predict_confint,model_fit)
 S3method(predict_hazard,model_fit)
 S3method(predict_linear_pred,model_fit)
 S3method(predict_numeric,"_elnet")
+S3method(predict_numeric,"_glmnetfit")
 S3method(predict_numeric,model_fit)
 S3method(predict_quantile,model_fit)
 S3method(predict_raw,"_elnet")
+S3method(predict_raw,"_glmnetfit")
 S3method(predict_raw,"_lognet")
 S3method(predict_raw,"_multnet")
 S3method(predict_raw,model_fit)

NEWS.md

@@ -1,5 +1,6 @@
 # parsnip (development version)
 
+* glmnet models fitted with base-R family objects are now supported for `linear_reg()`, `logistic_reg()`, and `multinomial_reg()` (#890).
 
 * Made `fit()` behave consistently with respect to missingness in the classification setting. Previously, `fit()` erroneously raised an error about the class of the outcome when there were no complete cases, and now always passes along complete cases to be handled by the modeling function (#888).
 

R/glmnet.R

@@ -97,14 +97,17 @@ multi_predict_glmnet <- function(object,
     }
   }
 
+  model_type <- class(object$spec)[1]
+
   if (object$spec$mode == "classification") {
     if (is.null(type)) {
       type <- "class"
     }
     if (!(type %in% c("class", "prob", "link", "raw"))) {
       rlang::abort("`type` should be either 'class', 'link', 'raw', or 'prob'.")
     }
-    if (type == "prob") {
+    if (type == "prob" |
+        model_type == "logistic_reg") {
       dots$type <- "response"
     } else {
       dots$type <- type
@@ -114,13 +117,13 @@ multi_predict_glmnet <- function(object,
   pred <- predict(object, new_data = new_data, type = "raw",
                   opts = dots, penalty = penalty, multi = TRUE)
 
-  model_type <- class(object$spec)[1]
+
   res <- switch(
     model_type,
     "linear_reg" = format_glmnet_multi_linear_reg(pred, penalty = penalty),
     "logistic_reg" = format_glmnet_multi_logistic_reg(pred,
                                                       penalty = penalty,
-                                                      type = dots$type,
+                                                      type = type,
                                                       lvl = object$lvl),
     "multinom_reg" = format_glmnet_multi_multinom_reg(pred,
                                                       penalty = penalty,
@@ -132,9 +135,25 @@ multi_predict_glmnet <- function(object,
   res
 }
 
+#' @export
+predict._glmnetfit <- predict_glmnet
 
-# -------------------------------------------------------------------------
+#' @export
+predict_numeric._glmnetfit <- predict_numeric_glmnet
 
+#' @export
+predict_class._glmnetfit <- predict_class_glmnet
+
+#' @export
+predict_classprob._glmnetfit <- predict_classprob_glmnet
+
+#' @export
+predict_raw._glmnetfit <- predict_raw_glmnet
+
+#' @export
+multi_predict._glmnetfit <- multi_predict_glmnet
+
+# -------------------------------------------------------------------------
 
 set_glmnet_penalty_path <- function(x) {
   if (any(names(x$eng_args) == "path_values")) {

R/logistic_reg.R

@@ -184,34 +184,41 @@ predict._lognet <- predict_glmnet
 multi_predict._lognet <- multi_predict_glmnet
 
 format_glmnet_multi_logistic_reg <- function(pred, penalty, type, lvl) {
-  param_key <- tibble(group = colnames(pred), penalty = penalty)
+
+  type <- rlang::arg_match(type, c("class", "prob"))
+
+  penalty_key <- tibble(s = colnames(pred), penalty = penalty)
+
   pred <- as_tibble(pred)
-  pred$.row <- 1:nrow(pred)
-  pred <- gather(pred, group, .pred_class, -.row)
+  pred$.row <- seq_len(nrow(pred))
+  pred <- tidyr::pivot_longer(pred, -.row, names_to = "s", values_to = ".pred")
+
   if (type == "class") {
-    pred[[".pred_class"]] <- factor(pred[[".pred_class"]], levels = lvl)
+    pred <- pred %>%
+      dplyr::mutate(.pred_class = dplyr::if_else(.pred >= 0.5, lvl[2], lvl[1]),
+                    .pred_class = factor(.pred_class, levels = lvl),
+                    .keep = "unused")
   } else {
-    if (type == "response") {
-      pred[[".pred2"]] <- 1 - pred[[".pred_class"]]
-      names(pred) <- c(".row", "group", paste0(".pred_", rev(lvl)))
-      pred <- pred[, c(".row", "group", paste0(".pred_", lvl))]
-    }
+    pred <- pred %>%
+      dplyr::mutate(.pred_class_2 = 1 - .pred) %>%
+      rlang::set_names(c(".row", "s", paste0(".pred_", rev(lvl)))) %>%
+      dplyr::select(c(".row", "s", paste0(".pred_", lvl)))
   }
+
   if (utils::packageVersion("dplyr") >= "1.0.99.9000") {
-    pred <- full_join(param_key, pred, by = "group", multiple = "all")
+    pred <- dplyr::full_join(penalty_key, pred, by = "s", multiple = "all")
   } else {
-    pred <- full_join(param_key, pred, by = "group")
+    pred <- dplyr::full_join(penalty_key, pred, by = "s")
   }
-  pred$group <- NULL
-  pred <- arrange(pred, .row, penalty)
-  .row <- pred$.row
-  pred$.row <- NULL
-  pred <- split(pred, .row)
-  names(pred) <- NULL
-  tibble(.pred = pred)
-}
 
+  pred <- pred %>%
+    dplyr::select(-s) %>%
+    dplyr::arrange(penalty) %>%
+    tidyr::nest(.by = .row, .key = ".pred") %>%
+    dplyr::select(-.row)
 
+  pred
+}
 
 #' @export
 predict_class._lognet <- predict_class_glmnet

R/parsnip-package.R

@@ -42,7 +42,8 @@ utils::globalVariables(
     "sub_neighbors", ".pred_class", "x", "y", "predictor_indicators",
     "compute_intercept", "remove_intercept", "estimate", "term",
     "call_info", "component", "component_id", "func", "tunable", "label",
-    "pkg", ".order", "item", "tunable", "has_ext", "id", "weights", "has_wts", "protect"
+    "pkg", ".order", "item", "tunable", "has_ext", "id", "weights", "has_wts",
+    "protect", "s"
   )
 )