40 | ![]()
43 |
44 | License
41 | 42 |YEAR: 2019 45 | COPYRIGHT HOLDER: Steven Pawley 46 |47 | 48 |
${s.title}
`;
142 | } else if (s.previous_headings == "") {
143 | return `${s.dir} > ${s.title}
> ${s.what}`;
144 | } else {
145 | return `${s.dir} > ${s.title}
> ${s.previous_headings} > ${s.what}`;
146 | }
147 | },
148 | },
149 | },
150 | ]).on('autocomplete:selected', function(event, s) {
151 | window.location.href = s.path + "?q=" + q + "#" + s.id;
152 | });
153 | });
154 | })(window.jQuery || window.$)
155 |
156 |
157 |
--------------------------------------------------------------------------------
/man/step_select_forests.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/step_select_forests.R
3 | \name{step_select_forests}
4 | \alias{step_select_forests}
5 | \alias{tidy.step_select_forests}
6 | \title{Feature selection step using a random forest feature importance scores}
7 | \usage{
8 | step_select_forests(
9 | recipe,
10 | ...,
11 | outcome = NULL,
12 | role = "predictor",
13 | trained = FALSE,
14 | engine = "ranger",
15 | options = list(importance = "permutation"),
16 | mtry = NULL,
17 | trees = NULL,
18 | min_n = NULL,
19 | top_p = NA,
20 | threshold = NA,
21 | cutoff = NA,
22 | exclude = NULL,
23 | scores = NULL,
24 | skip = FALSE,
25 | id = recipes::rand_id("select_forests")
26 | )
27 |
28 | \method{tidy}{step_select_forests}(x, type = "terms", ...)
29 | }
30 | \arguments{
31 | \item{recipe}{A recipe object. The step will be added to the sequence of
32 | operations for this recipe.}
33 |
34 | \item{...}{One or more selector functions to choose which predictors are
35 | affected by the step. See [selections()] for more details. For the `tidy`
36 | method, these are not currently used.}
37 |
38 | \item{outcome}{A character string with the name of the response variable to
39 | use to calculate the feature importance scores.}
40 |
41 | \item{role}{Not used by this step since no new variables are created.}
42 |
43 | \item{trained}{A logical to indicate if the quantities for preprocessing have
44 | been estimated.}
45 |
46 | \item{engine}{A supported rand_forest engine that is supported by parsnip.
47 | The default is "ranger".}
48 |
49 | \item{options}{A named list of options to pass to the rand_forest engine. For
50 | example, if `engine = 'ranger'` (the default) then options could be
51 | `list(permutation = 'importance`) because a feature importance method needs
52 | to be specified for this engine. This is the default.}
53 |
54 | \item{mtry}{An integer for the number of predictors that will be randomly
55 | sampled at each split when creating the tree models.}
56 |
57 | \item{trees}{An integer for the number of trees contained in the ensemble.}
58 |
59 | \item{min_n}{An integer for the minimum number of data points in a node that
60 | are required for the node to be split further.}
61 |
62 | \item{top_p}{An integer that will be used to select the `top_p` predictors
63 | with the smallest p-values. A value of `NA` implies that this criterion
64 | will be ignored.}
65 |
66 | \item{threshold}{A numeric value between 0 and 1 representing the percentile
67 | of best scoring features to select. For example `threshold = 0.9` will
68 | retain only predictors with scores in the top 90th percentile and a smaller
69 | threshold will select more features. Note that `top_p` and `threshold` are
70 | mutually exclusive but either can be used in conjunction with `cutoff` to
71 | select the top-ranked features and those that are smaller than the cutoff
72 | value.}
73 |
74 | \item{cutoff}{A numeric value, in -log10(p-value) units, where predictors
75 | with _larger_ than the cutoff will be retained. A value of `NA` implies
76 | that this criterion will be ignored.}
77 |
78 | \item{exclude}{A character vector of predictor names that will be removed
79 | from the data. This will be set when `prep()` is used on the recipe and
80 | should not be set by the user.}
81 |
82 | \item{scores}{A tibble with 'variable' and 'scores' columns containing the
83 | names of the variables and their feature importance scores. This parameter
84 | is only produced after the recipe has been trained.}
85 |
86 | \item{skip}{A logical. Should the step be skipped when the recipe is baked by
87 | bake.recipe()? While all operations are baked when prep.recipe() is run,
88 | some operations may not be able to be conducted on new data (e.g.
89 | processing the outcome variable(s)). Care should be taken when using skip =
90 | TRUE as it may affect the computations for subsequent operations.}
91 |
92 | \item{id}{A character string that is unique to this step to identify it.}
93 |
94 | \item{x}{A `step_select_forests` object.}
95 |
96 | \item{type}{A character with either 'terms' (the default) to return a
97 | tibble containing the variables that have been removed by the filter step,
98 | or 'scores' to return the scores for each variable.}
99 | }
100 | \value{
101 | An updated version of `recipe` with the new step added to the
102 | sequence of existing steps (if any). For the `tidy` method, a tibble with a
103 | `terms` column for which predictors were removed.
104 | }
105 | \description{
106 | `step_select_forests` creates a *specification* of a recipe step that selects
107 | a subset of predictors based on the ranking of variable importance using a
108 | `parsnip::rand_forest` supported model.
109 | }
110 | \examples{
111 | library(recipes)
112 | library(parsnip)
113 |
114 | # load the example iris dataset
115 | data(cells, package = "modeldata")
116 |
117 | # create a preprocessing recipe
118 | rec <-
119 | recipe(class ~ ., data = cells[, -1]) \%>\%
120 | step_select_forests(all_predictors(), outcome = "class", top_p = 10,
121 | cutoff = 0.9)
122 |
123 | prepped <- prep(rec)
124 |
125 | preproc_data <- juice(prepped)
126 | prepped
127 | }
128 |
--------------------------------------------------------------------------------
/docs/LICENSE-text.html:
--------------------------------------------------------------------------------
1 |
2 |
38 |
60 |
61 |
62 |
63 |
64 |
65 |
66 |
67 |
--------------------------------------------------------------------------------
/R/misc.R:
--------------------------------------------------------------------------------
1 | check_zero_one <- function(x) {
2 | if (is.na(x)) {
3 | return(x)
4 | } else {
5 | if (is.numeric(x)) {
6 | if (x >= 1 | x <= 0) {
7 | rlang::abort("`threshold` should be on (0, 1).")
8 | }
9 | } else {
10 | rlang::abort("`threshold` should be numeric.")
11 | }
12 | }
13 | return(x)
14 | }
15 |
16 | check_top_p <- function(x, n) {
17 | # checks on x (top_p) and n (number of features)
18 | if (is.na(x)) {
19 | return(x)
20 | }
21 |
22 | if (!is.numeric(x)) {
23 | rlang::abort("`top_p` should be numeric.")
24 | }
25 |
26 | if (!is.integer(x)) {
27 | x <- as.integer(x)
28 | }
29 |
30 | msg <- paste0("`top_p` should be on (1, ", n, ") based on the number of features available.")
31 |
32 | # return top_n = all features if top_n > n
33 | if (x >= n) {
34 | rlang::warn(msg)
35 | x <- min(n - 1, x)
36 |
37 | # return a single feature if top_p < 1
38 | } else if (x < 1) {
39 | rlang::warn(msg)
40 | x <- 1
41 | }
42 |
43 | return(x)
44 | }
45 |
46 | check_criteria <- function(top_p, threshold, cl) {
47 | if (is.na(top_p) & is.na(threshold)) {
48 | msg <- paste0(
49 | "For `",
50 | cl[[1]],
51 | "`, `top_p` and `threshold` cannot both be missing."
52 | )
53 | rlang::abort(msg)
54 | }
55 | invisible(NULL)
56 | }
57 |
58 | #' Select features using `top_p` or `threshold`.
59 | #'
60 | #' Feature selection using either the `top_p` or `threshold` features OR
61 | #' `cutoff` where cutoff refers to the absolute numeric value of the feature
62 | #' importance scores.
63 | #'
64 | #' @details
65 | #' `dual_filter` selects feature that are selected using either (`top_p`,
66 | #' `threshold`) or `cutoff` or both. If top_p/threshold and cutoff are both used
67 | #' then features are selected using OR. For example, if top_p selects features 1
68 | #' & 2, and threshold selects features 1 & 3, then the selected features =
69 | #' 1,2,3.
70 | #'
71 | #' @param x a named numeric vector of scores per feature
72 | #' @param top_p an integer specifying the number of top-performing features to
73 | #' retain
74 | #' @param threshold a numeric with percentile of top-performing features to
75 | #' retain. For example, `threshold = 0.9` will only retain features that are
76 | #' in the top 90th percentile. A smaller value of threshold will select
77 | #' more features.
78 | #' @param cutoff a numeric with the value that represents the cutoff in the
79 | #' scores in `x` by which to retain/discard features.
80 | #' @param maximize logical to indicate whether `top_p`, `threshold` and `cutoff`
81 | #' are used to keep features where high scores = 'best' (maximize = TRUE) or
82 | #' where low scores = 'best' (maximize = FALSE).
83 | #'
84 | #' @return character vector of feature names to exclude
85 | #' @keywords internal
86 | dual_filter <- function(x, top_p, threshold, cutoff, maximize) {
87 | if (!is.na(top_p) & !is.na(threshold)) {
88 | rlang::abort("`top_p` and `threshold` are mutually exclusive")
89 | }
90 |
91 | na_x <- x[is.na(x)]
92 | x <- x[!is.na(x)]
93 | x <- sort(x, decreasing = maximize)
94 |
95 | p <- length(x)
96 |
97 | # assign logical selection variable using top_p
98 | if (!is.na(top_p)) {
99 | top_p_lgl <- seq_along(x) <= top_p
100 | } else {
101 | top_p_lgl <- rep(FALSE, p)
102 | }
103 |
104 | # assign logical selection variable using threshold
105 | if (!is.na(threshold)) {
106 | p_to_exceed <- stats::quantile(x, threshold)
107 |
108 | if (maximize) {
109 | threshold_lgl <- x >= p_to_exceed
110 | } else {
111 | threshold_lgl <- x < p_to_exceed
112 | }
113 |
114 | } else {
115 | threshold_lgl <- rep(FALSE, p)
116 | }
117 |
118 | # assign logical selection variable using cutoff
119 | if (!is.na(cutoff)) {
120 | if (maximize) {
121 | cutoff_lgl <- x >= cutoff
122 | } else {
123 | cutoff_lgl <- x <= cutoff
124 | }
125 |
126 | } else {
127 | cutoff_lgl <- rep(FALSE, p)
128 | }
129 |
130 | keep_lgl <- top_p_lgl | threshold_lgl | cutoff_lgl
131 | excluded <- c(names(x)[!keep_lgl], names(na_x))
132 |
133 | return(excluded)
134 | }
135 |
136 | check_outcome <- function(y) {
137 | ifelse(inherits(y, "factor"), "classification", "regression")
138 | }
139 |
140 | get_outcome <- function(x, training, info) {
141 | if (!all(is.na(x$outcome))) {
142 | if (!all(is.character(x$outcome))) {
143 | rlang::abort("Outcome variable must be supplied as a character string")
144 | }
145 |
146 | outcome_col <- x$outcome
147 |
148 | } else {
149 | outcome_col <- info %>%
150 | dplyr::filter(.data$role == 'outcome') %>%
151 | dplyr::pull("variable")
152 | }
153 |
154 | if (length(outcome_col) > 1) {
155 | msg <- paste(
156 | "Multiple outcome variables are present in the recipe.",
157 | "Only a single outcome variable can be accepted by any `step_select` functions.",
158 | "Please supply the outcome variable using the `outcome` argument"
159 | )
160 | rlang::abort(msg)
161 | }
162 |
163 | if (length(outcome_col) < 1) {
164 | msg <- paste(
165 | "An outcome variable was not found.",
166 | "Please ensure an outcome variable is specified."
167 | )
168 | rlang::abort(msg)
169 | }
170 |
171 | if (!outcome_col %in% names(training)) {
172 | rlang::abort(paste0("Outcome variable '", outcome_col, "' not found"))
173 | }
174 |
175 | return(outcome_col)
176 | }
177 |
--------------------------------------------------------------------------------
/man/step_select_relief.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/step_select_relief.R
3 | \name{step_select_relief}
4 | \alias{step_select_relief}
5 | \alias{tidy.step_select_relief}
6 | \title{Feature selection step using the Relief algorithm}
7 | \usage{
8 | step_select_relief(
9 | recipe,
10 | ...,
11 | outcome = NULL,
12 | role = NA,
13 | trained = FALSE,
14 | top_p = NA,
15 | threshold = NA,
16 | cutoff = NA,
17 | neighbors = 5,
18 | sample_size = 10,
19 | exclude = NULL,
20 | scores = NULL,
21 | skip = FALSE,
22 | id = recipes::rand_id("select_relief")
23 | )
24 |
25 | \method{tidy}{step_select_relief}(x, ...)
26 | }
27 | \arguments{
28 | \item{recipe}{A recipe object. The step will be added to the sequence of
29 | operations for this recipe.}
30 |
31 | \item{...}{One or more selector functions to choose which predictors are
32 | affected by the step. See [selections()] for more details. For the `tidy`
33 | method, these are not currently used.}
34 |
35 | \item{outcome}{A character string with the name of the response variable to
36 | use to evaluate information gain value against the predictors.}
37 |
38 | \item{role}{Not used by this step since no new variables are created.}
39 |
40 | \item{trained}{A logical to indicate if the quantities for preprocessing have
41 | been estimated.}
42 |
43 | \item{top_p}{An integer that will be used to select the `top_p` predictors
44 | with the smallest p-values. A value of `NA` implies that this criterion
45 | will be ignored.}
46 |
47 | \item{threshold}{A numeric value between 0 and 1 representing the percentile
48 | of best scoring features to select. For example `threshold = 0.9` will
49 | retain only predictors with scores in the top 90th percentile and a smaller
50 | threshold will select more features. Note that `top_p` and `threshold` are
51 | mutually exclusive but either can be used in conjunction with `cutoff` to
52 | select the top-ranked features and those that are smaller than the cutoff
53 | value.}
54 |
55 | \item{cutoff}{A numeric value, in -log10(p-value) units, where predictors
56 | with _larger_ than the cutoff will be retained. A value of `NA` implies
57 | that this criterion will be ignored.}
58 |
59 | \item{neighbors}{An integer with the number of neighbors for find for each
60 | sampled instance. Default is 5.}
61 |
62 | \item{sample_size}{An integer with the number of instances to sample. Default
63 | is 10.}
64 |
65 | \item{exclude}{A character vector of predictor names that will be removed
66 | from the data. This will be set when `prep()` is used on the recipe and
67 | should not be set by the user.}
68 |
69 | \item{scores}{A tibble with 'variable' and 'scores' columns containing the
70 | names of the variables and their information gain scores. This parameter is
71 | only produced after the recipe has been trained.}
72 |
73 | \item{skip}{A logical. Should the step be skipped when the recipe is baked by
74 | bake.recipe()? While all operations are baked when prep.recipe() is run,
75 | some operations may not be able to be conducted on new data (e.g.
76 | processing the outcome variable(s)). Care should be taken when using skip =
77 | TRUE as it may affect the computations for subsequent operations.}
78 |
79 | \item{id}{A character string that is unique to this step to identify it.}
80 |
81 | \item{x}{A `step_select_relief` object.}
82 | }
83 | \value{
84 | An updated version of `recipe` with the new step added to the
85 | sequence of existing steps (if any). For the `tidy` method, a tibble with a
86 | `terms` column for which predictors were removed.
87 | }
88 | \description{
89 | Relief-based algorithms use nearest neighbors of randomly sampled
90 | observations (without replacement) to derive feature weights/scores that
91 | describe the relevance of each feature to the target variable. The feature
92 | weights represent the differences between the normalized feature values from
93 | each randomly sampled observation and a neighboring observation. If the
94 | neighboring observation's class is the same as the sampled observation
95 | (termed a 'hit') but the feature values are different, then this reduces the
96 | score on the basis that widely varying feature values for the same class are
97 | not desirable. Conversely, if a neighboring observation's class is different
98 | from the sampled observation (termed a 'miss') and the feature values are
99 | different, then this increases the score on the basis that observations of
100 | different classes are widely separated by their feature values. The feature
101 | weights / scores range from -1 (worst) to +1 (best).
102 | }
103 | \details{
104 | `step_select_relief` creates a *specification* of a recipe step that selects
105 | a subset of predictors based on the scores of the relief algorithm. This step
106 | requires the FSinR package to be installed. The top `top_p` scoring features,
107 | or features whose scores occur in the top percentile `threshold` will be
108 | retained as new predictors.
109 |
110 |
111 |
112 | The recipe will stop if all of `top_p`, `threshold` and `cutoff` are left
113 | unspecified.
114 | }
115 | \examples{
116 | \dontrun{
117 | library(recipes)
118 |
119 | data(cells, package = "modeldata")
120 |
121 | rec <- recipe(class ~ ., data = cells[, -1]) \%>\%
122 | step_select_relief(
123 | all_predictors(),
124 | outcome = "class",
125 | top_p = 10
126 | )
127 |
128 | prepped <- prep(rec)
129 | new_data <- bake(prepped, new_data = NULL)
130 | prepped
131 | }
132 | }
133 | \concept{preprocessing}
134 | \concept{supervised_filter}
135 | \keyword{datagen}
136 |
--------------------------------------------------------------------------------
/docs/404.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
39 |
49 |
50 |
51 |
57 |
81 |
82 |
83 |
84 |
85 |
86 |
87 |
88 |
--------------------------------------------------------------------------------
/R/step_select_boruta.R:
--------------------------------------------------------------------------------
1 | #' Feature selection step using Boruta
2 | #'
3 | #' `step_select_boruta` creates a *specification* of a recipe step that selects
4 | #' a subset of predictors using the Boruta feature selection approach.
5 | #'
6 | #' The Boruta algorithm technically is a wrapper approach that uses random
7 | #' forests to test whether the feature importance scores obtained on the
8 | #' original data are higher than best of the scores obtained when the variables
9 | #' are randomly permuted. These permuted features are termed 'shadow' features.
10 | #' If the scores for any original feature are higher than the best of the scores
11 | #' for the randomly permuted features, then this is marked as a 'hit'. Features
12 | #' are confirmed or rejected based on a confidence threshold (default is p =
13 | #' 0.01) applied to the tails of the binomial distribution with p = 0.5.
14 | #' Features that do not fall within the lower (reject) or upper (accept) tails
15 | #' of the distribution are labelled as 'tentative'. Rejected features are
16 | #' dropped from the feature set and the procedure is repeated until no more
17 | #' 'tentative' features exist, or that a maximum number of runs are reached.
18 | #'
19 | #' @inheritParams step_select_aov
20 | #' @inherit step_select_aov return
21 | #' @param outcome A character string with the name of the response variable to
22 | #' use to calculate the feature importance scores.
23 | #' @param role Not used by this step since no new variables are created.
24 | #' @param options A list of options to pass to `Boruta::Boruta()`. The defaults
25 | #' use Boruta's defaults. *Note* that `x` and `y` should not be passed here.
26 | #' @param res The `Boruta::Boruta` object is stored here once this preprocessing
27 | #' step has been trained by `prep.recipe()`.
28 | #'
29 | #' @export
30 | #' @examples
31 | #' library(recipes)
32 | #' library(parsnip)
33 | #'
34 | #' # load the example iris dataset
35 | #' data(cells, package = "modeldata")
36 | #'
37 | #' # create a preprocessing recipe
38 | #' rec <-
39 | #' recipe(class ~ ., data = cells[, -1]) %>%
40 | #' step_select_boruta(all_predictors(), outcome = "class")
41 | #'
42 | #' prepped <- prep(rec)
43 | #'
44 | #' preproc_data <- juice(prepped)
45 | #' prepped
46 | step_select_boruta <- function(
47 | recipe,
48 | ...,
49 | outcome = NULL,
50 | role = "predictor",
51 | trained = FALSE,
52 | exclude = NULL,
53 | options = list(pValue = 0.01, mcAdj = TRUE, maxRuns = 100),
54 | res = NULL,
55 | skip = FALSE,
56 | id = recipes::rand_id("select_boruta")) {
57 |
58 | recipes::recipes_pkg_check("Boruta")
59 |
60 | recipes::add_step(
61 | recipe,
62 | step_select_boruta_new(
63 | terms = recipes::ellipse_check(...),
64 | trained = trained,
65 | outcome = outcome,
66 | role = role,
67 | exclude = exclude,
68 | options = options,
69 | res = res,
70 | skip = skip,
71 | id = id
72 | )
73 | )
74 | }
75 |
76 | # wrapper around 'step' function that sets the class of new step objects
77 | #' @importFrom recipes step
78 | step_select_boruta_new <- function(terms, role, trained, outcome, exclude,
79 | options, res, skip, id) {
80 | recipes::step(
81 | subclass = "select_boruta",
82 | terms = terms,
83 | role = role,
84 | trained = trained,
85 | outcome = outcome,
86 | exclude = exclude,
87 | options = options,
88 | res = res,
89 | skip = skip,
90 | id = id
91 | )
92 | }
93 |
94 | #' @export
95 | prep.step_select_boruta <- function(x, training, info = NULL, ...) {
96 |
97 | # translate the terms arguments
98 | x_names <- recipes::recipes_eval_select(x$terms, training, info)
99 | y_name <- recipes::recipes_eval_select(x$outcome, training, info)
100 | y_name <- y_name[1]
101 |
102 | if (length(x_names) > 0) {
103 |
104 | call <- rlang::call2(
105 | .fn = "Boruta",
106 | .ns = "Boruta",
107 | x = rlang::quo(training[, x_names]),
108 | y = rlang::quo(training[[y_name]]),
109 | !!!x$options
110 | )
111 |
112 | res <- rlang::eval_tidy(call)
113 |
114 | exclude <- names(res$finalDecision[res$finalDecision == "Rejected"])
115 |
116 | } else {
117 | exclude <- character()
118 | }
119 |
120 | step_select_boruta_new(
121 | terms = x$terms,
122 | trained = TRUE,
123 | role = x$role,
124 | outcome = y_name,
125 | exclude = exclude,
126 | options = x$options,
127 | res = res,
128 | skip = x$skip,
129 | id = x$id
130 | )
131 | }
132 |
133 | #' @export
134 | bake.step_select_boruta <- function(object, new_data, ...) {
135 | if (length(object$exclude) > 0) {
136 | new_data <- new_data[, !colnames(new_data) %in% object$exclude]
137 | }
138 | as_tibble(new_data)
139 | }
140 |
141 | #' @export
142 | print.step_select_boruta <-
143 | function(x, width = max(20, options()$width - 30), ...) {
144 | cat("Boruta feature selection")
145 |
146 | if (recipes::is_trained(x)) {
147 | n <- length(x$exclude)
148 | cat(paste0(" (", n, " excluded)"))
149 | }
150 | cat("\n")
151 |
152 | invisible(x)
153 | }
154 |
155 | #' @rdname step_select_boruta
156 | #' @param x A `step_select_boruta` object.
157 | #' @param type A character with either 'terms' (the default) to return a
158 | #' tibble containing the variables that have been removed by the filter step,
159 | #' or 'scores' to return the scores for each variable.
160 | #' @export
161 | tidy.step_select_boruta <- function(x, type = "terms", ...) {
162 | tidy_filter_step(x, type)
163 | }
164 |
165 | #' @rdname required_pkgs.colino
166 | #' @export
167 | required_pkgs.step_select_boruta <- function(x, ...) {
168 | c("colino", "Boruta")
169 | }
170 |
--------------------------------------------------------------------------------
/docs/reference/pipe.html:
--------------------------------------------------------------------------------
1 |
2 |
58 |
67 |
68 |
69 |
80 |
59 | 
62 |
63 | Content not found. Please use links in the navbar.
64 |
65 | Page not found (404)
60 | 61 |
38 |
67 |
68 |
69 |
70 |
71 |
72 |
73 |
74 |
--------------------------------------------------------------------------------
/R/step_select_roc.R:
--------------------------------------------------------------------------------
1 | #' Filter Numeric Predictors using ROC Curve
2 | #'
3 | #' `step_select_roc` creates a *specification* of a recipe step that will
4 | #' filter predictors using their relationship with the outcome as measured
5 | #' using a Receiver Operating Characteristic curve.
6 | #'
7 | #' @inheritParams step_select_aov
8 | #' @inherit step_select_aov return
9 | #' @param outcome A single character string that specifies a single categorical
10 | #' variable to be used as the class.
11 | #' @param role For model terms created by this step, what analysis role should
12 | #' they be assigned?. By default, the function assumes that resulting distances
13 | #' will be used as predictors in a model.
14 | #'
15 | #' @keywords datagen
16 | #' @concept preprocessing
17 | #' @concept supervised_filter
18 | #' @export
19 | #' @details
20 | #'
21 | #' The recipe will stop if all of `top_p`, `threshold` and `cutoff` are left
22 | #' unspecified.
23 | #'
24 | #' The ROC AUC will be set to be 1 - AUC if the value is less than 0.50.
25 | #'
26 | #' @examples
27 | #' data(cells, package = "modeldata")
28 | #'
29 | #' rec <-
30 | #' recipe(class ~ ., data = cells[, -1]) %>%
31 | #' step_select_roc(all_predictors(), outcome = "class", top_p = 10, cutoff = 0.9) %>%
32 | #' prep()
33 | #'
34 | #' rec %>% bake(all_predictors(), new_data = NULL) %>% names()
35 | #'
36 | #' # Use ROC values to select but always keep at least one:
37 | #' rec <-
38 | #' recipe(class ~ ., data = cells[, -1]) %>%
39 | #' step_select_roc(
40 | #' all_predictors(),
41 | #' outcome = "class",
42 | #' top_p = 1,
43 | #' cutoff = 0.99
44 | #' ) %>%
45 | #' prep()
46 | #'
47 | #' rec %>% juice(all_predictors()) %>% names()
48 | step_select_roc <-
49 | function(recipe, ..., outcome, role = "predictor", trained = FALSE,
50 | threshold = NA, top_p = NA, cutoff = NA, exclude = NULL,
51 | skip = FALSE, id = recipes::rand_id("select_roc")) {
52 | recipes::add_step(
53 | recipe,
54 | step_select_roc_new(
55 | terms = recipes::ellipse_check(...),
56 | outcome = outcome,
57 | role = role,
58 | trained = trained,
59 | top_p = top_p,
60 | threshold = threshold,
61 | cutoff = cutoff,
62 | exclude = exclude,
63 | skip = skip,
64 | id = id
65 | )
66 | )
67 | }
68 |
69 | step_select_roc_new <-
70 | function(terms, outcome, role, trained, top_p, threshold, cutoff, exclude,
71 | skip, id) {
72 | recipes::step(
73 | subclass = "select_roc",
74 | terms = terms,
75 | outcome = outcome,
76 | role = role,
77 | trained = trained,
78 | top_p = top_p,
79 | threshold = threshold,
80 | cutoff = cutoff,
81 | exclude = exclude,
82 | skip = skip,
83 | id = id
84 | )
85 | }
86 |
87 | roc_calc <- function(x, y) {
88 | suppressMessages(
89 | suppressWarnings(
90 | {
91 | if (length(levels(y)) == 2) {
92 | res <- try(pROC::roc(y, x, direction = "auto"),
93 | silent = TRUE)
94 | } else {
95 | res <- try(pROC::multiclass.roc(y, x, direction = "auto"),
96 | silent = TRUE)
97 | }
98 | }
99 | )
100 | )
101 |
102 | if (inherits(res, "try-error")) {
103 | res <- NA_real_
104 | } else {
105 | res <- unname(pROC::auc(res))
106 | }
107 | res
108 | }
109 |
110 | #' @export
111 | prep.step_select_roc <- function(x, training, info = NULL, ...) {
112 | y_name <- recipes::recipes_eval_select(x$outcome, training, info)
113 | y_name <- x$outcome[1]
114 | recipes::check_type(training[, y_name], quant = FALSE)
115 | x_names <- recipes::recipes_eval_select(x$terms, training, info)
116 |
117 | if (length(x_names) > 0) {
118 |
119 | recipes::check_type(training[, x_names])
120 |
121 | # check criteria
122 | check_criteria(x$top_p, x$threshold, match.call())
123 | check_zero_one(x$threshold)
124 | x$top_p <- check_top_p(x$top_p, length(x_names))
125 |
126 | # filter
127 | scores <- purrr::map_dbl(training[, x_names], ~ roc_calc(.x, training[[y_name]]))
128 | exclude_chr <- dual_filter(scores, x$top_p, x$threshold, x$cutoff,
129 | maximize = TRUE)
130 | } else {
131 | exclude_chr <- character()
132 | }
133 |
134 | step_select_roc_new(
135 | terms = x$terms,
136 | outcome = x$outcome,
137 | role = x$role,
138 | trained = TRUE,
139 | top_p = x$top_p,
140 | threshold = x$threshold,
141 | cutoff = x$cutoff,
142 | exclude = exclude_chr,
143 | skip = x$skip,
144 | id = x$id
145 | )
146 | }
147 |
148 | #' @export
149 | bake.step_select_roc <- function(object, new_data, ...) {
150 | if (length(object$exclude) > 0) {
151 | new_data <- new_data %>%
152 | dplyr::select(-dplyr::one_of(object$exclude))
153 | }
154 | new_data
155 | }
156 |
157 | #' @export
158 | print.step_select_roc <-
159 | function(x, width = max(20, options()$width - 30), ...) {
160 | cat("ROC curve feature selection")
161 |
162 | if (recipes::is_trained(x)) {
163 | n <- length(x$exclude)
164 | cat(paste0(" (", n, " excluded)"))
165 | }
166 | cat("\n")
167 |
168 | invisible(x)
169 | }
170 |
171 | #' @rdname step_select_roc
172 | #' @param x A `step_select_roc` object.
173 | #' @export
174 | tidy.step_select_roc <- function(x, ...) {
175 | tidy_filter_step(x, type = "terms")
176 | }
177 |
178 | #' @export
179 | tunable.step_select_roc <- function(x, ...) {
180 | tibble::tibble(
181 | name = c("top_p", "threshold", "cutoff"),
182 | call_info = list(
183 | list(pkg = "colino", fun = "top_p"),
184 | list(pkg = "dials", fun = "threshold", range = c(0, 1)),
185 | list(pkg = "colino", fun = "cutoff")
186 | ),
187 | source = "recipe",
188 | component = "step_select_roc",
189 | component_id = x$id
190 | )
191 | }
192 |
193 | #' @rdname required_pkgs.colino
194 | #' @export
195 | required_pkgs.step_select_roc <- function(x, ...) {
196 | c("colino", "pROC")
197 | }
198 |
--------------------------------------------------------------------------------
/R/step_select_mrmr.R:
--------------------------------------------------------------------------------
1 | #' Apply minimum Redundancy Maximum Relevance Feature Selection (mRMR)
2 | #'
3 | #' `step_select_mrmr` creates a *specification* of a recipe step that will apply
4 | #' minimum Redundancy Maximum Relevance Feature Selection (mRMR) to numeric
5 | #' data. The top `top_p` scoring features, or features whose scores occur in the
6 | #' top percentile `threshold` will be retained as new predictors.
7 | #'
8 | #' @inheritParams step_select_aov
9 | #' @inherit step_select_aov return
10 | #' @param role Not used by this step since no new variables are created
11 | #' @param outcome A character string specifying the name of response variable
12 | #' used to evaluate mRMR.
13 | #' @param threads An integer specifying the number of threads to use for
14 | #' processing. The default = 0 uses all available threads.
15 | #' @param scores A tibble with 'variable' and 'scores' columns containing the
16 | #' names of the variables and their mRMR scores. This parameter is only
17 | #' produced after the recipe has been trained.
18 | #'
19 | #' @keywords datagen
20 | #' @concept preprocessing
21 | #' @concept supervised_filter
22 | #' @export
23 | #' @details
24 | #'
25 | #' The recipe will stop if all of `top_p`, `threshold` and `cutoff` are left
26 | #' unspecified.
27 | #'
28 | #' @examples
29 | #' library(recipes)
30 | #'
31 | #' data(cells, package = "modeldata")
32 | #'
33 | #' rec <-
34 | #' recipe(class ~ ., data = cells[, -1]) %>%
35 | #' step_select_mrmr(
36 | #' all_predictors(),
37 | #' outcome = "class",
38 | #' top_p = 10
39 | #' )
40 | #'
41 | #' prepped <- prep(rec)
42 | #'
43 | #' new_data <- bake(prepped, new_data = NULL)
44 | #' prepped
45 | step_select_mrmr <- function(
46 | recipe, ...,
47 | outcome = NULL,
48 | role = NA,
49 | trained = FALSE,
50 | top_p = NA,
51 | threshold = NA,
52 | cutoff = NA,
53 | threads = 0,
54 | exclude = NULL,
55 | scores = NULL,
56 | skip = FALSE,
57 | id = recipes::rand_id("select_mrmr")) {
58 |
59 | recipes::recipes_pkg_check("praznik")
60 |
61 | terms <- recipes::ellipse_check(...)
62 |
63 | recipes::add_step(
64 | recipe,
65 | step_select_mrmr_new(
66 | terms = terms,
67 | trained = trained,
68 | outcome = outcome,
69 | role = role,
70 | top_p = top_p,
71 | threshold = threshold,
72 | cutoff = cutoff,
73 | threads = threads,
74 | exclude = exclude,
75 | scores = scores,
76 | skip = skip,
77 | id = id
78 | )
79 | )
80 | }
81 |
82 | step_select_mrmr_new <-
83 | function(terms, role, trained, outcome, top_p, threshold, cutoff, threads,
84 | exclude, scores, skip, id) {
85 | recipes::step(
86 | subclass = "select_mrmr",
87 | terms = terms,
88 | role = role,
89 | trained = trained,
90 | outcome = outcome,
91 | top_p = top_p,
92 | threshold = threshold,
93 | cutoff = cutoff,
94 | threads = threads,
95 | exclude = exclude,
96 | scores = scores,
97 | skip = skip,
98 | id = id
99 | )
100 | }
101 |
102 | #' @export
103 | prep.step_select_mrmr <- function(x, training, info = NULL, ...) {
104 | # extract response and predictor names
105 | y_name <- recipes::recipes_eval_select(x$outcome, training, info)
106 | y_name <- y_name[1]
107 | x_names <- recipes::recipes_eval_select(x$terms, training, info)
108 |
109 | # check criteria
110 | check_criteria(x$top_p, x$threshold, match.call())
111 | check_zero_one(x$threshold)
112 | x$top_p <- check_top_p(x$top_p, length(x_names))
113 |
114 | if (length(x_names) > 0) {
115 |
116 | call <- rlang::call2(
117 | .fn = "MRMR",
118 | .ns = "praznik",
119 | X = rlang::quo(training[, x_names]),
120 | Y = rlang::quo(training[[y_name]]),
121 | k = length(x_names),
122 | threads = x$threads
123 | )
124 |
125 | res <- rlang::eval_tidy(call)
126 |
127 | res <- tibble(
128 | variable = names(res$selection),
129 | score = res$score
130 | )
131 |
132 | exclude <-
133 | dual_filter(res$score, x$top_p, x$threshold, x$cutoff, maximize = TRUE)
134 |
135 | } else {
136 | exclude <- character()
137 | }
138 |
139 | step_select_mrmr_new(
140 | terms = x$terms,
141 | trained = TRUE,
142 | role = x$role,
143 | outcome = y_name,
144 | top_p = x$top_p,
145 | threshold = x$threshold,
146 | cutoff = x$cutoff,
147 | threads = x$threads,
148 | exclude = exclude,
149 | scores = res,
150 | skip = x$skip,
151 | id = x$id
152 | )
153 | }
154 |
155 | #' @export
156 | bake.step_select_mrmr <- function(object, new_data, ...) {
157 | if (length(object$exclude) > 0) {
158 | new_data <- new_data[, !(colnames(new_data) %in% object$exclude)]
159 | }
160 | as_tibble(new_data)
161 | }
162 |
163 | #' @export
164 | print.step_select_mrmr <-
165 | function(x, width = max(20, options()$width - 30), ...) {
166 | cat("mRMR feature selection")
167 |
168 | if (recipes::is_trained(x)) {
169 | n <- length(x$exclude)
170 | cat(paste0(" (", n, " excluded)"))
171 | }
172 | cat("\n")
173 |
174 | invisible(x)
175 | }
176 |
177 | #' @rdname step_select_mrmr
178 | #' @param x A `step_select_mrmr` object.
179 | #' @param type A character with either 'terms' (the default) to return a
180 | #' tibble containing the variables that have been removed by the filter step,
181 | #' or 'scores' to return the scores for each variable.
182 | #' @export
183 | tidy.step_select_mrmr <- function(x, type = "terms", ...) {
184 | tidy_filter_step(x, type)
185 | }
186 |
187 | #' @export
188 | tunable.step_select_mrmr <- function(x, ...) {
189 | tibble(
190 | name = c("top_p", "threshold", "cutoff"),
191 | call_info = list(
192 | list(pkg = "colino", fun = "top_p"),
193 | list(pkg = "dials", fun = "threshold", range = c(0, 1)),
194 | list(pkg = "colino", fun = "cutoff")
195 | ),
196 | source = "recipe",
197 | component = "step_select_mrmr",
198 | component_id = x$id
199 | )
200 | }
201 |
202 | #' @rdname required_pkgs.colino
203 | #' @export
204 | required_pkgs.step_select_mrmr <- function(x, ...) {
205 | c("colino", "praznik")
206 | }
207 |
--------------------------------------------------------------------------------
/tests/testthat/test_step_select_fcbf.R:
--------------------------------------------------------------------------------
1 | library(recipes)
2 |
3 | data(iris)
4 |
5 | test_that("basic usage: expected columns retrieved", {
6 | skip_if_not_installed("FCBF")
7 |
8 | my_iris <- iris
9 | my_iris[['lglfeat']] <- c(TRUE, TRUE, FALSE, FALSE, TRUE, FALSE)
10 | my_iris[['partial_NAfeat']] <- c(2, 3, 6, 4, 3, NA)
11 |
12 | rec <-
13 | recipe(Species ~ ., data = my_iris) %>%
14 | step_select_fcbf(all_predictors(), threshold = 0.001)
15 |
16 | rec_p <- prep(rec, training = my_iris)
17 |
18 | iris_bake <- bake(rec_p, new_data = my_iris)
19 |
20 | expect_equal(names(iris_bake),
21 | c("Sepal.Width", "Petal.Width", "Species"))
22 | })
23 |
24 | test_that("warns/breaks if not enough predictors are provided", {
25 | skip_if_not_installed("FCBF")
26 |
27 | # warn if one usable predictor is provided to fcbf
28 | rec1 <-
29 | recipe(Species ~ Sepal.Length, iris) %>%
30 | step_select_fcbf(all_predictors())
31 |
32 | expect_warning(prep(rec1, training = iris), "Only one usable")
33 |
34 | # stop if no usable predictors are provided to fcbf
35 | rec2 <-
36 | recipe(Species ~ ., iris[, 'Species', drop = FALSE]) %>%
37 | step_select_fcbf(all_predictors())
38 |
39 | expect_error(prep(rec2, training = iris), "No usable predictors")
40 | })
41 |
42 | test_that("step_select_fcbf rejects bad threshold or cutpoint argument input", {
43 | skip_if_not_installed("FCBF")
44 |
45 | rec <- recipe(Species ~ ., data = iris)
46 |
47 | expect_error(
48 | rec %>%
49 | step_select_fcbf(threshold = 1.5) %>%
50 | prep(),
51 | "(0, 1)"
52 | )
53 |
54 | expect_error(
55 | rec %>%
56 | step_select_fcbf(threshold = NA) %>%
57 | prep(),
58 | "No usable"
59 | )
60 |
61 | expect_error(
62 | rec %>%
63 | step_select_fcbf(threshold = 0) %>%
64 | prep(),
65 | "(0, 1)"
66 | )
67 |
68 | expect_error(
69 | rec %>%
70 | step_select_fcbf(threshold = "median") %>%
71 | prep(),
72 | "should be numeric"
73 | )
74 |
75 | expect_error(
76 | rec %>%
77 | step_select_fcbf(threshold = TRUE) %>%
78 | prep(),
79 | "should be numeric"
80 | )
81 |
82 | expect_error(
83 | rec %>%
84 | step_select_fcbf(threshold = -0.01) %>%
85 | prep(),
86 | "(0, 1)"
87 | )
88 |
89 | error_cut <- "`cutpoint` must be a number between 0-1"
90 | expect_error(rec %>% step_select_fcbf(cutpoint = 1.5), error_cut)
91 | expect_error(rec %>% step_select_fcbf(cutpoint = NA), error_cut)
92 | expect_error(rec %>% step_select_fcbf(cutpoint = 0), error_cut)
93 | expect_error(rec %>% step_select_fcbf(cutpoint = "median"), error_cut)
94 | expect_error(rec %>% step_select_fcbf(cutpoint = TRUE), error_cut)
95 | expect_error(rec %>% step_select_fcbf(cutpoint = -0.01), error_cut)
96 | })
97 |
98 | # return warning if NA columns are provided
99 | test_that("NA columns get removed with warning", {
100 | skip_if_not_installed("FCBF")
101 |
102 | na_vec <- rep(NA, 10)
103 | na_dat <- tibble(
104 | out = rep(c("A", "B"), 5),
105 | f1 = as.character(na_vec),
106 | f2 = as.numeric(na_vec),
107 | f3 = na_vec,
108 | f4 = c(1, 4, 32, 6, 4, 23, 44, 54, 23, 6),
109 | f5 = c(1:10)
110 | )
111 |
112 | inpt_cols <- c('f1', 'f2', 'f3', 'f4', 'f5')
113 |
114 | rec <-
115 | recipe(out ~ f1 + f2 + f3 + f4 + f5, data = na_dat) %>%
116 | step_select_fcbf(all_predictors())
117 |
118 | expect_warning(remove_NA_cols(inpt_cols, na_dat), "3 features were full")
119 | expect_warning(prep(rec, na_dat), "3 features were full")
120 | })
121 |
122 |
123 | # return error if outcome is not provided, or not in expected format
124 | test_that("bad outcome variables handled correctly", {
125 | skip_if_not_installed("FCBF")
126 |
127 | # no outcome variable specified in recipe
128 | rec <-
129 | recipe(iris) %>%
130 | update_role(Sepal.Length, Sepal.Width, Petal.Length, new_role = 'predictor') %>%
131 | step_select_fcbf(all_predictors())
132 |
133 | expect_error(prep(rec, iris), "outcome variable was not found")
134 |
135 | # code works if outcome = argument supplied, despite no outcome in the recipe
136 | rec2 <-
137 | recipe(iris) %>%
138 | update_role(Sepal.Length, Sepal.Width, Petal.Length, new_role = 'predictor') %>%
139 | step_select_fcbf(all_predictors(), outcome = "Species")
140 |
141 | expect_equal(
142 | prep(rec2, iris) %>% bake(iris) %>% names,
143 | c("Sepal.Width", "Petal.Length", "Petal.Width", "Species")
144 | )
145 |
146 | # outcome supplied in unexpected format
147 | rec3 <-
148 | recipe(iris) %>%
149 | update_role(Sepal.Length, Sepal.Width, Petal.Length, new_role = 'predictor') %>%
150 | step_select_fcbf(all_predictors(), outcome = 5)
151 |
152 | expect_error(prep(rec3, iris), "supplied as a character")
153 |
154 | rec4 <-
155 | recipe(iris) %>%
156 | update_role(Sepal.Length, Sepal.Width, Petal.Length, new_role = 'predictor') %>%
157 | step_select_fcbf(all_predictors(), outcome = c("Species", "Petal.Length"))
158 |
159 | expect_error(prep(rec4, iris), "single outcome variable can be")
160 |
161 | rec5 <-
162 | recipe(iris) %>%
163 | update_role(Sepal.Length, Sepal.Width, Petal.Length, new_role = 'predictor') %>%
164 | step_select_fcbf(all_predictors(), outcome = TRUE)
165 |
166 | expect_error(prep(rec5, iris), "supplied as a character")
167 |
168 | rec6 <-
169 | recipe(iris) %>%
170 | update_role(Sepal.Length, Sepal.Width, Petal.Length, new_role = 'predictor') %>%
171 | step_select_fcbf(all_predictors(), outcome = 'doesnt_exist')
172 |
173 | expect_error(prep(rec6, iris), "not found")
174 |
175 | rec7 <-
176 | recipe(iris) %>%
177 | update_role(Sepal.Length, Sepal.Width, Petal.Length, new_role = 'predictor') %>%
178 | step_select_fcbf(all_predictors(), outcome = NA)
179 |
180 | expect_error(prep(rec7, iris), "outcome variable was not found")
181 | })
182 |
183 | # Test if user provides columns by name rather than using tidyselect helpers
184 | test_that("function works if user provides columns by name", {
185 | skip_if_not_installed("FCBF")
186 |
187 | rec <-
188 | recipe(Species ~ . , iris) %>%
189 | step_select_fcbf(c("Petal.Length", "Sepal.Length"))
190 |
191 | expect_equal(
192 | prep(rec, iris) %>% bake(iris) %>% names,
193 | c("Sepal.Width", "Petal.Length", "Petal.Width", "Species")
194 | )
195 | })
196 |
--------------------------------------------------------------------------------
/docs/LICENSE.html:
--------------------------------------------------------------------------------
1 |
2 |
39 |
44 |
45 |
56 |
57 |
58 |
46 |
48 |
49 |
53 |
54 |
55 | See magrittr::%>% for details.
38 |
64 |
65 |
66 |
67 |
68 |
69 |
70 |
71 |
--------------------------------------------------------------------------------
/R/step_select_vip.R:
--------------------------------------------------------------------------------
1 | #' Feature selection step using a model's feature importance scores or
2 | #' coefficients
3 | #'
4 | #' `step_select_vip` creates a *specification* of a recipe step that selects a
5 | #' subset of predictors based on the ranking of variable importance provided by
6 | #' a `parsnip` model specification and the `model` parameter
7 | #'
8 | #' @inheritParams step_select_aov
9 | #' @inherit step_select_aov return
10 | #' @param outcome A character string with the name of the response variable to
11 | #' use to calculate the feature importance scores.
12 | #' @param role Not used by this step since no new variables are created.
13 | #' @param model A `model_spec` object from `parsnip` that has a feature
14 | #' importances or coefficients method. The model needs to have an equivalent
15 | #' `pull_importances` method defined. See `?pull_importances` for how to
16 | #' define methods for models that are not currently supported.
17 | #' @param scores A tibble with 'variable' and 'scores' columns containing the
18 | #' names of the variables and their feature importance scores. This parameter
19 | #' is only produced after the recipe has been trained.
20 | #'
21 | #' @export
22 | #'
23 | #' @details
24 | #' The recipe will stop if all of `top_p`, `threshold` and `cutoff` are left
25 | #' unspecified.
26 | #'
27 | #' @examples
28 | #' library(recipes)
29 | #' library(parsnip)
30 | #'
31 | #' # load the example cells dataset
32 | #' data(cells, package = "modeldata")
33 | #'
34 | #' # define a base model to use for feature importances
35 | #' base_model <- rand_forest(mode = "classification") %>%
36 | #' set_engine("ranger", importance = "permutation")
37 | #'
38 | #' # create a preprocessing recipe
39 | #' rec <-
40 | #' recipe(class ~ ., data = cells[, -1]) %>%
41 | #' step_select_vip(
42 | #' all_predictors(),
43 | #' outcome = "class",
44 | #' model = base_model,
45 | #' top_p = 10
46 | #' )
47 | #'
48 | #' prepped <- prep(rec)
49 | #'
50 | #' preproc_data <- juice(prepped)
51 | #' prepped
52 | step_select_vip <- function(
53 | recipe,
54 | ...,
55 | outcome = NULL,
56 | role = "predictor",
57 | trained = FALSE,
58 | model = NULL,
59 | top_p = NA,
60 | threshold = NA,
61 | cutoff = NA,
62 | exclude = NULL,
63 | scores = NULL,
64 | skip = FALSE,
65 | id = recipes::rand_id("select_vip")) {
66 |
67 | if (missing(model))
68 | rlang::abort("Model argument should be a `parsnip` model specification")
69 |
70 | recipes::add_step(
71 | recipe,
72 | step_select_vip_new(
73 | terms = recipes::ellipse_check(...),
74 | trained = trained,
75 | outcome = outcome,
76 | role = role,
77 | model = model,
78 | top_p = top_p,
79 | threshold = threshold,
80 | cutoff = cutoff,
81 | exclude = exclude,
82 | scores = scores,
83 | skip = skip,
84 | id = id
85 | )
86 | )
87 | }
88 |
89 | # wrapper around 'step' function that sets the class of new step objects
90 | #' @importFrom recipes step
91 | step_select_vip_new <- function(terms, role, trained, outcome, model, top_p,
92 | threshold, cutoff, exclude, scores, skip, id) {
93 | recipes::step(
94 | subclass = "select_vip",
95 | terms = terms,
96 | role = role,
97 | trained = trained,
98 | outcome = outcome,
99 | model = model,
100 | top_p = top_p,
101 | threshold = threshold,
102 | cutoff = cutoff,
103 | exclude = exclude,
104 | scores = scores,
105 | skip = skip,
106 | id = id
107 | )
108 | }
109 |
110 | #' @export
111 | prep.step_select_vip <- function(x, training, info = NULL, ...) {
112 |
113 | # translate the terms arguments
114 | x_names <- recipes::recipes_eval_select(x$terms, training, info)
115 | y_name <- recipes::recipes_eval_select(x$outcome, training, info)
116 | y_name <- y_name[1]
117 |
118 | # check criteria
119 | check_criteria(x$top_p, x$threshold, match.call())
120 | check_zero_one(x$threshold)
121 | x$top_p <- check_top_p(x$top_p, length(x_names))
122 |
123 | if (length(x_names) > 0) {
124 | # fit initial model
125 | X <- training[, x_names]
126 | y <- training[[y_name]]
127 |
128 | initial_model <- parsnip::fit_xy(x$model, X, y)
129 | res <- pull_importances(initial_model)
130 | names(res) <- c("variable", "score")
131 | res$score <- rlang::set_names(res$score, res$variable)
132 |
133 | exclude <-
134 | dual_filter(res$score, x$top_p, x$threshold, x$cutoff, maximize = TRUE)
135 |
136 | } else {
137 | exclude <- character()
138 | }
139 |
140 | step_select_vip_new(
141 | terms = x$terms,
142 | trained = TRUE,
143 | role = x$role,
144 | outcome = y_name,
145 | model = x$model,
146 | top_p = x$top_p,
147 | threshold = x$threshold,
148 | cutoff = x$cutoff,
149 | exclude = exclude,
150 | scores = res,
151 | skip = x$skip,
152 | id = x$id
153 | )
154 | }
155 |
156 | #' @export
157 | bake.step_select_vip <- function(object, new_data, ...) {
158 | if (length(object$exclude) > 0) {
159 | new_data <- new_data[, !colnames(new_data) %in% object$exclude]
160 | }
161 | as_tibble(new_data)
162 | }
163 |
164 | #' @export
165 | print.step_select_vip <-
166 | function(x, width = max(20, options()$width - 30), ...) {
167 | cat("Variable importance feature selection")
168 |
169 | if (recipes::is_trained(x)) {
170 | n <- length(x$exclude)
171 | cat(paste0(" (", n, " excluded)"))
172 | }
173 | cat("\n")
174 |
175 | invisible(x)
176 | }
177 |
178 | #' @rdname step_select_vip
179 | #' @param x A `step_select_vip` object
180 | #' @param type A character with either 'terms' (the default) to return a
181 | #' tibble containing the variables that have been removed by the filter step,
182 | #' or 'scores' to return the scores for each variable.
183 | #' @export
184 | tidy.step_select_vip <- function(x, type = "terms", ...) {
185 | tidy_filter_step(x, type)
186 | }
187 |
188 | #' @export
189 | tunable.step_select_vip <- function(x, ...) {
190 | tibble(
191 | name = c("top_p", "threshold", "cutoff"),
192 | call_info = list(
193 | list(pkg = "colino", fun = "top_p"),
194 | list(pkg = "dials", fun = "threshold", range = c(0, 1)),
195 | list(pkg = "colino", fun = "cutoff")
196 | ),
197 | source = "recipe",
198 | component = "step_select_vip",
199 | component_id = x$id
200 | )
201 | }
202 |
203 | #' @rdname required_pkgs.colino
204 | #' @export
205 | required_pkgs.step_select_vip <- function(x, ...) {
206 | c("colino")
207 | }
208 |
--------------------------------------------------------------------------------
/R/step_select_xtab.R:
--------------------------------------------------------------------------------
1 | #' Filter Categorical Predictors using Contingency Tables
2 | #'
3 | #' `step_select_xtab` creates a *specification* of a recipe step that will
4 | #' filter predictors using their relationship with the outcome as measured
5 | #' using statistical tests for association.
6 | #'
7 | #' @inheritParams step_select_aov
8 | #' @inherit step_select_aov return
9 | #' @param outcome A single character string that specifies a single categorical
10 | #' variable to be used as the class.
11 | #' @param role For model terms created by this step, what analysis role should
12 | #' they be assigned?. By default, the function assumes that resulting distances
13 | #' will be used as predictors in a model.
14 | #' @param exact Should an exact test be used?
15 | #' @param fdr Should false discovery rates (FDR) be used instead of p-values?
16 | #'
17 | #' @keywords datagen
18 | #' @concept preprocessing
19 | #' @concept supervised_filter
20 | #' @export
21 | #' @details
22 | #'
23 | #' The recipe will stop if all of `top_p`, `threshold` and `cutoff` are left
24 | #' unspecified. If both are used, they are combined via 'or'.
25 | #'
26 | #' The Benjamini-Hochberg FDR correction is used (see [stats::p.adjust()]).
27 | #'
28 | #' Warnings from [stats::chisq.test()] and [stats::fisher.test()] are suppressed.
29 | #' @examples
30 | #' data(attrition, package = "modeldata")
31 | #'
32 | #' rec <-
33 | #' recipe(Attrition ~ ., data = attrition) %>%
34 | #' step_select_xtab(all_nominal(), -all_outcomes(), outcome = "Attrition",
35 | #' top_p = 1, cutoff = 0.001, exact = TRUE) %>%
36 | #' prep()
37 | #'
38 | #' rec %>% juice(all_nominal(), -all_outcomes()) %>% names()
39 | #'
40 | #' tidy(rec, number = 1)
41 | step_select_xtab <- function(recipe,
42 | ...,
43 | outcome,
44 | role = "predictor",
45 | trained = FALSE,
46 | top_p = NA,
47 | threshold = NA,
48 | cutoff = NA,
49 | exact = FALSE,
50 | fdr = TRUE,
51 | exclude = NULL,
52 | skip = FALSE,
53 | id = recipes::rand_id("select_xtab")) {
54 | recipes::add_step(
55 | recipe,
56 | step_select_xtab_new(
57 | terms = recipes::ellipse_check(...),
58 | outcome = outcome,
59 | role = role,
60 | trained = trained,
61 | top_p = top_p,
62 | threshold = threshold,
63 | cutoff = cutoff,
64 | exact = exact,
65 | fdr = fdr,
66 | exclude = exclude,
67 | skip = skip,
68 | id = id
69 | )
70 | )
71 | }
72 |
73 | step_select_xtab_new <-
74 | function(terms, outcome, role, trained, top_p, threshold, cutoff, exact, fdr,
75 | exclude, skip, id) {
76 | recipes::step(
77 | subclass = "select_xtab",
78 | terms = terms,
79 | outcome = outcome,
80 | role = role,
81 | trained = trained,
82 | top_p = top_p,
83 | threshold = threshold,
84 | cutoff = cutoff,
85 | exact = exact,
86 | fdr = fdr,
87 | exclude = exclude,
88 | skip = skip,
89 | id = id
90 | )
91 | }
92 |
93 | tbl_calc <- function(x, y, exact) {
94 | xtab <- table(x, y)
95 | if (exact) {
96 | res <- suppressWarnings(try(stats::fisher.test(xtab)$p.value, silent = TRUE))
97 | } else {
98 | res <- suppressWarnings(try(stats::chisq.test(xtab)$p.value, silent = TRUE))
99 | }
100 | if (inherits(res, "try-error")) {
101 | res <- NA_real_
102 | }
103 | res
104 | }
105 |
106 | #' @export
107 | prep.step_select_xtab <- function(x, training, info = NULL, ...) {
108 | y_name <- recipes::recipes_eval_select(x$outcome, training, info)
109 | y_name <- x$outcome[1]
110 | recipes::check_type(training[, y_name], quant = FALSE)
111 | x_names <- recipes::recipes_eval_select(x$terms, training, info)
112 |
113 | if (length(x_names) > 0) {
114 |
115 | recipes::check_type(training[, x_names], quant = FALSE)
116 |
117 | # check criteria
118 | check_criteria(x$top_p, x$threshold, match.call())
119 | check_zero_one(x$threshold)
120 | x$top_p <- check_top_p(x$top_p, length(x_names))
121 |
122 | # filter
123 | scores <- purrr::map_dbl(training[, x_names],
124 | ~ tbl_calc(.x, training[[y_name]], exact = x$exact))
125 | scores <- sort(scores, na.last = TRUE)
126 | if (x$fdr) {
127 | scores <- stats::p.adjust(scores, method = "BH")
128 | }
129 |
130 | exclude_chr <- dual_filter(scores, x$top_p, x$threshold, x$cutoff, maximize = FALSE)
131 | } else {
132 | exclude_chr <- character()
133 | }
134 |
135 | step_select_xtab_new(
136 | terms = x$terms,
137 | outcome = x$outcome,
138 | role = x$role,
139 | trained = TRUE,
140 | top_p = x$top_p,
141 | threshold = x$threshold,
142 | cutoff = x$cutoff,
143 | exact = x$exact,
144 | fdr = x$fdr,
145 | exclude = exclude_chr,
146 | skip = x$skip,
147 | id = x$id
148 | )
149 | }
150 |
151 | #' @export
152 | bake.step_select_xtab <- function(object, new_data, ...) {
153 | if (length(object$exclude) > 0) {
154 | new_data <- new_data %>% dplyr::select(-dplyr::one_of(object$exclude))
155 | }
156 | new_data
157 | }
158 |
159 | #' @export
160 | print.step_select_xtab <-
161 | function(x, width = max(20, options()$width - 30), ...) {
162 | cat("Association test feature selection")
163 |
164 | if (recipes::is_trained(x)) {
165 | n <- length(x$exclude)
166 | cat(paste0(" (", n, " excluded)"))
167 | }
168 | cat("\n")
169 |
170 | invisible(x)
171 | }
172 |
173 | #' @rdname step_select_xtab
174 | #' @param x A `step_select_xtab` object.
175 | #' @export
176 | tidy.step_select_xtab <- function(x, ...) {
177 | tidy_filter_step(x, type = "terms")
178 | }
179 |
180 | #' @export
181 | tunable.step_select_xtab <- function(x, ...) {
182 | tibble::tibble(
183 | name = c("top_p", "threshold", "cutoff"),
184 | call_info = list(
185 | list(pkg = "colino", fun = "top_p"),
186 | list(pkg = "dials", fun = "threshold", range = c(-10, -1)),
187 | list(pkg = "colino", fun = "cutoff")
188 | ),
189 | source = "recipe",
190 | component = "step_select_xtab",
191 | component_id = x$id
192 | )
193 | }
194 |
195 | #' @rdname required_pkgs.colino
196 | #' @export
197 | required_pkgs.step_select_xtab <- function(x, ...) {
198 | c("colino")
199 | }
200 |
--------------------------------------------------------------------------------
/docs/authors.html:
--------------------------------------------------------------------------------
1 |
2 |
39 |
43 |
44 |
53 |
54 |
55 |
45 |
46 |
51 |
52 | Copyright (c) 2019 Steven Pawley
47 |Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
48 |The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
49 |THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
50 |
38 |
89 |
90 |
91 |
92 |
93 |
94 |
95 |
96 |
--------------------------------------------------------------------------------
/R/step_select_carscore.R:
--------------------------------------------------------------------------------
1 | #' Feature selection step using the CAR score algorithm
2 | #'
3 | #' `step_select_carscore` creates a *specification* of a recipe step that
4 | #' selects a subset of predictors as part of a regression model based on the
5 | #' scores of the CAR score algorithm. This step requires the `care` package to be
6 | #' installed. The top `top_p` scoring features, or features whose scores occur
7 | #' in the top percentile `threshold` will be retained as new predictors.
8 | #'
9 | #' @inheritParams step_select_aov
10 | #' @inherit step_select_aov return
11 | #' @param role Not used by this step since no new variables are created.
12 | #' @param lambda The correlation shrinkage intensity (range 0-1).
13 | #' @param diagonal For diagonal = FALSE (the default) CAR scores are computed;
14 | #' otherwise with diagonal = TRUE marginal correlations.
15 | #' @param outcome A character string with the name of the response variable.
16 | #' This must refer to a numeric feature for regression.
17 | #' @param scores A tibble with 'variable' and 'scores' columns containing the
18 | #' names of the variables and the absolute values of the calculated CAR
19 | #' scores. This parameter is only produced after the recipe has been trained.
20 | #' @export
21 | #' @keywords datagen
22 | #' @concept preprocessing
23 | #' @concept supervised_filter
24 | #' @export
25 | #' @details
26 | #'
27 | #' The recipe will stop if all of `top_p`, `threshold` and `cutoff` are left
28 | #' unspecified.
29 | #'
30 | #' @examples
31 | #' library(recipes)
32 | #'
33 | #' data(car_prices, package = "modeldata")
34 | #'
35 | #' rec <-
36 | #' recipe(Price ~ ., data = car_prices) %>%
37 | #' step_select_carscore(
38 | #' all_predictors(),
39 | #' outcome = "Price",
40 | #' top_p = 5,
41 | #' cutoff = 0.7
42 | #' )
43 | #'
44 | #' prepped <- prep(rec)
45 | #'
46 | #' new_data <- bake(prepped, new_data = NULL)
47 | #' prepped
48 | step_select_carscore <- function(
49 | recipe, ...,
50 | outcome = NULL,
51 | role = NA,
52 | trained = FALSE,
53 | top_p = NA,
54 | threshold = NA,
55 | cutoff = NA,
56 | lambda = NA,
57 | diagonal = FALSE,
58 | exclude = NULL,
59 | scores = NULL,
60 | skip = FALSE,
61 | id = recipes::rand_id("select_carscore")) {
62 |
63 | recipes::recipes_pkg_check("care")
64 |
65 | terms <- recipes::ellipse_check(...)
66 |
67 | recipes::add_step(
68 | recipe,
69 | step_select_carscore_new(
70 | terms = terms,
71 | trained = trained,
72 | outcome = outcome,
73 | role = role,
74 | top_p = top_p,
75 | threshold = threshold,
76 | cutoff = cutoff,
77 | lambda = lambda,
78 | diagonal = diagonal,
79 | exclude = exclude,
80 | scores = scores,
81 | skip = skip,
82 | id = id
83 | )
84 | )
85 | }
86 |
87 |
88 | # wrapper around 'step' function that sets the class of new step objects
89 | step_select_carscore_new <-
90 | function(terms, role, trained, outcome, top_p, threshold, cutoff, lambda,
91 | diagonal, exclude, scores, skip, id) {
92 | recipes::step(
93 | subclass = "select_carscore",
94 | terms = terms,
95 | role = role,
96 | trained = trained,
97 | outcome = outcome,
98 | top_p = top_p,
99 | threshold = threshold,
100 | cutoff = cutoff,
101 | lambda = lambda,
102 | diagonal = diagonal,
103 | exclude = exclude,
104 | scores = scores,
105 | skip = skip,
106 | id = id
107 | )
108 | }
109 |
110 |
111 | #' @export
112 | prep.step_select_carscore <- function(x, training, info = NULL, ...) {
113 |
114 | # extract response and predictor names
115 | x_names <- recipes::recipes_eval_select(x$terms, training, info)
116 | y_name <- recipes::recipes_eval_select(x$outcome, training, info)
117 | y_name <- y_name[1]
118 |
119 | # check criteria
120 | recipes::check_type(training[, y_name], quant = TRUE)
121 | check_criteria(x$top_p, x$threshold, match.call())
122 | check_zero_one(x$threshold)
123 | x$top_p <- check_top_p(x$top_p, length(x_names))
124 |
125 | # information gain
126 | if (length(x_names) > 0) {
127 |
128 | args <- list()
129 |
130 | if (!is.na(x$lambda))
131 | args$lambda <- x$lambda
132 |
133 | call <- rlang::call2(
134 | .fn = "carscore",
135 | .ns = "care",
136 | Xtrain = training[, x_names],
137 | Ytrain = training[, y_name],
138 | diagonal = x$diagonal,
139 | !!!args
140 | )
141 |
142 | res <- rlang::eval_tidy(call)
143 |
144 | res <- tibble(
145 | variable = names(res),
146 | score = abs(res)
147 | )
148 |
149 | exclude <-
150 | dual_filter(res$score, x$top_p, x$threshold, x$cutoff, maximize = TRUE)
151 |
152 | } else {
153 | exclude <- character()
154 | }
155 |
156 | step_select_carscore_new(
157 | terms = x$terms,
158 | trained = TRUE,
159 | role = x$role,
160 | outcome = y_name,
161 | top_p = x$top_p,
162 | threshold = x$threshold,
163 | cutoff = x$cutoff,
164 | lambda = x$lambda,
165 | diagonal = x$diagonal,
166 | exclude = exclude,
167 | scores = res,
168 | skip = x$skip,
169 | id = x$id
170 | )
171 | }
172 |
173 | #' @export
174 | bake.step_select_carscore <- function(object, new_data, ...) {
175 | if (length(object$exclude > 0)) {
176 | new_data <- new_data[, !(colnames(new_data) %in% object$exclude)]
177 | }
178 | as_tibble(new_data)
179 | }
180 |
181 | #' @export
182 | print.step_select_carscore <-
183 | function(x, width = max(20, options()$width - 30), ...) {
184 | cat("Carscore feature selection")
185 |
186 | if (recipes::is_trained(x)) {
187 | n <- length(x$exclude)
188 | cat(paste0(" (", n, " excluded)"))
189 | }
190 | cat("\n")
191 |
192 | invisible(x)
193 | }
194 |
195 | #' @rdname step_select_carscore
196 | #' @param x A `step_select_carscore` object.
197 | #' @param type A character with either 'terms' (the default) to return a
198 | #' tibble containing the variables that have been removed by the filter step,
199 | #' or 'scores' to return the scores for each variable.
200 | #' @export
201 | tidy.step_select_carscore <- function(x, type = "terms", ...) {
202 | tidy_filter_step(x, type)
203 | }
204 |
205 | #' @export
206 | tunable.step_select_carscore <- function(x, ...) {
207 | tibble::tibble(
208 | name = c("top_p", "threshold", "cutoff"),
209 | call_info = list(
210 | list(pkg = "colino", fun = "top_p"),
211 | list(pkg = "dials", fun = "threshold", range = c(0, 1)),
212 | list(pkg = "colino", fun = "cutoff")
213 | ),
214 | source = "recipe",
215 | component = "step_select_carscore",
216 | component_id = x$id
217 | )
218 | }
219 |
220 | #' @rdname required_pkgs.colino
221 | #' @export
222 | required_pkgs.step_select_carscore <- function(x, ...) {
223 | c("colino", "care")
224 | }
225 |
--------------------------------------------------------------------------------
/R/step_select_infgain.R:
--------------------------------------------------------------------------------
1 | #' Information gain feature selection step
2 | #'
3 | #' `step_select_infgain` creates a *specification* of a recipe step that selects a
4 | #' subset of predictors based on the scores of the information gain algorithm.
5 | #' This step requires the FSelectorRcpp package to be installed. The top
6 | #' `top_p` scoring features, or features whose scores occur in the top
7 | #' percentile `threshold` will be retained as new predictors.
8 | #'
9 | #' @inheritParams step_select_aov
10 | #' @inherit step_select_aov return
11 | #' @param role Not used by this step since no new variables are created.
12 | #' @param type A character string specifying the information gain method to use.
13 | #' One of "infogain", "gainratio", "symuncert". The default is 'infogain'.
14 | #' @param outcome A character string with the name of the response variable to
15 | #' use to evaluate information gain value against the predictors.
16 | #' @param type The entropy measure. One of c("infogain", "gainratio",
17 | #' "symuncert"). The default is 'infogain'.
18 | #' @param threads An integer specifying the number of threads to use for
19 | #' processing. The default = 0 uses all available threads.
20 | #' @param nbins An integer specifying the number of bins for discretization.
21 | #' Only used if the outcome of a continuous variable for regression. The
22 | #' default is 'nbins = 5'.
23 | #' @param scores A tibble with 'variable' and 'scores' columns containing the
24 | #' names of the variables and their information gain scores. This parameter is
25 | #' only produced after the recipe has been trained.
26 | #'
27 | #' @export
28 | #' @keywords datagen
29 | #' @concept preprocessing
30 | #' @concept supervised_filter
31 | #' @export
32 | #' @details
33 | #'
34 | #' The recipe will stop if both `top_p`, `threshold` and `cutoff` are left
35 | #' unspecified.
36 | #'
37 | #' @examples
38 | #' library(recipes)
39 | #'
40 | #' data(cells, package = "modeldata")
41 | #'
42 | #' rec <-
43 | #' recipe(class ~ ., data = cells[, -1]) %>%
44 | #' step_select_infgain(
45 | #' all_predictors(),
46 | #' outcome = "class",
47 | #' threshold = 0.9,
48 | #' id = "infgain"
49 | #' )
50 | #'
51 | #' prepped <- prep(rec)
52 | #'
53 | #' new_data <- juice(prepped)
54 | #' prepped
55 | step_select_infgain <- function(
56 | recipe, ...,
57 | outcome = NULL,
58 | role = NA,
59 | trained = FALSE,
60 | top_p = NA,
61 | threshold = NA,
62 | cutoff = NA,
63 | type = "infogain",
64 | nbins = 5,
65 | threads = 1,
66 | exclude = NULL,
67 | scores = NULL,
68 | skip = FALSE,
69 | id = recipes::rand_id("select_infgain")) {
70 |
71 | recipes::recipes_pkg_check("FSelectorRcpp")
72 |
73 | terms <- recipes::ellipse_check(...)
74 |
75 | recipes::add_step(
76 | recipe,
77 | step_select_infgain_new(
78 | terms = terms,
79 | trained = trained,
80 | outcome = outcome,
81 | role = role,
82 | top_p = top_p,
83 | threshold = threshold,
84 | cutoff = cutoff,
85 | type = type,
86 | threads = threads,
87 | nbins = nbins,
88 | exclude = exclude,
89 | scores = scores,
90 | skip = skip,
91 | id = id
92 | )
93 | )
94 | }
95 |
96 |
97 | # wrapper around 'step' function that sets the class of new step objects
98 | step_select_infgain_new <- function(terms, role, trained, outcome, top_p,
99 | threshold, cutoff, type, threads, nbins,
100 | exclude, scores, skip, id) {
101 | recipes::step(
102 | subclass = "select_infgain",
103 | terms = terms,
104 | role = role,
105 | trained = trained,
106 | outcome = outcome,
107 | top_p = top_p,
108 | threshold = threshold,
109 | cutoff = cutoff,
110 | type = type,
111 | threads = threads,
112 | nbins = nbins,
113 | exclude = exclude,
114 | scores = scores,
115 | skip = skip,
116 | id = id
117 | )
118 | }
119 |
120 |
121 | #' @export
122 | prep.step_select_infgain <- function(x, training, info = NULL, ...) {
123 | # extract response and predictor names
124 | x_names <- recipes::recipes_eval_select(x$terms, training, info)
125 | y_name <- recipes::recipes_eval_select(x$outcome, training, info)
126 | y_name <- y_name[1]
127 |
128 | # check criteria
129 | check_criteria(x$top_p, x$threshold, match.call())
130 | check_zero_one(x$threshold)
131 | x$top_p <- check_top_p(x$top_p, length(x_names))
132 |
133 | # information gain
134 | if (length(x_names) > 0) {
135 |
136 | f <- stats::as.formula(paste(y_name, "~", paste0(x_names, collapse = " + ")))
137 | model_mode <- check_outcome(training[[y_name]])
138 | equal <- model_mode == "regression"
139 |
140 | ig_call <- rlang::call2(
141 | .fn = "information_gain",
142 | .ns = "FSelectorRcpp",
143 | formula = f,
144 | data = rlang::quo(training),
145 | type = x$type,
146 | threads = x$threads,
147 | discIntegers = TRUE,
148 | equal = equal,
149 | nbins = x$nbins
150 | )
151 |
152 | res <- rlang::eval_tidy(ig_call)
153 | res <- as_tibble(res)
154 | res <- rlang::set_names(res, c("variable", "score"))
155 | res$score <- rlang::set_names(res$score, res$variable)
156 |
157 | exclude <-
158 | dual_filter(res$score, x$top_p, x$threshold, x$cutoff, maximize = TRUE)
159 |
160 | } else {
161 | exclude <- character()
162 | }
163 |
164 | step_select_infgain_new(
165 | terms = x$terms,
166 | trained = TRUE,
167 | role = x$role,
168 | outcome = y_name,
169 | top_p = x$top_p,
170 | threshold = x$threshold,
171 | cutoff = x$cutoff,
172 | type = x$type,
173 | threads = x$threads,
174 | nbins = x$nbins,
175 | exclude = exclude,
176 | scores = res,
177 | skip = x$skip,
178 | id = x$id
179 | )
180 | }
181 |
182 | #' @export
183 | bake.step_select_infgain <- function(object, new_data, ...) {
184 | if (length(object$exclude > 0)) {
185 | new_data <- new_data[, !(colnames(new_data) %in% object$exclude)]
186 | }
187 | as_tibble(new_data)
188 | }
189 |
190 | #' @export
191 | print.step_select_infgain <-
192 | function(x, width = max(20, options()$width - 30), ...) {
193 | cat("Information Gain feature selection")
194 |
195 | if (recipes::is_trained(x)) {
196 | n <- length(x$exclude)
197 | cat(paste0(" (", n, " excluded)"))
198 | }
199 | cat("\n")
200 |
201 | invisible(x)
202 | }
203 |
204 | #' @rdname step_select_infgain
205 | #' @param x A `step_select_infgain` object.
206 | #' @param type A character with either 'terms' (the default) to return a
207 | #' tibble containing the variables that have been removed by the filter step,
208 | #' or 'scores' to return the scores for each variable.
209 | #' @export
210 | tidy.step_select_infgain <- function(x, type = "terms", ...) {
211 | tidy_filter_step(x, type)
212 | }
213 |
214 | #' @export
215 | tunable.step_select_infgain <- function(x, ...) {
216 | tibble::tibble(
217 | name = c("top_p", "entropy", "threshold", "cutoff"),
218 | call_info = list(
219 | list(pkg = "colino", fun = "top_p"),
220 | list(pkg = "colino", fun = "entropy", values = values_entropy),
221 | list(pkg = "dials", fun = "threshold", range = c(0, 1)),
222 | list(pkg = "colino", fun = "cutoff")
223 | ),
224 | source = "recipe",
225 | component = "step_select_infgain",
226 | component_id = x$id
227 | )
228 | }
229 |
230 | #' @rdname required_pkgs.colino
231 | #' @export
232 | required_pkgs.step_select_infgain <- function(x, ...) {
233 | c("colino", "FSelectorRcpp")
234 | }
235 |
--------------------------------------------------------------------------------
/R/step_select_tree.R:
--------------------------------------------------------------------------------
1 | #' Feature selection step using a decision tree importance scores
2 | #'
3 | #' `step_select_tree` creates a *specification* of a recipe step that selects a
4 | #' subset of predictors based on the ranking of variable importance provided by
5 | #' a `parsnip::decision_tree` supported model.
6 | #'
7 | #' @inheritParams step_select_aov
8 | #' @inherit step_select_aov return
9 | #' @param outcome A character string with the name of the response variable to
10 | #' use to calculate the feature importance scores.
11 | #' @param role Not used by this step since no new variables are created.
12 | #' @param engine A supported rand_forest engine that is supported by parsnip.
13 | #' The default is "rpart".
14 | #' @param cost_complexity A positive number for the the cost/complexity
15 | #' parameter (a.k.a. Cp) used by CART models (specific engines only).
16 | #' @param tree_depth An integer for maximum depth of the tree.
17 | #' @param min_n An integer for the minimum number of data points in a node that
18 | #' are required for the node to be split further.
19 | #' @param scores A tibble with 'variable' and 'scores' columns containing the
20 | #' names of the variables and their feature importance scores. This parameter
21 | #' is only produced after the recipe has been trained.
22 | #'
23 | #' @export
24 | #'
25 | #' @details
26 | #'
27 | #' The recipe will stop if all of `top_p`, `threshold` and `cutoff` are left
28 | #' unspecified.
29 | #'
30 | #' @examples
31 | #' library(recipes)
32 | #' library(parsnip)
33 | #'
34 | #' # load the example cells dataset
35 | #' data(cells, package = "modeldata")
36 | #'
37 | #' # create a preprocessing recipe
38 | #' rec <-
39 | #' recipe(class ~ ., data = cells[, -1]) %>%
40 | #' step_select_tree(all_predictors(), outcome = "class", top_p = 10)
41 | #'
42 | #' prepped <- prep(rec)
43 | #'
44 | #' preproc_data <- bake(prepped, new_data = NULL)
45 | #' prepped
46 | step_select_tree <- function(
47 | recipe,
48 | ...,
49 | outcome = NULL,
50 | role = "predictor",
51 | trained = FALSE,
52 | engine = "rpart",
53 | cost_complexity = NULL,
54 | tree_depth = NULL,
55 | min_n = NULL,
56 | top_p = NA,
57 | threshold = NA,
58 | cutoff = NA,
59 | exclude = NULL,
60 | scores = NULL,
61 | skip = FALSE,
62 | id = recipes::rand_id("select_tree")) {
63 |
64 | engines <- parsnip::show_engines("decision_tree")$engine
65 |
66 | if (!engine %in% engines) {
67 | rlang::abort(
68 | paste("Engine argument should be one of", paste(engines, collapse = ", "))
69 | )
70 | }
71 |
72 | recipes::add_step(
73 | recipe,
74 | step_select_tree_new(
75 | terms = recipes::ellipse_check(...),
76 | trained = trained,
77 | outcome = outcome,
78 | role = role,
79 | engine = engine,
80 | cost_complexity = cost_complexity,
81 | tree_depth = tree_depth,
82 | min_n = min_n,
83 | top_p = top_p,
84 | threshold = threshold,
85 | cutoff = cutoff,
86 | exclude = exclude,
87 | scores = scores,
88 | skip = skip,
89 | id = id
90 | )
91 | )
92 | }
93 |
94 | # wrapper around 'step' function that sets the class of new step objects
95 | #' @importFrom recipes step
96 | step_select_tree_new <- function(terms, role, trained, outcome, engine,
97 | top_p, threshold, cutoff, cost_complexity,
98 | tree_depth, min_n, exclude, scores, skip, id) {
99 | recipes::step(
100 | subclass = "select_tree",
101 | terms = terms,
102 | role = role,
103 | trained = trained,
104 | outcome = outcome,
105 | engine = engine,
106 | cost_complexity = cost_complexity,
107 | tree_depth = tree_depth,
108 | min_n = min_n,
109 | top_p = top_p,
110 | threshold = threshold,
111 | cutoff = cutoff,
112 | exclude = exclude,
113 | scores = scores,
114 | skip = skip,
115 | id = id
116 | )
117 | }
118 |
119 | #' @export
120 | prep.step_select_tree <- function(x, training, info = NULL, ...) {
121 |
122 | # translate the terms arguments
123 | x_names <- recipes::recipes_eval_select(x$terms, training, info)
124 | y_name <- recipes::recipes_eval_select(x$outcome, training, info)
125 | y_name <- y_name[1]
126 |
127 | # check criteria
128 | check_criteria(x$top_p, x$threshold, match.call())
129 | check_zero_one(x$threshold)
130 | x$top_p <- check_top_p(x$top_p, length(x_names))
131 |
132 | if (length(x_names) > 0) {
133 | # fit initial model
134 | X <- training[, x_names]
135 | y <- training[[y_name]]
136 |
137 | model_mode <- check_outcome(y)
138 |
139 | model_args <- list(
140 | cost_complexity = x$cost_complexity,
141 | tree_depth = x$tree_depth,
142 | min_n = x$min_n
143 | )
144 |
145 | model_spec <-
146 | parsnip::make_call("decision_tree", args = model_args, ns = "parsnip")
147 |
148 | model_spec <-
149 | rlang::eval_tidy(model_spec) %>%
150 | parsnip::set_mode(model_mode) %>%
151 | parsnip::set_engine(x$engine)
152 |
153 | initial_model <- parsnip::fit_xy(model_spec, X, y)
154 | res <- pull_importances(initial_model)
155 | names(res) <- c("variable", "score")
156 | res$score <- rlang::set_names(res$score, res$variable)
157 |
158 | exclude <-
159 | dual_filter(res$score, x$top_p, x$threshold, x$cutoff, maximize = TRUE)
160 |
161 | } else {
162 | exclude <- character()
163 | }
164 |
165 | step_select_tree_new(
166 | terms = x$terms,
167 | trained = TRUE,
168 | role = x$role,
169 | outcome = y_name,
170 | engine = x$engine,
171 | cost_complexity = x$cost_complexity,
172 | tree_depth = x$tree_depth,
173 | min_n = x$min_n,
174 | top_p = x$top_p,
175 | threshold = x$threshold,
176 | cutoff = x$cutoff,
177 | exclude = exclude,
178 | scores = res,
179 | skip = x$skip,
180 | id = x$id
181 | )
182 | }
183 |
184 | #' @export
185 | bake.step_select_tree <- function(object, new_data, ...) {
186 | if (length(object$exclude) > 0) {
187 | new_data <- new_data[, !colnames(new_data) %in% object$exclude]
188 | }
189 |
190 | as_tibble(new_data)
191 | }
192 |
193 | #' @export
194 | print.step_select_tree <-
195 | function(x, width = max(20, options()$width - 30),
196 | ...) {
197 | cat("Variable importance feature selection")
198 |
199 | if (recipes::is_trained(x)) {
200 | n <- length(x$exclude)
201 | cat(paste0(" (", n, " excluded)"))
202 | }
203 | cat("\n")
204 |
205 | invisible(x)
206 | }
207 |
208 | #' @rdname step_select_tree
209 | #' @param x A `step_select_tree` object.
210 | #' @param type A character with either 'terms' (the default) to return a
211 | #' tibble containing the variables that have been removed by the filter step,
212 | #' or 'scores' to return the scores for each variable.
213 | #' @export
214 | tidy.step_select_tree <- function(x, type = "terms", ...) {
215 | tidy_filter_step(x, type)
216 | }
217 |
218 | #' @export
219 | tunable.step_select_tree <- function(x, ...) {
220 | tibble(
221 | name = c("top_p", "threshold", "cutoff", "cost_complexity", "tree_depth", "min_n"),
222 | call_info = list(
223 | list(pkg = "colino", fun = "top_p"),
224 | list(pkg = "dials", fun = "threshold", range = c(0, 1)),
225 | list(pkg = "colino", fun = "cutoff"),
226 | list(pkg = "dials", fun = "cost_complexity", range = c(-10, -1),
227 | trans = scales::log10_trans()),
228 | list(pkg = "dials", fun = "tree_depth", range = c(1L, 15L)),
229 | list(pkg = "dials", fun = "min_n", range = c(2L, 40L))
230 | ),
231 | source = "recipe",
232 | component = "step_select_tree",
233 | component_id = x$id
234 | )
235 | }
236 |
237 | #' @rdname required_pkgs.colino
238 | #' @export
239 | required_pkgs.step_select_tree <- function(x, ...) {
240 | c("colino")
241 | }
242 |
--------------------------------------------------------------------------------
/R/step_select_relief.R:
--------------------------------------------------------------------------------
1 | #' Feature selection step using the Relief algorithm
2 | #'
3 | #' Relief-based algorithms use nearest neighbors of randomly sampled
4 | #' observations (without replacement) to derive feature weights/scores that
5 | #' describe the relevance of each feature to the target variable. The feature
6 | #' weights represent the differences between the normalized feature values from
7 | #' each randomly sampled observation and a neighboring observation. If the
8 | #' neighboring observation's class is the same as the sampled observation
9 | #' (termed a 'hit') but the feature values are different, then this reduces the
10 | #' score on the basis that widely varying feature values for the same class are
11 | #' not desirable. Conversely, if a neighboring observation's class is different
12 | #' from the sampled observation (termed a 'miss') and the feature values are
13 | #' different, then this increases the score on the basis that observations of
14 | #' different classes are widely separated by their feature values. The feature
15 | #' weights / scores range from -1 (worst) to +1 (best).
16 | #'
17 | #' `step_select_relief` creates a *specification* of a recipe step that selects
18 | #' a subset of predictors based on the scores of the relief algorithm. This step
19 | #' requires the FSinR package to be installed. The top `top_p` scoring features,
20 | #' or features whose scores occur in the top percentile `threshold` will be
21 | #' retained as new predictors.
22 | #'
23 | #' @inheritParams step_select_aov
24 | #' @inherit step_select_aov return
25 | #' @param role Not used by this step since no new variables are created.
26 | #' @param outcome A character string with the name of the response variable to
27 | #' use to evaluate information gain value against the predictors.
28 | #' @param neighbors An integer with the number of neighbors for find for each
29 | #' sampled instance. Default is 5.
30 | #' @param sample_size An integer with the number of instances to sample. Default
31 | #' is 10.
32 | #' @param scores A tibble with 'variable' and 'scores' columns containing the
33 | #' names of the variables and their information gain scores. This parameter is
34 | #' only produced after the recipe has been trained.
35 | #'
36 | #' @export
37 | #' @keywords datagen
38 | #' @concept preprocessing
39 | #' @concept supervised_filter
40 | #' @export
41 | #' @details
42 | #'
43 | #' The recipe will stop if all of `top_p`, `threshold` and `cutoff` are left
44 | #' unspecified.
45 | #'
46 | #' @examples
47 | #' \dontrun{
48 | #' library(recipes)
49 | #'
50 | #' data(cells, package = "modeldata")
51 | #'
52 | #' rec <- recipe(class ~ ., data = cells[, -1]) %>%
53 | #' step_select_relief(
54 | #' all_predictors(),
55 | #' outcome = "class",
56 | #' top_p = 10
57 | #' )
58 | #'
59 | #' prepped <- prep(rec)
60 | #' new_data <- bake(prepped, new_data = NULL)
61 | #' prepped
62 | #' }
63 | step_select_relief <- function(
64 | recipe, ...,
65 | outcome = NULL,
66 | role = NA,
67 | trained = FALSE,
68 | top_p = NA,
69 | threshold = NA,
70 | cutoff = NA,
71 | neighbors = 5,
72 | sample_size = 10,
73 | exclude = NULL,
74 | scores = NULL,
75 | skip = FALSE,
76 | id = recipes::rand_id("select_relief")) {
77 |
78 | recipes::recipes_pkg_check("FSinR")
79 |
80 | if (neighbors <= 0)
81 | rlang::abort("`neighbors` must be greater than zero")
82 |
83 | if (sample_size <= 0)
84 | rlang::abort("'sample_size' must be greater than zero")
85 |
86 | terms <- recipes::ellipse_check(...)
87 |
88 | recipes::add_step(
89 | recipe,
90 | step_select_relief_new(
91 | terms = terms,
92 | trained = trained,
93 | outcome = outcome,
94 | role = role,
95 | top_p = top_p,
96 | threshold = threshold,
97 | cutoff = cutoff,
98 | neighbors = neighbors,
99 | sample_size = sample_size,
100 | exclude = exclude,
101 | scores = scores,
102 | skip = skip,
103 | id = id
104 | )
105 | )
106 | }
107 |
108 |
109 | # wrapper around 'step' function that sets the class of new step objects
110 | step_select_relief_new <-
111 | function(terms, role, trained, outcome, top_p, threshold, cutoff, neighbors,
112 | sample_size, exclude, scores, skip, id) {
113 | recipes::step(
114 | subclass = "select_relief",
115 | terms = terms,
116 | role = role,
117 | trained = trained,
118 | outcome = outcome,
119 | top_p = top_p,
120 | threshold = threshold,
121 | cutoff = cutoff,
122 | neighbors = neighbors,
123 | sample_size = sample_size,
124 | exclude = exclude,
125 | scores = scores,
126 | skip = skip,
127 | id = id
128 | )
129 | }
130 |
131 |
132 | #' @export
133 | prep.step_select_relief <- function(x, training, info = NULL, ...) {
134 | x_names <- recipes::recipes_eval_select(x$terms, training, info)
135 | y_name <- recipes::recipes_eval_select(x$outcome, training, info)
136 | y_name <- y_name[1]
137 |
138 | # check criteria
139 | check_criteria(x$top_p, x$threshold, match.call())
140 | check_zero_one(x$threshold)
141 | x$top_p <- check_top_p(x$top_p, length(x_names))
142 |
143 | # feature selection
144 | if (length(x_names) > 0) {
145 | call_func <- rlang::call2(
146 | .fn = "relief",
147 | .ns = "FSelectorRcpp",
148 | x = rlang::quo(as.data.frame(training[, x_names])),
149 | y = rlang::quo(training[[y_name]]),
150 | neighboursCount = x$neighbors,
151 | sampleSize = x$sample_size
152 | )
153 | res <- rlang::eval_tidy(call_func)
154 | res <- as_tibble(res)
155 | res <- rlang::set_names(res, c("variable", "score"))
156 | res$score <- rlang::set_names(res$score, res$variable)
157 | res <- res[order(res$score, decreasing = TRUE), ]
158 |
159 | exclude <-
160 | dual_filter(res$score, x$top_p, x$threshold, x$cutoff, maximize = TRUE)
161 |
162 | } else {
163 | exclude <- character()
164 | }
165 |
166 | step_select_relief_new(
167 | terms = x$terms,
168 | trained = TRUE,
169 | role = x$role,
170 | outcome = y_name,
171 | top_p = x$top_p,
172 | threshold = x$threshold,
173 | cutoff = x$cutoff,
174 | neighbors = x$neighbors,
175 | sample_size = x$sample_size,
176 | exclude = exclude,
177 | scores = res,
178 | skip = x$skip,
179 | id = x$id
180 | )
181 | }
182 |
183 | #' @export
184 | bake.step_select_relief <- function(object, new_data, ...) {
185 | if (length(object$exclude > 0)) {
186 | new_data <- new_data[, !(colnames(new_data) %in% object$exclude)]
187 | }
188 | as_tibble(new_data)
189 | }
190 |
191 | #' @export
192 | print.step_select_relief <- function(x, width = max(20, options()$width - 30), ...) {
193 | cat("Relief feature selection")
194 |
195 | if (recipes::is_trained(x)) {
196 | n <- length(x$exclude)
197 | cat(paste0(" (", n, " excluded)"))
198 | }
199 | cat("\n")
200 |
201 | invisible(x)
202 | }
203 |
204 | #' @rdname step_select_relief
205 | #' @param x A `step_select_relief` object.
206 | #' @export
207 | tidy.step_select_relief <- function(x, ...) {
208 | if (recipes::is_trained(x)) {
209 | res <- tibble(terms = x$exclude)
210 | } else {
211 | term_names <- recipes::sel2char(x$terms)
212 | res <- tibble(terms = rlang::na_chr)
213 | }
214 | res$id <- x$id
215 | res
216 | }
217 |
218 | #' @export
219 | tunable.step_select_relief <- function(x, ...) {
220 | tibble::tibble(
221 | name = c("top_p", "threshold", "cutoff"),
222 | call_info = list(
223 | list(pkg = "colino", fun = "top_p"),
224 | list(pkg = "dials", fun = "threshold", range = c(0, 1)),
225 | list(pkg = "colino", fun = "cutoff")
226 | ),
227 | source = "recipe",
228 | component = "step_select_relief",
229 | component_id = x$id
230 | )
231 | }
232 |
233 | #' @rdname required_pkgs.colino
234 | #' @export
235 | required_pkgs.step_select_relief <- function(x, ...) {
236 | c("colino", "FSinR")
237 | }
238 |
--------------------------------------------------------------------------------
39 |
78 |
79 |
80 |
40 | ![]()
42 |
43 | Authors and Citation
41 |
44 |
59 |
60 | Authors
45 | 46 |-
47 |
Steven Pawley. Author, maintainer. 48 |
49 |
50 | -
51 |
Max Kuhn. Author. 52 |
53 |
54 | -
55 |
Rowan Jacques-Hamilton. Author. 56 |
57 |
58 |
61 |
76 | Citation
62 |Source: DESCRIPTION
Pawley S, Kuhn M, Jacques-Hamilton R (2022). 65 | colino: Recipes Steps for Supervised Filter-Based Feature Selection. 66 | R package version 0.0.1, https://stevenpawley.github.io/colino. 67 |
68 |@Manual{,
69 | title = {colino: Recipes Steps for Supervised Filter-Based Feature Selection},
70 | author = {Steven Pawley and Max Kuhn and Rowan Jacques-Hamilton},
71 | year = {2022},
72 | note = {R package version 0.0.1},
73 | url = {https://stevenpawley.github.io/colino},
74 | }
75 |