Added FNN, liquidSVM and neuralnet engines

Author: stevenpawley

R/mlp_data.R

@@ -311,3 +311,125 @@ set_pred(
       )
   )
 )
+
+# ------------------------------------------------------------------------------
+
+set_model_engine("mlp", "classification", "neuralnet")
+set_model_engine("mlp", "regression", "neuralnet")
+set_dependency("mlp", "neuralnet", "neuralnet")
+
+set_model_arg(
+  model = "mlp",
+  eng = "neuralnet",
+  parsnip = "hidden_units",
+  original = "hidden",
+  func = list(pkg = "dials", fun = "hidden_units"),
+  has_submodel = FALSE
+)
+set_fit(
+  model = "mlp",
+  eng = "neuralnet",
+  mode = "classification",
+  value = list(
+    interface = "formula",
+    protect = c("formula", "data"),
+    func = c(pkg = "neuralnet", fun = "neuralnet"),
+    defaults = list(
+      rep = 1,
+      linear.output = FALSE
+    )
+  )
+)
+set_fit(
+  model = "mlp",
+  eng = "neuralnet",
+  mode = "regression",
+  value = list(
+    interface = "formula",
+    protect = c("formula", "data"),
+    func = c(pkg = "neuralnet", fun = "neuralnet"),
+    defaults = list(
+      rep = 1,
+      linear.output = TRUE
+    )
+  )
+)
+set_pred(
+  model = "mlp",
+  eng = "neuralnet",
+  mode = "classification",
+  type = "class",
+  value = list(
+    pre = NULL,
+    post = function(x, object) object$lvl[apply(x, 1, which.max)],
+    func = c(pkg = "stats", fun = "predict"),
+    args = list(
+      object = quote(object$fit),
+      newdata = quote(new_data)
+    )
+  )
+)
+set_pred(
+  model = "mlp",
+  eng = "neuralnet",
+  mode = "classification",
+  type = "prob",
+  value = list(
+    pre = NULL,
+    post = function(x, object) {
+      colnames(x) <- object$lvl
+      tibble::as_tibble(x)
+    },
+    func = c(pkg = "stats", fun = "predict"),
+    args = list(
+      object = quote(object$fit),
+      newdata = quote(new_data),
+      prob = TRUE
+    )
+  )
+)
+set_pred(
+  model = "mlp",
+  eng = "neuralnet",
+  mode = "classification",
+  type = "raw",
+  value = list(
+    pre = NULL,
+    post = NULL,
+    func = c(pkg = "stats", fun = "predict"),
+    args = list(
+      object = quote(object$fit),
+      newdata = quote(new_data)
+    )
+  )
+)
+set_pred(
+  model = "mlp",
+  eng = "neuralnet",
+  mode = "regression",
+  type = "numeric",
+  value = list(
+    pre = NULL,
+    post = function(x, object) as.numeric(x),
+    func = c(pkg = "stats", fun = "predict"),
+    args = list(
+      object = quote(object$fit),
+      newdata = quote(new_data)
+    )
+  )
+)
+set_pred(
+  model = "mlp",
+  eng = "neuralnet",
+  mode = "regression",
+  type = "raw",
+  value = list(
+    pre = NULL,
+    post = NULL,
+    func = c(pkg = "stats", fun = "predict"),
+    args = list(
+      object = quote(object$fit),
+      newdata = quote(new_data)
+    )
+  )
+)

R/nearest_neighbor.R

@@ -211,3 +211,86 @@ knn_by_k <- function(k, object, new_data, type, ...) {
     dplyr::mutate(neighbors = k, .row = dplyr::row_number()) %>%
     dplyr::select(.row, neighbors, dplyr::starts_with(".pred"))
 }
+
+# ------------------------------------------------------------------------------
+
+#' Nearest neighbors using FNN
+#'
+#' `fnn_train` is a wrapper for `FNN` fast nearest neighbor models
+#'
+#' @param x a data frame or matrix of predictors.
+#' @param y a vector (factor or numeric) or matrix (numeric) of outcome data.
+#' @param k a vector (integer) of the number of neighbours to consider.
+#' @param algorithm character, one of c("kd_tree", "cover_tree", "brute"),
+#'   default = "kd_tree"
+#' @param ... additional arguments to pass to FNN, currently unused.
+#'
+#' @return list containing the FNN call
+#' @export
+fnn_train <- function(x, y = NULL, k = 1, algorithm = "kd_tree", ...) {
+
+  # regression
+  if (is.numeric(y)) {
+    fun <- "knn.reg"
+    main_args <- list(
+      train = rlang::enquo(x),
+      y = rlang::enquo(y),
+      k = k,
+      algorithm = algorithm)
+    call <- parsnip:::make_call(fun = fun, ns = "FNN", main_args)
+    rlang::eval_tidy(call, env = rlang::current_env())
+
+    # for classification return unevaluated call because FNN:knn
+    # trains and predicts in same call
+  } else {
+    fun <- "knn"
+    main_args <- list(
+      train = rlang::enquo(x),
+      cl = rlang::enquo(y),
+      k = k,
+      algorithm = algorithm)
+    call <- parsnip:::make_call(fun = fun, ns = "FNN", main_args)
+    list(call = call)
+  }
+}
+
+
+#' Nearest neighbors prediction using FNN
+#'
+#' `fnn_pred` is a wrapper for `FNN` fast nearest neighbor models
+#'
+#' @param object parsnip model spec.
+#' @param newdata data.frame or matrix of training data.
+#' @param prob logical return predicted probability of the winning class,
+#'   default = FALSE.
+#' @param ... additional arguments to pass to FNN, currently unused.
+#'
+#' @return data.frame containing the predicted results.
+#' @export
+fnn_pred <- function(object, newdata, prob = FALSE, ...) {
+
+  # modify the call for prediction
+  object$call$test <- newdata
+
+  # regression result
+  if ("y" %in% names(object$call)) {
+    res <- rlang::eval_tidy(object$call)
+    res <- res$pred
+
+    # classification result
+  } else {
+    object$call$prob <- prob
+    lvl <- levels(rlang::eval_tidy(object$call$cl))
+    res <- rlang::eval_tidy(object$call)
+
+    # probability for winning class
+    if (prob == FALSE) {
+      attributes(res) <- NULL
+      res <- factor(lvl[res], levels = lvl)
+    } else {
+      res <- attr(res, "prob")
+    }
+  }
+
+  res
+}

