Merge pull request #509 from tidymodels/export-glmnet-helpers

Export glmnet helpers

Author: topepo

NAMESPACE

@@ -108,6 +108,8 @@ S3method(varying_args,model_spec)
 S3method(varying_args,recipe)
 S3method(varying_args,step)
 export("%>%")
+export(.check_glmnet_penalty_fit)
+export(.check_glmnet_penalty_predict)
 export(.cols)
 export(.convert_form_to_xy_fit)
 export(.convert_form_to_xy_new)
@@ -117,6 +119,7 @@ export(.dat)
 export(.facts)
 export(.lvls)
 export(.obs)
+export(.organize_glmnet_pred)
 export(.preds)
 export(.x)
 export(.y)

R/linear_reg.R

@@ -107,7 +107,7 @@ translate.linear_reg <- function(x, engine = x$engine, ...) {
   x <- translate.default(x, engine, ...)
 
   if (engine == "glmnet") {
-    check_glmnet_penalty(x)
+    .check_glmnet_penalty_fit(x)
     if (any(names(x$eng_args) == "path_values")) {
       # Since we decouple the parsnip `penalty` argument from being the same
       # as the glmnet `lambda` value, `path_values` allows users to set the
@@ -192,7 +192,18 @@ check_args.linear_reg <- function(object) {
 
 # ------------------------------------------------------------------------------
 
-organize_glmnet_pred <- function(x, object) {
+#' Organize glmnet predictions
+#'
+#' This function is for developer use and organizes predictions from glmnet
+#' models.
+#'
+#' @param x Predictions as returned by the `predict()` method for glmnet models.
+#' @param object An object of class `model_fit`.
+#'
+#' @rdname glmnet_helpers_prediction
+#' @keywords internal
+#' @export
+.organize_glmnet_pred <- function(x, object) {
   if (ncol(x) == 1) {
     res <- x[, 1]
     res <- unname(res)
@@ -207,41 +218,6 @@ organize_glmnet_pred <- function(x, object) {
   res
 }
 
-
-# ------------------------------------------------------------------------------
-
-# For `predict` methods that use `glmnet`, we have specific methods.
-# Only one value of the penalty should be allowed when called by `predict()`:
-
-check_penalty <- function(penalty = NULL, object, multi = FALSE) {
-
-  if (is.null(penalty)) {
-    penalty <- object$fit$lambda
-  }
-
-  # when using `predict()`, allow for a single lambda
-  if (!multi) {
-    if (length(penalty) != 1)
-      rlang::abort(
-        glue::glue(
-          "`penalty` should be a single numeric value. `multi_predict()` ",
-          "can be used to get multiple predictions per row of data.",
-        )
-      )
-  }
-
-  if (length(object$fit$lambda) == 1 && penalty != object$fit$lambda)
-    rlang::abort(
-      glue::glue(
-        "The glmnet model was fit with a single penalty value of ",
-        "{object$fit$lambda}. Predicting with a value of {penalty} ",
-        "will give incorrect results from `glmnet()`."
-      )
-    )
-
-  penalty
-}
-
 # ------------------------------------------------------------------------------
 # glmnet call stack for linear regression using `predict` when object has
 # classes "_elnet" and "model_fit":
@@ -279,7 +255,7 @@ predict._elnet <-
       penalty <- object$spec$args$penalty
     }
 
-    object$spec$args$penalty <- check_penalty(penalty, object, multi)
+    object$spec$args$penalty <- .check_glmnet_penalty_predict(penalty, object, multi)
 
     object$spec <- eval_args(object$spec)
     predict.model_fit(object, new_data = new_data, type = type, opts = opts, ...)

R/linear_reg_data.R

@@ -163,7 +163,7 @@ set_pred(
   type = "numeric",
   value = list(
     pre = NULL,
-    post = organize_glmnet_pred,
+    post = .organize_glmnet_pred,
     func = c(fun = "predict"),
     args =
       list(

R/logistic_reg.R

@@ -109,7 +109,7 @@ translate.logistic_reg <- function(x, engine = x$engine, ...) {
   arg_names <- names(arg_vals)
 
   if (engine == "glmnet") {
-    check_glmnet_penalty(x)
+    .check_glmnet_penalty_fit(x)
     if (any(names(x$eng_args) == "path_values")) {
       # Since we decouple the parsnip `penalty` argument from being the same
       # as the glmnet `lambda` value, `path_values` allows users to set the
@@ -296,7 +296,7 @@ predict._lognet <- function(object, new_data, type = NULL, opts = list(), penalt
     penalty <- object$spec$args$penalty
   }
 
-  object$spec$args$penalty <- check_penalty(penalty, object, multi)
+  object$spec$args$penalty <- .check_glmnet_penalty_predict(penalty, object, multi)
 
   object$spec <- eval_args(object$spec)
   predict.model_fit(object, new_data = new_data, type = type, opts = opts, ...)

R/misc.R

@@ -323,7 +323,26 @@ stan_conf_int <- function(object, newdata) {
   rlang::eval_tidy(fn)
 }
 
-check_glmnet_penalty <- function(x) {
+# ------------------------------------------------------------------------------
+
+
+#' Helper functions for checking the penalty of glmnet models
+#'
+#' @description
+#' These functions are for developer use.
+#'
+#' `.check_glmnet_penalty_fit()` checks that the model specification for fitting a
+#' glmnet model contains a single value.
+#'
+#' `.check_glmnet_penalty_predict()` checks that the penalty value used for prediction is valid.
+#' If called by `predict()`, it needs to be a single value. Multiple values are
+#' allowed for `multi_predict()`.
+#'
+#' @param x An object of class `model_spec`.
+#' @rdname glmnet_helpers
+#' @keywords internal
+#' @export
+.check_glmnet_penalty_fit <- function(x) {
   pen <- rlang::eval_tidy(x$args$penalty)
 
   if (length(pen) != 1) {
@@ -335,3 +354,39 @@ check_glmnet_penalty <- function(x) {
     ))
   }
 }
+
+#' @param penalty A penalty value to check.
+#' @param object An object of class `model_fit`.
+#' @param multi A logical indicating if multiple values are allowed.
+#'
+#' @rdname glmnet_helpers
+#' @keywords internal
+#' @export
+.check_glmnet_penalty_predict <- function(penalty = NULL, object, multi = FALSE) {
+
+  if (is.null(penalty)) {
+    penalty <- object$fit$lambda
+  }
+
+  # when using `predict()`, allow for a single lambda
+  if (!multi) {
+    if (length(penalty) != 1)
+      rlang::abort(
+        glue::glue(
+          "`penalty` should be a single numeric value. `multi_predict()` ",
+          "can be used to get multiple predictions per row of data.",
+        )
+      )
+  }
+
+  if (length(object$fit$lambda) == 1 && penalty != object$fit$lambda)
+    rlang::abort(
+      glue::glue(
+        "The glmnet model was fit with a single penalty value of ",
+        "{object$fit$lambda}. Predicting with a value of {penalty} ",
+        "will give incorrect results from `glmnet()`."
+      )
+    )
+
+  penalty
+}

R/multinom_reg.R

@@ -222,7 +222,7 @@ predict._multnet <-
       penalty <- object$spec$args$penalty
     }
 
-    object$spec$args$penalty <- check_penalty(penalty, object, multi)
+    object$spec$args$penalty <- .check_glmnet_penalty_predict(penalty, object, multi)
 
     object$spec <- eval_args(object$spec)
     res <- predict.model_fit(
@@ -317,20 +317,3 @@ predict_raw._multnet <- function(object, new_data, opts = list(), ...) {
   object$spec <- eval_args(object$spec)
   predict_raw.model_fit(object, new_data = new_data, opts = opts, ...)
 }
-
-
-
-# ------------------------------------------------------------------------------
-
-# This checks as a pre-processor in the model data object
-check_glmnet_lambda <- function(dat, object) {
-  if (length(object$fit$lambda) > 1)
-    rlang::abort(
-      glue::glue(
-      "`predict()` doesn't work with multiple penalties (i.e. lambdas). ",
-      "Please specify a single value using `penalty = some_value` or use ",
-      "`multi_predict()` to get multiple predictions per row of data."
-      )
-    )
-  dat
-}