Enough changes to get rand_forest with a formula interface working

Author: DavisVaughan

R/descriptors.R

@@ -50,10 +50,10 @@
 #'
 #' rand_forest(mode = "classification", mtry = expr(n_cols - 2))
 #' }
-#' 
+#'
 #' When no instance of `expr` is found in any of the argument
 #'  values, the descriptor calculation code will not be executed.
-#' 
+#'
 NULL
 
 get_descr_form <- function(formula, data) {
@@ -66,24 +66,37 @@ get_descr_form <- function(formula, data) {
 }
 
 get_descr_df <- function(formula, data) {
-  
+
   tmp_dat <- convert_form_to_xy_fit(formula, data, indicators = FALSE)
-  
+
   if(is.factor(tmp_dat$y)) {
-    n_levs <- table(tmp_dat$y, dnn = NULL)
-  } else n_levs <- NA
-  
-  n_cols <- ncol(tmp_dat$x)
-  n_preds <- ncol(convert_form_to_xy_fit(formula, data, indicators = TRUE)$x)
-  n_obs <- nrow(data)
-  n_facts <- sum(vapply(tmp_dat$x, is.factor, logical(1)))
-  
+    n_levs <- function() {
+      table(tmp_dat$y, dnn = NULL)
+    }
+  } else n_levs <- function() { NA }
+
+  n_cols <- function() {
+    ncol(tmp_dat$x)
+  }
+
+  n_preds <- function() {
+    ncol(convert_form_to_xy_fit(formula, data, indicators = TRUE)$x)
+  }
+
+  n_obs <- function() {
+    nrow(data)
+  }
+
+  n_facts <- function() {
+    sum(vapply(tmp_dat$x, is.factor, logical(1)))
+  }
+
   list(
-    cols = n_cols,
-    preds = n_preds,
-    obs = n_obs,
-    levs = n_levs,
-    facts = n_facts
+    n_cols = n_cols,
+    n_preds = n_preds,
+    n_obs = n_obs,
+    n_levs = n_levs,
+    n_facts = n_facts
   )
 }
 
