fixes for glmnet predictions

Author: topepo

NAMESPACE

@@ -9,13 +9,22 @@ S3method(multi_predict,"_lognet")
 S3method(multi_predict,"_multnet")
 S3method(multi_predict,"_xgb.Booster")
 S3method(multi_predict,default)
+S3method(predict,"_elnet")
+S3method(predict,"_lognet")
 S3method(predict,"_multnet")
 S3method(predict,model_fit)
+S3method(predict_class,"_lognet")
 S3method(predict_class,model_fit)
+S3method(predict_classprob,"_lognet")
+S3method(predict_classprob,"_multnet")
 S3method(predict_classprob,model_fit)
 S3method(predict_confint,model_fit)
+S3method(predict_num,"_elnet")
 S3method(predict_num,model_fit)
 S3method(predict_predint,model_fit)
+S3method(predict_raw,"_elnet")
+S3method(predict_raw,"_lognet")
+S3method(predict_raw,"_multnet")
 S3method(predict_raw,model_fit)
 S3method(print,boost_tree)
 S3method(print,linear_reg)
@@ -131,6 +140,7 @@ importFrom(purrr,map_dbl)
 importFrom(purrr,map_df)
 importFrom(purrr,map_dfr)
 importFrom(purrr,map_lgl)
+importFrom(rlang,eval_tidy)
 importFrom(rlang,sym)
 importFrom(rlang,syms)
 importFrom(stats,.checkMFClasses)

R/arguments.R

@@ -116,4 +116,20 @@ set_mode <- function(object, mode) {
   object
 }
 
+# ------------------------------------------------------------------------------
 
+#' @importFrom rlang eval_tidy
+#' @importFrom purrr map
+maybe_eval <- function(x) {
+  # if descriptors are in `x`, eval fails
+  y <- try(rlang::eval_tidy(x), silent = TRUE)
+  if (inherits(y, "try-error"))
+    y <- x
+  y
+}
+
+eval_args <- function(spec, ...) {
+  spec$args   <- purrr::map(spec$args,   maybe_eval)
+  spec$others <- purrr::map(spec$others, maybe_eval)
+  spec
+}

R/linear_reg.R

@@ -226,6 +226,27 @@ organize_glmnet_pred <- function(x, object) {
 }
 
 
+# ------------------------------------------------------------------------------
+
+#' @export
+predict._elnet <-
+  function(object, new_data, type = NULL, opts = list(), ...) {
+    object$spec <- eval_args(object$spec)
+    predict.model_fit(object, new_data = new_data, type = type, opts = opts, ...)
+  }
+
+#' @export
+predict_num._elnet <- function(object, new_data, ...) {
+  object$spec <- eval_args(object$spec)
+  predict_num.model_fit(object, new_data = new_data, ...)
+}
+
+#' @export
+predict_raw._elnet <- function(object, new_data, opts = list(), ...)  {
+  object$spec <- eval_args(object$spec)
+  predict_raw.model_fit(object, new_data = new_data, opts = opts, ...)
+}
+
 #' @importFrom dplyr full_join as_tibble arrange
 #' @importFrom tidyr gather
 #' @export
@@ -235,6 +256,8 @@ multi_predict._elnet <-
     if (is.null(penalty))
       penalty <- object$fit$lambda
     dots$s <- penalty
+
+    object$spec <- eval_args(object$spec)
     pred <- predict(object, new_data = new_data, type = "raw", opts = dots)
     param_key <- tibble(group = colnames(pred), penalty = penalty)
     pred <- as_tibble(pred)

R/linear_reg_data.R

@@ -86,6 +86,8 @@ linear_reg_lm_data <-
     )
   )
 
