Merge pull request #199 from tidymodels/rlang-tibble-updates

rlang and tibble updates

Author: topepo

.travis.yml

@@ -22,9 +22,36 @@ matrix:
   allow_failures:
     - r: 3.3       # inum      install failure (seg fault)
     - r: 3.2       # partykit  install failure (libcoin needs >= 3.4.0)
-    - r: 3.4       # mvtnorm requires >= 3.5.0
+    - r: 3.4       # mvtnorm   requires >= 3.5.0
+
+r_binary_packages:
+  - RCurl
+  - dplyr
+  - glue
+  - magrittr
+  - stringi
+  - stringr
+  - munsell
+  - rlang
+  - reshape2
+  - scales
+  - tibble
+  - ggplot2
+  - Rcpp
+  - RcppEigen
+  - BH
+  - glmnet
+  - earth
+  - sparklyr
+  - flexsurv
+  - ranger
+  - randomforest
+  - xgboost
+  - C50
+
 
 cache:
+  packages: true
   directories:
     - $HOME/.keras
     - $HOME/.cache/pip

DESCRIPTION

@@ -28,7 +28,7 @@ Imports:
     stats,
     tidyr,
     globals,
-    vctrs
+    vctrs (>= 0.2.0)
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 6.1.1
 Suggests: 
@@ -50,4 +50,3 @@ Suggests:
     rpart,
     MASS,
     nlme
-Remotes: r-lib/vctrs

NEWS.md

@@ -22,6 +22,8 @@ Unplanned release based on CRAN requirements for Solaris.
 
  * A suite of internal functions were added to help with upcoming model tuning features.  
 
+ * A `parsnip` object always saved the name(s) of the outcome variable(s) for proper naming of the predicted values. 
+
 
 # parsnip 0.0.2
 

R/aaa.R

@@ -1,9 +1,15 @@
 
 maybe_multivariate <- function(results, object) {
-  if (isTRUE(ncol(results) > 1))
-    results <- as_tibble(results)
-  else
+
+  if (isTRUE(ncol(results) > 1)) {
+    nms <- colnames(results)
+    results <- as_tibble(results, .name_repair = "minimal")
+    if (length(nms) == 0 && length(object$preproc$y_var) == ncol(results)) {
+      names(results) <- object$preproc$y_var
+    }
+  }  else {
     results <- unname(results[, 1])
+  }
   results
 }
 

R/arguments.R

@@ -1,9 +1,11 @@
 #' @importFrom rlang expr enquos enquo quos is_quosure call2 quo_get_expr ll
 #' @importFrom rlang abort current_env get_expr is_missing is_null is_symbolic  missing_arg
 null_value <- function(x) {
-  res <- if(is_quosure(x))
-    isTRUE(all.equal(x[[-1]], quote(NULL))) else
-      isTRUE(all.equal(x, NULL))
+  if (is_quosure(x)) {
+    res <- isTRUE(all.equal(rlang::get_expr(x), expr(NULL)))
+  } else {
+    res <- isTRUE(all.equal(x, NULL))
+  }
   res
 }
 

R/fit_helpers.R

@@ -59,7 +59,7 @@ form_form <-
       env = env,
       ...
     )
-    res$preproc <- NA
+    res$preproc <- list(y_var = all.vars(env$formula[[2]]))
     res
   }
 
@@ -114,7 +114,12 @@ xy_xy <- function(object, env, control, target = "none", ...) {
     env = env,
     ...
   )
-  res$preproc <- NA
+  if (is.vector(env$y)) {
+    y_name <- character(0)
+  } else {
+    y_name <- colnames(env$y)
+  }
+  res$preproc <- list(y_var = y_name)
   res
 }
 
@@ -144,6 +149,7 @@ form_xy <- function(object, control, env,
     control = control,
     target = target
   )
+  data_obj$y_var <- all.vars(env$formula[[2]])
   data_obj$x <- NULL
   data_obj$y <- NULL
   data_obj$weights <- NULL
@@ -177,7 +183,12 @@ xy_form <- function(object, env, control, ...) {
     control = control,
     ...
   )
-  res$preproc <- data_obj["x_var"]
+  if (is.vector(env$y)) {
+    data_obj$y_var <- character(0)
+  } else {
+    data_obj$y_var <- colnames(env$y)
+  }
+  res$preproc <- data_obj[c("x_var", "y_var")]
   res
 }
 

R/logistic_reg_data.R

@@ -333,8 +333,8 @@ set_pred(
   value = list(
     pre = NULL,
     post = function(x, object) {
-      x <- as_tibble(x)
       colnames(x) <- object$lvl
+      x <- as_tibble(x)
       x
     },
     func = c(pkg = "keras", fun = "predict_proba"),

R/mars.R

@@ -59,7 +59,6 @@
 #' @examples
 #' mars(mode = "regression", num_terms = 5)
 #' @export
-
 mars <-
   function(mode = "unknown",
            num_terms = NULL, prod_degree = NULL, prune_method = NULL) {
@@ -149,7 +148,7 @@ translate.mars <- function(x, engine = x$engine, ...) {
   # see if it is there and, if not, add the default value.
   if (x$mode == "classification") {
     if (!("glm" %in% names(x$eng_args))) {
-      x$eng_args$glm <- quote(list(family = stats::binomial))
+      x$eng_args$glm <- rlang::quo(list(family = stats::binomial))
     }
   }
 
@@ -193,8 +192,8 @@ earth_reg_updater <- function(num, object, new_data, ...) {
   if (ncol(pred) == 1) {
     res <- tibble::tibble(.pred = pred[, 1], nprune = num)
   } else {
-    res <- tibble::as_tibble(res)
     names(res) <- paste0(".pred_", names(res))
+    res <- tibble::as_tibble(res)
     res$nprune <- num
   }
   res

R/misc.R

@@ -223,3 +223,15 @@ check_outcome <- function(y, spec) {
   invisible(NULL)
 }
 
+
+# Get's a character string of varible names used as the outcome
+# in a terms object
+terms_y <- function(x) {
+  att <- attributes(x)
+  resp_ind <- att$response
+  y_expr <- att$predvars[[resp_ind + 1]]
+  all.vars(y_expr)
+}
+
+
+

R/mlp.R

@@ -370,6 +370,7 @@ keras_mlp <-
     fit_call <- rlang::call_modify(fit_call, !!!arg_values$fit)
 
     history <- eval_tidy(fit_call)
+    model$y_names <- colnames(y)
     model
   }
 
@@ -379,8 +380,9 @@ nnet_softmax <- function(results, object) {
     results <- cbind(1 - results, results)
 
   results <- apply(results, 1, function(x) exp(x)/sum(exp(x)))
-  results <- as_tibble(t(results))
+  results <- t(results)
   names(results) <- paste0(".pred_", object$lvl)
+  results <- as_tibble(results)
   results
 }
 
@@ -419,7 +421,7 @@ parse_keras_args <- function(...) {
 }
 
 mlp_num_weights <- function(p, hidden_units, classes) {
-  ((p+1) * hidden_units) + ((hidden_units+1) * classes)
+  ((p + 1) * hidden_units) + ((hidden_units+1) * classes)
 }