@@ -93,9 +106,9 @@ get_descr_df <- function(formula, data) {
 #' @importFrom rlang syms sym
 #' @importFrom utils head
 get_descr_spark <- function(formula, data) {
-  
+
   all_vars <- all.vars(formula)
-  
+
   if("." %in% all_vars){
     tmpdata <- dplyr::collect(head(data, 1000))
     f_terms <- stats::terms(formula, data = tmpdata)
@@ -106,11 +119,11 @@ get_descr_spark <- function(formula, data) {
     term_data <- dplyr::select(data, !!! rlang::syms(f_cols))
     tmpdata <- dplyr::collect(head(term_data, 1000))
   }
-  
+
   f_term_labels <- attr(f_terms, "term.labels")
   y_ind <- attr(f_terms, "response")
   y_col <- f_cols[y_ind]
-  
+
   classes <- purrr::map(tmpdata, class)
   icats <- purrr::map_lgl(classes, ~.x == "character")
   cats <- classes[icats]
@@ -119,14 +132,14 @@ get_descr_spark <- function(formula, data) {
   cat_levels <- imap(
     cats,
     ~{
-      p <- dplyr::group_by(data, !! rlang::sym(.y)) 
+      p <- dplyr::group_by(data, !! rlang::sym(.y))
       p <- dplyr::summarise(p)
       dplyr::pull(p)
     }
-  ) 
+  )
   numeric_pred <- length(f_term_labels) - length(cat_levels)
-  
-  
+
+
   if(length(cat_levels) > 0){
     n_dummies <- purrr::map_dbl(cat_levels, ~length(.x) - 1)
     n_dummies <- sum(n_dummies)
@@ -136,27 +149,27 @@ get_descr_spark <- function(formula, data) {
     factor_pred <- 0
     all_preds <- numeric_pred
   }
-  
+
   out_cats <- classes[icats]
   out_cats <- out_cats[names(out_cats) == y_col]
-  
+
   outs <- purrr::imap(
     out_cats,
     ~{
-      p <- dplyr::group_by(data, !! sym(.y)) 
-      p <- dplyr::tally(p) 
+      p <- dplyr::group_by(data, !! sym(.y))
+      p <- dplyr::tally(p)
       dplyr::collect(p)
     }
-  ) 
-  
+  )
+
   if(length(outs) > 0){
     outs <- outs[[1]]
     y_vals <- purrr::as_vector(outs[,2])
     names(y_vals) <- purrr::as_vector(outs[,1])
     y_vals <- y_vals[order(names(y_vals))]
     y_vals <- as.table(y_vals)
   } else y_vals <- NA
-  
+
   list(
     cols = length(f_term_labels),
     preds = all_preds,
@@ -170,15 +183,15 @@ get_descr_xy <- function(x, y) {
   if(is.factor(y)) {
     n_levs <- table(y, dnn = NULL)
   } else n_levs <- NA
-  
+
   n_cols  <- ncol(x)
   n_preds <- ncol(x)
   n_obs   <- nrow(x)
   n_facts <- if(is.data.frame(x))
     sum(vapply(x, is.factor, logical(1)))
   else
     sum(apply(x, 2, is.factor)) # would this always be zero?
-  
+
   list(
     cols = n_cols,
     preds = n_preds,

R/fit.R

@@ -103,7 +103,8 @@ fit.model_spec <-
     cl <- match.call(expand.dots = TRUE)
     # Create an environment with the evaluated argument objects. This will be
     # used when a model call is made later.
-    eval_env <- rlang::env()
+
+    eval_env <- rlang::new_environment(parent = rlang::base_env())
     eval_env$data <- data
     eval_env$formula <- formula
     fit_interface <-
@@ -181,6 +182,7 @@ fit_xy.model_spec <-
            control = fit_control(),
            ...
   ) {
+
     cl <- match.call(expand.dots = TRUE)
     eval_env <- rlang::env()
     eval_env$x <- x

R/fit_helpers.R

@@ -15,6 +15,31 @@ form_form <-
 
     object <- check_mode(object, y_levels)
 
+    # check to see of there are any `expr` in the arguments then
+    # run a function that evaluates the data and subs in the
+    # values of the expressions. we would have to evaluate the
+    # formula (perhaps with and without dummy variables) to get
+    # the appropraite number of columns. (`..vars..` vs `..cols..`)
+    # Perhaps use `convert_form_to_xy_fit` here to get the results.
+
+    if (make_descr(object)) {
+      data_stats <- get_descr_form(env$formula, env$data)
+
+      object$args <- purrr::map(object$args, ~{
+
+        .x_env <- rlang::quo_get_env(.x)
+
+        if(identical(.x_env, rlang::empty_env())) {
+          .x
+        } else {
+          .x_new_env <- rlang::env_bury(.x_env, !!! data_stats)
+          rlang::quo_set_env(.x, .x_new_env)
+        }
+
+      })
+
+    }
+
     # sub in arguments to actual syntax for corresponding engine
     object <- translate(object, engine = object$engine)
 
@@ -28,22 +53,6 @@ form_form <-
     }
     fit_args$formula <- quote(formula)
 
-    # check to see of there are any `expr` in the arguments then
-    # run a function that evaluates the data and subs in the
-    # values of the expressions. we would have to evaluate the
-    # formula (perhaps with and without dummy variables) to get
-    # the appropraite number of columns. (`..vars..` vs `..cols..`)
-    # Perhaps use `convert_form_to_xy_fit` here to get the results.
-
-    if (make_descr(object)) {
-      data_stats <- get_descr_form(env$formula, env$data)
-      env$n_obs <- data_stats$obs
-      env$n_cols <- data_stats$cols
-      env$n_preds <- data_stats$preds
-      env$n_levs <- data_stats$levs
-      env$n_facts <- data_stats$facts
-    }
-
     fit_call <- make_call(
       fun = object$method$fit$func["fun"],
       ns = object$method$fit$func["pkg"],

R/misc.R

@@ -56,10 +56,12 @@ model_printer <- function(x, ...) {
   non_null_args <- x$args[!vapply(x$args, null_value, lgl(1))]
   if (length(non_null_args) > 0) {
     cat("Main Arguments:\n")
+    non_null_args <- map(non_null_args, convert_arg)
     cat(print_arg_list(non_null_args), "\n", sep = "")
   }
   if (length(x$others) > 0) {
     cat("Engine-Specific Arguments:\n")
+    x$others <- map(x$others, convert_arg)
     cat(print_arg_list(x$others), "\n", sep = "")
   }
   if (!is.null(x$engine)) {
@@ -95,6 +97,8 @@ is_missing_arg <- function(x)
 #' @keywords internal
 #' @export
 show_call <- function(object) {
+  object$method$fit$args <-
+    map(object$method$fit$args, convert_arg)
   if (
     is.null(object$method$fit$func["pkg"]) ||
     is.na(object$method$fit$func["pkg"])
@@ -109,8 +113,17 @@ show_call <- function(object) {
   res
 }
 
+convert_arg <- function(x) {
+  if (is_quosure(x))
+    quo_get_expr(x)
+  else
+    x
+}
+
 make_call <- function(fun, ns, args, ...) {
 
+  #args <- map(args, convert_arg)
+
   # remove any null or placeholders (`missing_args`) that remain
   discard <-
     vapply(args, function(x)

R/rand_forest.R

@@ -103,10 +103,12 @@
 
 rand_forest <-
   function(mode = "unknown",
-           ...,
-           mtry = NULL, trees = NULL, min_n = NULL,
-           others = list()) {
-    check_empty_ellipse(...)
+           mtry = NULL, trees = NULL, min_n = NULL, ...) {
+
+    others <- enquos(...)
+    mtry   <- enquo(mtry)
+    trees  <- enquo(trees)
+    min_n  <- enquo(min_n)
 
     ## TODO: make a utility function here
     if (!(mode %in% rand_forest_modes))