Merge branch 'master' into knn-multi-predict

Author: topepo

NAMESPACE

@@ -2,6 +2,9 @@
 
 S3method(fit,model_spec)
 S3method(fit_xy,model_spec)
+S3method(has_multi_pred,default)
+S3method(has_multi_pred,model_fit)
+S3method(has_multi_pred,workflow)
 S3method(multi_predict,"_C5.0")
 S3method(multi_predict,"_earth")
 S3method(multi_predict,"_elnet")
@@ -92,6 +95,7 @@ export(get_fit)
 export(get_from_env)
 export(get_model_env)
 export(get_pred_type)
+export(has_multi_pred)
 export(keras_mlp)
 export(linear_reg)
 export(logistic_reg)
@@ -211,4 +215,5 @@ importFrom(utils,capture.output)
 importFrom(utils,getFromNamespace)
 importFrom(utils,globalVariables)
 importFrom(utils,head)
+importFrom(utils,methods)
 importFrom(vctrs,vec_unique)

R/boost_tree.R

@@ -137,7 +137,7 @@ print.boost_tree <- function(x, ...) {
   cat("Boosted Tree Model Specification (", x$mode, ")\n\n", sep = "")
   model_printer(x, ...)
 
-  if(!is.null(x$method$fit$args)) {
+  if (!is.null(x$method$fit$args)) {
     cat("Model fit template:\n")
     print(show_call(x))
   }
@@ -211,14 +211,15 @@ translate.boost_tree <- function(x, engine = x$engine, ...) {
   x <- translate.default(x, engine, ...)
 
   if (engine == "spark") {
-    if (x$mode == "unknown")
+    if (x$mode == "unknown") {
       stop(
         "For spark boosted trees models, the mode cannot be 'unknown' ",
         "if the specification is to be translated.",
         call. = FALSE
       )
-    else
+    } else {
       x$method$fit$args$type <- x$mode
+    }
   }
   x
 }
@@ -282,27 +283,33 @@ xgb_train <- function(
     }
   }
 
-  if (is.data.frame(x))
+  if (is.data.frame(x)) {
     x <- as.matrix(x) # maybe use model.matrix here?
+  }
 
   n <- nrow(x)
   p <- ncol(x)
 
-  if (!inherits(x, "xgb.DMatrix"))
+  if (!inherits(x, "xgb.DMatrix")) {
     x <- xgboost::xgb.DMatrix(x, label = y, missing = NA)
-  else
+  } else {
     xgboost::setinfo(x, "label", y)
+  }
 
   # translate `subsample` and `colsample_bytree` to be on (0, 1] if not
-  if(subsample > 1)
+  if (subsample > 1) {
     subsample <- subsample/n
-  if(subsample > 1)
+  }
+  if (subsample > 1) {
     subsample <- 1
+  }
 
-  if(colsample_bytree > 1)
+  if (colsample_bytree > 1) {
     colsample_bytree <- colsample_bytree/p
-  if(colsample_bytree > 1)
+  }
+  if (colsample_bytree > 1) {
     colsample_bytree <- 1
+  }
 
   arg_list <- list(
     eta = eta,
@@ -321,18 +328,19 @@ xgb_train <- function(
     nrounds = nrounds,
     objective = loss
   )
-  if (!is.null(num_class))
+  if (!is.null(num_class)) {
     main_args$num_class <- num_class
+  }
 
   call <- make_call(fun = "xgb.train", ns = "xgboost", main_args)
 
   # override or add some other args
   others <- list(...)
   others <-
     others[!(names(others) %in% c("data", "weights", "nrounds", "num_class", names(arg_list)))]
-  if (length(others) > 0)
-    for (i in names(others))
-      call[[i]] <- others[[i]]
+  if (length(others) > 0) {
+    call <- rlang::call_modify(call, !!!others)
+  }
 
   eval_tidy(call, env = current_env())
 }
@@ -348,7 +356,7 @@ xgb_pred <- function(object, newdata, ...) {
 
   x = switch(
     object$params$objective,
-    "reg:linear" =, "reg:logistic" =, "binary:logistic" = res,
+    "reg:linear" = , "reg:logistic" = , "binary:logistic" = res,
     "binary:logitraw" = stats::binomial()$linkinv(res),
     "multi:softprob" = matrix(res, ncol = object$params$num_class, byrow = TRUE),
     res
@@ -362,11 +370,13 @@ xgb_pred <- function(object, newdata, ...) {
 #' @param trees An integer vector for the number of trees in the ensemble.
 multi_predict._xgb.Booster <-
   function(object, new_data, type = NULL, trees = NULL, ...) {
-    if (any(names(enquos(...)) == "newdata"))
+    if (any(names(enquos(...)) == "newdata")) {
       stop("Did you mean to use `new_data` instead of `newdata`?", call. = FALSE)
+    }
 
-    if (is.null(trees))
+    if (is.null(trees)) {
       trees <- object$fit$nIter
+    }
     trees <- sort(trees)
 
     if (is.null(type)) {
@@ -376,9 +386,8 @@ multi_predict._xgb.Booster <-
         type <- "numeric"
     }
 
-    res <-
-      map_df(trees, xgb_by_tree, object = object,
-             new_data = new_data, type = type, ...)
+    res <- map_df(trees, xgb_by_tree, object = object, new_data = new_data,
+                  type = type, ...)
     res <- arrange(res, .row, trees)
     res <- split(res[, -1], res$.row)
     names(res) <- NULL
@@ -451,20 +460,18 @@ C5.0_train <-
     ctrl <- call2("C5.0Control", .ns = "C50")
     ctrl$minCases <- minCases
     ctrl$sample <- sample
-    for(i in names(ctrl_args))
-      ctrl[[i]] <- ctrl_args[[i]]
+    ctrl <- rlang::call_modify(ctrl, !!!ctrl_args)
 
     fit_call <- call2("C5.0", .ns = "C50")
     fit_call$x <- expr(x)
     fit_call$y <- expr(y)
     fit_call$trials <- trials
     fit_call$control <- ctrl
-    if(!is.null(weights))
+    if (!is.null(weights)) {
       fit_call$weights <- quote(weights)
-
-    for (i in names(fit_args)) {
-      fit_call[[i]] <- fit_args[[i]]
     }
+    fit_call <- rlang::call_modify(fit_call, !!!fit_args)
+
     eval_tidy(fit_call)
   }
 

R/decision_tree.R

@@ -187,8 +187,6 @@ translate.decision_tree <- function(x, engine = x$engine, ...) {
         "if the specification is to be translated.",
         call. = FALSE
       )
-    } else {
-      arg_vals$type <- x$mode
     }
 
     # See "Details" in ?ml_random_forest_classifier. `feature_subset_strategy`
@@ -273,18 +271,16 @@ rpart_train <-
     ctrl$minsplit <- minsplit
     ctrl$maxdepth <- maxdepth
     ctrl$cp <- cp
-    for(i in names(ctrl_args))
-      ctrl[[i]] <- ctrl_args[[i]]
+    ctrl <- rlang::call_modify(ctrl, !!!ctrl_args)
 
     fit_call <- call2("rpart", .ns = "rpart")
     fit_call$formula <- expr(formula)
     fit_call$data <- expr(data)
     fit_call$control <- ctrl
-    if(!is.null(weights))
+    if (!is.null(weights)) {
       fit_call$weights <- quote(weights)
-
-    for(i in names(fit_args))
-      fit_call[[i]] <- fit_args[[i]]
+    }
+    fit_call <- rlang::call_modify(fit_call, !!!fit_args)
 
     eval_tidy(fit_call)
   }

R/mlp.R

@@ -275,27 +275,31 @@ keras_mlp <-
            seeds = sample.int(10^5, size = 3),
            ...) {
 
-    if(decay > 0 & dropout > 0)
+    if (decay > 0 & dropout > 0) {
       stop("Please use either dropoput or weight decay.", call. = FALSE)
-
-    if (!is.matrix(x))
+    }
+    if (!is.matrix(x)) {
       x <- as.matrix(x)
+    }
 
-    if(is.character(y))
+    if (is.character(y)) {
       y <- as.factor(y)
+    }
     factor_y <- is.factor(y)
 
-    if (factor_y)
+    if (factor_y) {
       y <- class2ind(y)
-    else {
-      if (isTRUE(ncol(y) > 1))
+    } else {
+      if (isTRUE(ncol(y) > 1)) {
         y <- as.matrix(y)
-      else
+      } else {
         y <- matrix(y, ncol = 1)
+      }
     }
 
     model <- keras::keras_model_sequential()
-    if(decay > 0) {
+
+    if (decay > 0) {
       model %>%
         keras::layer_dense(
           units = hidden_units,
@@ -313,53 +317,57 @@ keras_mlp <-
           kernel_initializer = keras::initializer_glorot_uniform(seed = seeds[1])
         )
     }
-    if(dropout > 0)
+
+    if (dropout > 0) {
       model %>%
-      keras::layer_dense(
-        units = hidden_units,
-        activation = act,
-        input_shape = ncol(x),
-        kernel_initializer = keras::initializer_glorot_uniform(seed = seeds[1])
-      ) %>%
-      keras::layer_dropout(rate = dropout, seed = seeds[2])
-
-    if (factor_y)
+        keras::layer_dense(
+          units = hidden_units,
+          activation = act,
+          input_shape = ncol(x),
+          kernel_initializer = keras::initializer_glorot_uniform(seed = seeds[1])
+        ) %>%
+        keras::layer_dropout(rate = dropout, seed = seeds[2])
+    }
+
+    if (factor_y) {
       model <- model %>%
-      keras::layer_dense(
-        units = ncol(y),
-        activation = 'softmax',
-        kernel_initializer = keras::initializer_glorot_uniform(seed = seeds[3])
-      )
-    else
+        keras::layer_dense(
+          units = ncol(y),
+          activation = 'softmax',
+          kernel_initializer = keras::initializer_glorot_uniform(seed = seeds[3])
+        )
+    } else {
       model <- model %>%
-      keras::layer_dense(
-        units = ncol(y),
-        activation = 'linear',
-        kernel_initializer = keras::initializer_glorot_uniform(seed = seeds[3])
-      )
+        keras::layer_dense(
+          units = ncol(y),
+          activation = 'linear',
+          kernel_initializer = keras::initializer_glorot_uniform(seed = seeds[3])
+        )
+    }
 
     arg_values <- parse_keras_args(...)
-    compile_call <- expr(
-      keras::compile(object = model)
-    )
-    if(!any(names(arg_values$compile) == "loss"))
-      compile_call$loss <-
-      if(factor_y) "binary_crossentropy" else "mse"
-    if(!any(names(arg_values$compile) == "optimizer"))
+    compile_call <- expr(keras::compile(object = model))
+    if (!any(names(arg_values$compile) == "loss")) {
+      if (factor_y) {
+        compile_call$loss <- "binary_crossentropy"
+      } else {
+        compile_call$loss <- "mse"
+      }
+    }
+
+    if (!any(names(arg_values$compile) == "optimizer")) {
       compile_call$optimizer <- "adam"
-    for(arg in names(arg_values$compile))
-      compile_call[[arg]] <- arg_values$compile[[arg]]
+    }
+
+    compile_call <- rlang::call_modify(compile_call, !!!arg_values$compile)
 
     model <- eval_tidy(compile_call)
 
-    fit_call <- expr(
-      keras::fit(object = model)
-    )
+    fit_call <- expr(keras::fit(object = model))
     fit_call$x <- quote(x)
     fit_call$y <- quote(y)
     fit_call$epochs <- epochs
-    for(arg in names(arg_values$fit))
-      fit_call[[arg]] <- arg_values$fit[[arg]]
+    fit_call <- rlang::call_modify(fit_call, !!!arg_values$fit)
 
     history <- eval_tidy(fit_call)
     model