Merge branch 'master' into try-catch-augment

Author: topepo

NEWS.md

@@ -1,21 +1,33 @@
 # parsnip (development version)
 
-* `generics::required_pkgs()` was extended for `parsnip` objects. 
-
-* The `liquidSVM` engine for `svm_rbf()` was deprecated due to that package's removal from CRAN. (#425)
+## Model Specification Changes
 
 * A new linear SVM model `svm_linear()` is now available with the `LiblineaR` engine (#424) and the `kernlab` engine (#438), and the `LiblineaR` engine is available for `logistic_reg()` as well (#429). These models can use sparse matrices via `fit_xy()` (#447) and have a `tidy` method (#474).
 
+* For models with `glmnet` engines: 
+
+  - A single value is required for `penalty` (either a single numeric value or a value of `tune()`) (#481).
+  - A special argument called `path_values` can be used to set the `lambda` path as a specific set of numbers (independent of the value of `penalty`). A pure ridge regression models (i.e., `mixture = 1`) will generate incorrect values if the path does not include zero. See issue #431 for discussion (#486).
+  
+* The `liquidSVM` engine for `svm_rbf()` was deprecated due to that package's removal from CRAN. (#425)
+
 * New model specification `survival_reg()` for the new mode `"censored regression"` (#444). `surv_reg()` is now soft-deprecated (#448).
 
 * New model specification `proportional_hazards()` for the `"censored regression"` mode (#451).
 
+## Other Changes
+
 * Re-licensed package from GPL-2 to MIT. See [consent from copyright holders here](https://github.com/tidymodels/parsnip/issues/462).
 
 * `set_mode()` now checks if `mode` is compatible with the model class, similar to `new_model_spec()` (@jtlandis, #467).
 
 * Re-organized model documentation for `update` methods (#479).
 
+ 
+  
+* `generics::required_pkgs()` was extended for `parsnip` objects. 
+
+
 
 # parsnip 0.1.5
 

R/aaa_models.R

@@ -127,21 +127,27 @@ check_model_doesnt_exist <- function(model) {
 }
 
 check_mode_val <- function(mode) {
-  if (rlang::is_missing(mode) || length(mode) != 1 || !is.character(mode))
+  if (rlang::is_missing(mode) || length(mode) != 1 || !is.character(mode)) {
     rlang::abort("Please supply a character string for a mode (e.g. `'regression'`).")
+  }
   invisible(NULL)
 }
 
 # check if class and mode are compatible
 check_spec_mode_val <- function(cls, mode) {
   spec_modes <- rlang::env_get(get_model_env(), paste0(cls, "_modes"))
-  if (!(mode %in% spec_modes))
-    rlang::abort(
-      glue::glue(
-        "`mode` should be one of: ",
-        glue::glue_collapse(glue::glue("'{spec_modes}'"), sep = ", ")
-      )
+  compatible_modes <-
+    glue::glue(
+      "`mode` should be one of: ",
+      glue::glue_collapse(glue::glue("'{spec_modes}'"), sep = ", ")
     )
+
+  if (is.null(mode)) {
+    rlang::abort(compatible_modes)
+  } else if (!(mode %in% spec_modes)) {
+    rlang::abort(compatible_modes)
+  }
+
   invisible(NULL)
 }
 
@@ -280,12 +286,27 @@ check_pred_info <- function(pred_obj, type) {
   invisible(NULL)
 }
 
+check_spec_pred_type <- function(object, type) {
+  possible_preds <- names(object$spec$method$pred)
+  if (!any(possible_preds == type)) {
+    rlang::abort(c(
+      glue::glue("No {type} prediction method available for this model."),
+      glue::glue("Value for `type` should be one of: ",
+                 glue::glue_collapse(glue::glue("'{possible_preds}'"), sep = ", "))
+    ))
+  }
+  invisible(NULL)
+}
+
+
 check_pkg_val <- function(pkg) {
-  if (rlang::is_missing(pkg) || length(pkg) != 1 || !is.character(pkg))
+  if (rlang::is_missing(pkg) || length(pkg) != 1 || !is.character(pkg)) {
     rlang::abort("Please supply a single character value for the package name.")
+  }
   invisible(NULL)
 }
 
+
 check_interface_val <- function(x) {
   exp_interf <- c("data.frame", "formula", "matrix")
   if (length(x) != 1 || !(x %in% exp_interf)) {

R/arguments.R

@@ -76,17 +76,10 @@ set_args <- function(object, ...) {
 #' @rdname set_args
 #' @export
 set_mode <- function(object, mode) {
-  if (is.null(mode))
-    return(object)
-  mode <- mode[1]
-  if (!(any(all_modes == mode))) {
-    rlang::abort(
-      glue::glue(
-        "`mode` should be one of ",
-        glue::glue_collapse(glue::glue("'{all_modes}'"), sep = ", ")
-      )
-    )
+  if (rlang::is_missing(mode)) {
+    mode <- NULL
   }
+  mode <- mode[1]
   check_spec_mode_val(class(object)[1], mode)
   object$mode <- mode
   object

R/engines.R

@@ -15,6 +15,10 @@ check_engine <- function(object) {
   if (is.null(object$engine)) {
     object$engine <- avail_eng[1]
     rlang::warn(glue::glue("`engine` was NULL and updated to be `{object$engine}`"))
+  } else {
+    if (!is.character(object$engine) | length(object$engine) != 1) {
+      rlang::abort("`engine` should be a single character value.")
+    }
   }
   if (!(object$engine %in% avail_eng)) {
     rlang::abort(
@@ -91,18 +95,20 @@ set_engine <- function(object, engine, ...) {
   if (!inherits(object, "model_spec")) {
     rlang::abort("`object` should have class 'model_spec'.")
   }
-  if (!is.character(engine) | length(engine) != 1)
-    rlang::abort("`engine` should be a single character value.")
-  if (engine == "liquidSVM") {
+
+  if (rlang::is_missing(engine)) {
+    engine <- NULL
+  }
+  object$engine <- engine
+  object <- check_engine(object)
+
+  if (object$engine == "liquidSVM") {
     lifecycle::deprecate_soft(
       "0.1.6",
       "set_engine(engine = 'cannot be liquidSVM')",
       details = "The liquidSVM package is no longer available on CRAN.")
   }
 
-  object$engine <- engine
-  object <- check_engine(object)
-
   new_model_spec(
     cls = class(object)[1],
     args = object$args,

R/linear_reg.R

@@ -107,14 +107,23 @@ translate.linear_reg <- function(x, engine = x$engine, ...) {
   x <- translate.default(x, engine, ...)
 
   if (engine == "glmnet") {
-    # See discussion in https://github.com/tidymodels/parsnip/issues/195
-    x$method$fit$args$lambda <- NULL
+    check_glmnet_penalty(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
+      # path differently from the default that glmnet uses. See
+      # https://github.com/tidymodels/parsnip/issues/431
+      x$method$fit$args$lambda <- x$eng_args$path_values
+      x$eng_args$path_values <- NULL
+      x$method$fit$args$path_values <- NULL
+    } else {
+      # See discussion in https://github.com/tidymodels/parsnip/issues/195
+      x$method$fit$args$lambda <- NULL
+    }
     # Since the `fit` information is gone for the penalty, we need to have an
     # evaluated value for the parameter.
     x$args$penalty <- rlang::eval_tidy(x$args$penalty)
-    check_glmnet_penalty(x)
   }
-
   x
 }
 

R/logistic_reg.R

@@ -108,14 +108,23 @@ translate.logistic_reg <- function(x, engine = x$engine, ...) {
   arg_vals <- x$method$fit$args
   arg_names <- names(arg_vals)
 
-
   if (engine == "glmnet") {
-    # See discussion in https://github.com/tidymodels/parsnip/issues/195
-    arg_vals$lambda <- NULL
+    check_glmnet_penalty(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
+      # path differently from the default that glmnet uses. See
+      # https://github.com/tidymodels/parsnip/issues/431
+      x$method$fit$args$lambda <- x$eng_args$path_values
+      x$eng_args$path_values <- NULL
+      x$method$fit$args$path_values <- NULL
+    } else {
+      # See discussion in https://github.com/tidymodels/parsnip/issues/195
+      x$method$fit$args$lambda <- NULL
+    }
     # Since the `fit` information is gone for the penalty, we need to have an
     # evaluated value for the parameter.
     x$args$penalty <- rlang::eval_tidy(x$args$penalty)
-    check_glmnet_penalty(x)
   }
 
   if (engine == "LiblineaR") {
@@ -134,11 +143,8 @@ translate.logistic_reg <- function(x, engine = x$engine, ...) {
           rlang::abort("For the LiblineaR engine, mixture must be 0 or 1.")
         }
     }
-
+    x$method$fit$args <- arg_vals
   }
-
-  x$method$fit$args <- arg_vals
-
   x
 }
 

R/misc.R

@@ -324,10 +324,12 @@ stan_conf_int <- function(object, newdata) {
 }
 
 check_glmnet_penalty <- function(x) {
-  if (length(x$args$penalty) != 1) {
+  pen <- rlang::eval_tidy(x$args$penalty)
+
+  if (length(pen) != 1) {
     rlang::abort(c(
       "For the glmnet engine, `penalty` must be a single number (or a value of `tune()`).",
-      glue::glue("There are {length(x$args$penalty)} values for `penalty`."),
+      glue::glue("There are {length(pen)} values for `penalty`."),
       "To try multiple values for total regularization, use the tune package.",
       "To predict multiple penalties, use `multi_predict()`"
     ))

R/predict_class.R

@@ -12,8 +12,7 @@ predict_class.model_fit <- function(object, new_data, ...) {
   if (object$spec$mode != "classification")
     rlang::abort("`predict.model_fit()` is for predicting factor outcomes.")
 
-  if (!any(names(object$spec$method$pred) == "class"))
-    rlang::abort("No class prediction module defined for this model.")
+  check_spec_pred_type(object, "class")
 
   if (inherits(object$fit, "try-error")) {
     rlang::warn("Model fit failed; cannot make predictions.")

R/predict_classprob.R

@@ -9,8 +9,8 @@ predict_classprob.model_fit <- function(object, new_data, ...) {
   if (object$spec$mode != "classification")
     rlang::abort("`predict.model_fit()` is for predicting factor outcomes.")
 
-  if (!any(names(object$spec$method$pred) == "prob"))
-    rlang::abort("No class probability module defined for this model.")
+  check_spec_pred_type(object, "prob")
+
 
   if (inherits(object$fit, "try-error")) {
     rlang::warn("Model fit failed; cannot make predictions.")

R/predict_hazard.R

@@ -7,8 +7,7 @@
 predict_hazard.model_fit <-
   function(object, new_data, .time, ...) {
 
-    if (is.null(object$spec$method$pred$hazard))
-      rlang::abort("No hazard prediction method defined for this engine.")
+    check_spec_pred_type(object, "hazard")
 
     if (inherits(object$fit, "try-error")) {
       rlang::warn("Model fit failed; cannot make predictions.")

R/predict_interval.R

@@ -10,8 +10,7 @@
 #' @export
 predict_confint.model_fit <- function(object, new_data, level = 0.95, std_error = FALSE, ...) {
 
-  if (is.null(object$spec$method$pred$conf_int))
-    rlang::abort("No confidence interval method defined for this engine.")
+  check_spec_pred_type(object, "conf_int")
 
   if (inherits(object$fit, "try-error")) {
     rlang::warn("Model fit failed; cannot make predictions.")
@@ -58,8 +57,7 @@ predict_confint <- function(object, ...)
 # @export
 predict_predint.model_fit <- function(object, new_data, level = 0.95, std_error = FALSE, ...) {
 
-  if (is.null(object$spec$method$pred$pred_int))
-    rlang::abort("No prediction interval method defined for this engine.")
+  check_spec_pred_type(object, "pred_int")
 
   if (inherits(object$fit, "try-error")) {
     rlang::warn("Model fit failed; cannot make predictions.")

R/predict_linear_pred.R

@@ -6,8 +6,7 @@
 #' @export
 predict_linear_pred.model_fit <- function(object, new_data, ...) {
 
-  if (!any(names(object$spec$method$pred) == "linear_pred"))
-    rlang::abort("No prediction module defined for this model.")
+  check_spec_pred_type(object, "linear_pred")
 
   if (inherits(object$fit, "try-error")) {
     rlang::warn("Model fit failed; cannot make predictions.")

R/predict_numeric.R

@@ -10,8 +10,7 @@ predict_numeric.model_fit <- function(object, new_data, ...) {
                             "Use `predict_class()` or `predict_classprob()` for ",
                             "classification models."))
 
-  if (!any(names(object$spec$method$pred) == "numeric"))
-    rlang::abort("No prediction module defined for this model.")
+  check_spec_pred_type(object, "numeric")
 
   if (inherits(object$fit, "try-error")) {
     rlang::warn("Model fit failed; cannot make predictions.")

R/predict_quantile.R

@@ -9,8 +9,7 @@
 predict_quantile.model_fit <-
   function(object, new_data, quantile = (1:9)/10, ...) {
 
-    if (is.null(object$spec$method$pred$quantile))
-      rlang::abort("No quantile prediction method defined for this engine.")
+    check_spec_pred_type(object, "quantile")
 
     if (inherits(object$fit, "try-error")) {
       rlang::warn("Model fit failed; cannot make predictions.")

R/predict_raw.R

@@ -13,8 +13,7 @@ predict_raw.model_fit <- function(object, new_data, opts = list(), ...) {
       c(object$spec$method$pred$raw$args, opts)
   }
 
-  if (!any(names(object$spec$method$pred) == "raw"))
-    rlang::abort("No raw prediction module defined for this model.")
+  check_spec_pred_type(object, "raw")
 
   if (inherits(object$fit, "try-error")) {
     rlang::warn("Model fit failed; cannot make predictions.")

R/predict_survival.R

@@ -7,8 +7,7 @@
 predict_survival.model_fit <-
   function(object, new_data, .time, ...) {
 
-    if (is.null(object$spec$method$pred$survival))
-      rlang::abort("No survival prediction method defined for this engine.")
+    check_spec_pred_type(object, "survival")
 
     if (inherits(object$fit, "try-error")) {
       rlang::warn("Model fit failed; cannot make predictions.")

R/predict_time.R

@@ -10,8 +10,7 @@ predict_time.model_fit <- function(object, new_data, ...) {
                             "Use `predict_class()` or `predict_classprob()` for ",
                             "classification models."))
 
-  if (!any(names(object$spec$method$pred) == "time"))
-    rlang::abort("No prediction module defined for this model.")
+  check_spec_pred_type(object, "time")
 
   if (inherits(object$fit, "try-error")) {
     rlang::warn("Model fit failed; cannot make predictions.")

R/svm_linear_data.R

@@ -123,27 +123,6 @@ set_pred(
       )
   )
 )
-set_pred(
-  model = "svm_linear",
-  eng = "LiblineaR",
-  mode = "classification",
-  type = "prob",
-  value = list(
-    pre = function(x, object) {
-      rlang::abort(
-        paste0("The LiblineaR engine does not support class probabilities ",
-               "for any `svm` models.")
-      )
-    },
-    post = NULL,
-    func = c(fun = "predict"),
-    args =
-      list(
-        object = quote(object$fit),
-        newx = expr(as.matrix(new_data))
-      )
-  )
-)
 set_pred(
   model = "svm_linear",
   eng = "LiblineaR",