+# Note: For glmnet, you will need to make model-specific predict methods.
+# See linear_reg.R
 linear_reg_glmnet_data <-
   list(
     libs = "glmnet",

R/logistic_reg.R

@@ -247,6 +247,31 @@ organize_glmnet_prob <- function(x, object) {
 
 # ------------------------------------------------------------------------------
 
+#' @export
+predict._lognet <- function (object, new_data, type = NULL, opts = list(), ...) {
+  object$spec <- eval_args(object$spec)
+  predict.model_fit(object, new_data = new_data, type = type, opts = opts, ...)
+}
+
+#' @export
+predict_class._lognet <- function (object, new_data, ...) {
+  object$spec <- eval_args(object$spec)
+  predict_class.model_fit(object, new_data = new_data, ...)
+}
+
+#' @export
+predict_classprob._lognet <- function (object, new_data, ...) {
+  object$spec <- eval_args(object$spec)
+  predict_classprob.model_fit(object, new_data = new_data, ...)
+}
+
+#' @export
+predict_raw._lognet <- function (object, new_data, opts = list(), ...) {
+  object$spec <- eval_args(object$spec)
+  predict_raw.model_fit(object, new_data = new_data, opts = opts, ...)
+}
+
+
 #' @importFrom dplyr full_join as_tibble arrange
 #' @importFrom tidyr gather
 #' @export
@@ -255,6 +280,7 @@ multi_predict._lognet <-
     dots <- list(...)
     if (is.null(penalty))
       penalty <- object$lambda
+    dots$s <- penalty
 
     if (is.null(type))
       type <- "class"
@@ -266,7 +292,7 @@ multi_predict._lognet <-
     else
       dots$type <- type
 
-    dots$s <- penalty
+    object$spec <- eval_args(object$spec)
     pred <- predict(object, new_data = new_data, type = "raw", opts = dots)
     param_key <- tibble(group = colnames(pred), penalty = penalty)
     pred <- as_tibble(pred)

R/logistic_reg_data.R

@@ -95,6 +95,8 @@ logistic_reg_glm_data <-
     )
   )
 