R/nearest_neighbor_data.R

@@ -172,3 +172,116 @@ set_pred(
       )
   )
 )
+
+# ------------------------------------------------------------------------------
+
+set_model_engine("nearest_neighbor", "classification", "FNN")
+set_model_engine("nearest_neighbor", "regression", "FNN")
+set_dependency("nearest_neighbor", "FNN", "FNN")
+
+set_model_arg(
+  model = "nearest_neighbor",
+  eng = "FNN",
+  parsnip = "neighbors",
+  original = "k",
+  func = list(pkg = "dials", fun = "neighbors"),
+  has_submodel = FALSE
+)
+set_fit(
+  model = "nearest_neighbor",
+  eng = "FNN",
+  mode = "regression",
+  value = list(
+    interface = "matrix",
+    protect = c("x", "y"),
+    func = c(fun = "fnn_train"),
+    defaults = list()
+  )
+)
+set_fit(
+  model = "nearest_neighbor",
+  eng = "FNN",
+  mode = "classification",
+  value = list(
+    interface = "matrix",
+    protect = c("x", "y"),
+    func = c(fun = "fnn_train"),
+    defaults = list()
+  )
+)
+set_pred(
+  model = "nearest_neighbor",
+  eng = "FNN",
+  mode = "regression",
+  type = "numeric",
+  value = list(
+    pre = NULL,
+    post = NULL,
+    func = c(fun = "fnn_pred"),
+    args = list(
+      object = quote(object$fit),
+      newdata = quote(new_data)
+    )
+  )
+)
+set_pred(
+  model = "nearest_neighbor",
+  eng = "FNN",
+  mode = "regression",
+  type = "raw",
+  value = list(
+    pre = NULL,
+    post = NULL,
+    func = c(fun = "fnn_pred"),
+    args = list(
+      object = quote(object$fit),
+      newdata = quote(new_data)
+    )
+  )
+)
+set_pred(
+  model = "nearest_neighbor",
+  eng = "FNN",
+  mode = "classification",
+  type = "class",
+  value = list(
+    pre = NULL,
+    post = NULL,
+    func = c(fun = "fnn_pred"),
+    args = list(
+      object = quote(object$fit),
+      newdata = quote(new_data)
+    )
+  )
+)
+set_pred(
+  model = "nearest_neighbor",
+  eng = "FNN",
+  mode = "classification",
+  type = "prob",
+  value = list(
+    pre = NULL,
+    post = function(result, object) tibble::as_tibble(result),
+    func = c(fun = "fnn_pred"),
+    args =
+      list(
+        object = quote(object$fit),
+        newdata = quote(new_data),
+        prob = TRUE
+      )
+  )
+)
+set_pred(
+  model = "nearest_neighbor",
+  eng = "FNN",
+  mode = "classification",
+  type = "raw",
+  value = list(
+    pre = NULL,
+    post = NULL,
+    func = c(fun = "fnn_pred"),
+    args = list(
+      object = quote(object$fit),
+      newdata = quote(new_data))
+  )
+)

R/svm_rbf.R

@@ -158,6 +158,21 @@ translate.svm_rbf <- function(x, engine = x$engine, ...) {
     }
 
   }
+
+  if (x$engine == "liquidSVM") {
+    # convert parameter arguments
+    if (any(arg_names == "sigma")) {
+      arg_vals$gammas <- rlang::quo(1 / !!sqrt(arg_vals$sigma))
+      arg_vals$sigma <- NULL
+    }
+
+    if (any(arg_names == "C")) {
+      arg_vals$lambdas <- arg_vals$C
+      arg_vals$C <- NULL
+    }
+
+  }
+
   x$method$fit$args <- arg_vals
 
   # worried about people using this to modify the specification