1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
#' Zero Variance Filter
#'
#' `step_zv` creates a *specification* of a recipe step
#' that will remove variables that contain only a single value.
#'
#' @inheritParams step_center
#' @param removals A character string that contains the names of
#' columns that should be removed. These values are not determined
#' until [prep()] is called.
#' @param group An optional character string or call to [dplyr::vars()]
#' that can be used to specify a group(s) within which to identify
#' variables that contain only a single value. If the grouping variables
#' are contained in terms selector, they will not be considered for
#' removal.
#' @template step-return
#' @template filter-steps
#' @details
#'
#' # Tidying
#'
#' When you [`tidy()`][tidy.recipe()] this step, a tibble with column
#' `terms` (the columns that will be removed) is returned.
#'
#' @template case-weights-not-supported
#'
#' @family variable filter steps
#' @export
#'
#' @examplesIf rlang::is_installed("modeldata")
#' data(biomass, package = "modeldata")
#'
#' biomass$one_value <- 1
#'
#' biomass_tr <- biomass[biomass$dataset == "Training", ]
#' biomass_te <- biomass[biomass$dataset == "Testing", ]
#'
#' rec <- recipe(HHV ~ carbon + hydrogen + oxygen +
#' nitrogen + sulfur + one_value,
#' data = biomass_tr
#' )
#'
#' zv_filter <- rec %>%
#' step_zv(all_predictors())
#'
#' filter_obj <- prep(zv_filter, training = biomass_tr)
#'
#' filtered_te <- bake(filter_obj, biomass_te)
#' any(names(filtered_te) == "one_value")
#'
#' tidy(zv_filter, number = 1)
#' tidy(filter_obj, number = 1)
step_zv <-
function(recipe,
...,
role = NA,
trained = FALSE,
group = NULL,
removals = NULL,
skip = FALSE,
id = rand_id("zv")) {
add_step(
recipe,
step_zv_new(
terms = enquos(...),
role = role,
trained = trained,
group = group,
removals = removals,
skip = skip,
id = id
)
)
}
step_zv_new <-
function(terms, role, trained, group, removals, skip, id) {
step(
subclass = "zv",
terms = terms,
role = role,
trained = trained,
group = group,
removals = removals,
skip = skip,
id = id
)
}
one_unique <- function(x) {
x <- x[!is.na(x)]
length(unique(x)) < 2
}
group_one_unique <- function(x, f) {
x_split <- split(x, f)
any(vapply(x_split, one_unique, logical(1)))
}
#' @export
prep.step_zv <- function(x, training, info = NULL, ...) {
col_names <- recipes_eval_select(x$terms, training, info)
group_names <- recipes_eval_select(x$group, training, info)
if (is.null(x$group)) {
filter <- vapply(training[, col_names], one_unique, logical(1))
} else {
filter <- vapply(
training[, setdiff(col_names, group_names)],
group_one_unique,
f = interaction(training[group_names]),
logical(1)
)
}
step_zv_new(
terms = x$terms,
role = x$role,
trained = TRUE,
group = x$group,
removals = names(filter)[filter],
skip = x$skip,
id = x$id
)
}
#' @export
bake.step_zv <- function(object, new_data, ...) {
if (length(object$removals) > 0) {
new_data <- new_data[, !(colnames(new_data) %in% object$removals)]
}
new_data
}
print.step_zv <-
function(x, width = max(20, options()$width - 38), ...) {
if (x$trained) {
title <- "Zero variance filter removed "
} else {
title <- "Zero variance filter on "
}
print_step(x$removals, x$terms, x$trained, title, width)
invisible(x)
}
#' @rdname tidy.recipe
#' @export
tidy.step_zv <- tidy_filter
|