+# Note: For glmnet, you will need to make model-specific predict methods.
+# See logistic_reg.R
 logistic_reg_glmnet_data <-
   list(
     libs = "glmnet",

R/multinom_reg.R

@@ -200,6 +200,31 @@ organize_multnet_prob <- function(x, object) {
 
 # ------------------------------------------------------------------------------
 
+#' @export
+predict._lognet <- function (object, new_data, type = NULL, opts = list(), ...) {
+  object$spec <- eval_args(object$spec)
+  predict.model_fit(object, new_data = new_data, type = type, opts = opts, ...)
+}
+
+#' @export
+predict_class._lognet <- function (object, new_data, ...) {
+  object$spec <- eval_args(object$spec)
+  predict_class.model_fit(object, new_data = new_data, ...)
+}
+
+#' @export
+predict_classprob._multnet <- function (object, new_data, ...) {
+  object$spec <- eval_args(object$spec)
+  predict_classprob.model_fit(object, new_data = new_data, ...)
+}
+
+#' @export
+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, ...)
+}
+
+
 #' @export
 predict._multnet <-
   function(object, new_data, type = NULL, opts = list(), penalty = NULL, ...) {
@@ -211,6 +236,7 @@ predict._multnet <-
     stop("`penalty` should be a single numeric value. ",
          "`multi_predict` can be used to get multiple predictions ",
          "per row of data.", call. = FALSE)
+    object$spec <- eval_args(object$spec)
     res <- predict.model_fit(
       object = object,
       new_data = new_data,
@@ -227,9 +253,13 @@ predict._multnet <-
 #' @export
 multi_predict._multnet <-
   function(object, new_data, type = NULL, penalty = NULL, ...) {
+    if (is_quosure(penalty))
+      penalty <- eval_tidy(penalty)
+
     dots <- list(...)
     if (is.null(penalty))
-      penalty <- object$lambda
+      penalty <- eval_tidy(object$lambda)
+    dots$s <- penalty
 
     if (is.null(type))
       type <- "class"
@@ -241,7 +271,7 @@ multi_predict._multnet <-
     else
       dots$type <- type
 
-    dots$s <- penalty
+    object$spec <- eval_args(object$spec)
     pred <- predict.model_fit(object, new_data = new_data, type = "raw", opts = dots)
 
     format_probs <- function(x) {

tests/testthat/test_linear_reg_glmnet.R

@@ -71,8 +71,7 @@ test_that('glmnet prediction, single lambda', {
             s = iris_basic$spec$args$penalty)
   uni_pred <- unname(uni_pred[,1])
 
-  # TODO neet a fix here
-  # expect_equal(uni_pred, predict_num(res_xy, iris[1:5, num_pred]))
+  expect_equal(uni_pred, predict_num(res_xy, iris[1:5, num_pred]))
 
   res_form <- fit(
     iris_basic,
@@ -90,8 +89,8 @@ test_that('glmnet prediction, single lambda', {
             newx = form_pred,
             s = res_form$spec$spec$args$penalty)
   form_pred <- unname(form_pred[,1])
-  # TODO neet a fix here
-  # expect_equal(form_pred, predict_num(res_form, iris[1:5, c("Sepal.Width", "Species")]))
+
+  expect_equal(form_pred, predict_num(res_form, iris[1:5, c("Sepal.Width", "Species")]))
 })
 
 
@@ -119,8 +118,7 @@ test_that('glmnet prediction, multiple lambda', {
   mult_pred$lambda <- rep(lams, each = 5)
   mult_pred <- mult_pred[,-2]
 
-  # TODO neet a fix here
-  # expect_equal(mult_pred, predict_num(res_xy, iris[1:5, num_pred]))
+  expect_equal(mult_pred, predict_num(res_xy, iris[1:5, num_pred]))
 
   res_form <- fit(
     iris_mult,
@@ -141,8 +139,7 @@ test_that('glmnet prediction, multiple lambda', {
   form_pred$lambda <- rep(lams, each = 5)
   form_pred <- form_pred[,-2]
 
-  # TODO neet a fix here
-  # expect_equal(form_pred, predict_num(res_form, iris[1:5, c("Sepal.Width", "Species")]))
+  expect_equal(form_pred, predict_num(res_form, iris[1:5, c("Sepal.Width", "Species")]))
 })
 
 test_that('glmnet prediction, all lambda', {
@@ -164,8 +161,7 @@ test_that('glmnet prediction, all lambda', {
   all_pred$lambda <- rep(res_xy$fit$lambda, each = 5)
   all_pred <- all_pred[,-2]
 
-  # TODO neet a fix here
-  # expect_equal(all_pred, predict_num(res_xy, iris[1:5, num_pred]))
+  expect_equal(all_pred, predict_num(res_xy, iris[1:5, num_pred]))
 
   # test that the lambda seq is in the right order (since no docs on this)
   tmp_pred <- predict(res_xy$fit, newx = as.matrix(iris[1:5, num_pred]),
@@ -189,8 +185,7 @@ test_that('glmnet prediction, all lambda', {
   form_pred$lambda <- rep(res_form$fit$lambda, each = 5)
   form_pred <- form_pred[,-2]
 
-  # TODO neet a fix here
-  # expect_equal(form_pred, predict_num(res_form, iris[1:5, c("Sepal.Width", "Species")]))
+  expect_equal(form_pred, predict_num(res_form, iris[1:5, c("Sepal.Width", "Species")]))
 })
 
 

tests/testthat/test_logistic_reg_glmnet.R

@@ -67,8 +67,7 @@ test_that('glmnet prediction, one lambda', {
   uni_pred <- factor(uni_pred, levels = levels(lending_club$Class))
   uni_pred <- unname(uni_pred)
 
-  # not currently working; will fix
-  # expect_equal(uni_pred, predict_class(xy_fit, lending_club[1:7, num_pred]))
+  expect_equal(uni_pred, predict_class(xy_fit, lending_club[1:7, num_pred]))
 
   res_form <- fit(
     logistic_reg(penalty = 0.1),
@@ -88,8 +87,8 @@ test_that('glmnet prediction, one lambda', {
   form_pred <- ifelse(form_pred >= 0.5, "good", "bad")
   form_pred <- factor(form_pred, levels = levels(lending_club$Class))
   form_pred <- unname(form_pred)
-  # not currently working; will fix
-  # expect_equal(form_pred, predict_class(res_form, lending_club[1:7, c("funded_amnt", "int_rate")]))
+
+  expect_equal(form_pred, predict_class(res_form, lending_club[1:7, c("funded_amnt", "int_rate")]))
 
 })
 
@@ -118,8 +117,7 @@ test_that('glmnet prediction, mulitiple lambda', {
   mult_pred$lambda <- rep(lams, each = 7)
   mult_pred <- mult_pred[, -2]
 
-  # not currently working; will fix
-  # expect_equal(mult_pred, predict_class(xy_fit, lending_club[1:7, num_pred]))
+  expect_equal(mult_pred, predict_class(xy_fit, lending_club[1:7, num_pred]))
 
   res_form <- fit(
     logistic_reg(penalty = lams),
@@ -142,14 +140,12 @@ test_that('glmnet prediction, mulitiple lambda', {
   form_pred$lambda <- rep(lams, each = 7)
   form_pred <- form_pred[, -2]
 
-  # not currently working; will fix
-  # expect_equal(form_pred, predict_class(res_form, lending_club[1:7, c("funded_amnt", "int_rate")]))
+  expect_equal(form_pred, predict_class(res_form, lending_club[1:7, c("funded_amnt", "int_rate")]))
 
 })
 
 test_that('glmnet prediction, no lambda', {
 
-  skip("not currently working; will fix")
   skip_if_not_installed("glmnet")
 
   xy_fit <- fit_xy(
@@ -163,7 +159,7 @@ test_that('glmnet prediction, no lambda', {
   mult_pred <-
     predict(xy_fit$fit,
             newx = as.matrix(lending_club[1:7, num_pred]),
-            s = xy_fit$spec$args$penalty, type = "response")
+            s = xy_fit$fit$lambda, type = "response")
   mult_pred <- stack(as.data.frame(mult_pred))
   mult_pred$values <- ifelse(mult_pred$values >= 0.5, "good", "bad")
   mult_pred$values <- factor(mult_pred$values, levels = levels(lending_club$Class))
@@ -199,7 +195,6 @@ test_that('glmnet prediction, no lambda', {
 
 test_that('glmnet probabilities, one lambda', {
 
-  skip("not currently working; will fix")
   skip_if_not_installed("glmnet")
 
   xy_fit <- fit_xy(
@@ -243,7 +238,6 @@ test_that('glmnet probabilities, one lambda', {
 
 test_that('glmnet probabilities, mulitiple lambda', {
 
-  skip("not currently working; will fix")
   skip_if_not_installed("glmnet")
 
   lams <- c(0.01, 0.1)
@@ -292,7 +286,6 @@ test_that('glmnet probabilities, mulitiple lambda', {
 
 test_that('glmnet probabilities, no lambda', {
 
-  skip("not currently working; will fix")
   skip_if_not_installed("glmnet")
 
   xy_fit <- fit_xy(

tests/testthat/test_multinom_reg_glmnet.R

@@ -118,11 +118,10 @@ test_that('glmnet probabilities, mulitiple lambda', {
   names(mult_pred) <- NULL
   mult_pred <- tibble(.pred = mult_pred)
 
-  # needs fixin
-  # expect_equal(
-  #   mult_pred$.pred,
-  #   multi_predict(xy_fit, iris[rows, 1:4], penalty = xy_fit$spec$args$penalty, type = "prob")$.pred
-  # )
+  expect_equal(
+    mult_pred$.pred,
+    multi_predict(xy_fit, iris[rows, 1:4], penalty = lams, type = "prob")$.pred
+  )
 
   mult_class <- names(mult_probs)[apply(mult_probs, 1, which.max)]
   mult_class <- tibble(
@@ -135,11 +134,10 @@ test_that('glmnet probabilities, mulitiple lambda', {
   names(mult_class) <- NULL
   mult_class <- tibble(.pred = mult_class)
 
-  # needs fixin
-  # expect_equal(
-  #   mult_class$.pred,
-  #   multi_predict(xy_fit, iris[rows, 1:4], penalty = xy_fit$spec$args$penalty)$.pred
-  # )
+  expect_equal(
+    mult_class$.pred,
+    multi_predict(xy_fit, iris[rows, 1:4], penalty = lams)$.pred
+  )
 })