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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
#' Impute numeric data below the threshold of measurement
#'
#' `step_impute_lower` creates a *specification* of a recipe step
#' designed for cases where the non-negative numeric data cannot be
#' measured below a known value. In these cases, one method for
#' imputing the data is to substitute the truncated value by a
#' random uniform number between zero and the truncation point.
#'
#' @inheritParams step_center
#' @param threshold A named numeric vector of lower bounds. This is
#' `NULL` until computed by [prep()].
#' @template step-return
#' @family imputation steps
#' @export
#' @details `step_impute_lower` estimates the variable minimums
#' from the data used in the `training` argument of `prep.recipe`.
#' `bake.recipe` then simulates a value for any data at the minimum
#' with a random uniform value between zero and the minimum.
#'
#' As of `recipes` 0.1.16, this function name changed from `step_lowerimpute()`
#' to `step_impute_lower()`.
#'
#' # Tidying
#'
#' When you [`tidy()`][tidy.recipe()] this step, a tibble with columns
#' `terms` (the selectors or variables selected) and `value` for the
#' estimated threshold is returned.
#'
#' @template case-weights-not-supported
#'
#' @examplesIf rlang::is_installed("modeldata")
#' library(recipes)
#' data(biomass, package = "modeldata")
#'
#' ## Truncate some values to emulate what a lower limit of
#' ## the measurement system might look like
#'
#' biomass$carbon <- ifelse(biomass$carbon > 40, biomass$carbon, 40)
#' biomass$hydrogen <- ifelse(biomass$hydrogen > 5, biomass$carbon, 5)
#'
#' biomass_tr <- biomass[biomass$dataset == "Training", ]
#' biomass_te <- biomass[biomass$dataset == "Testing", ]
#'
#' rec <- recipe(
#' HHV ~ carbon + hydrogen + oxygen + nitrogen + sulfur,
#' data = biomass_tr
#' )
#'
#' impute_rec <- rec %>%
#' step_impute_lower(carbon, hydrogen)
#'
#' tidy(impute_rec, number = 1)
#'
#' impute_rec <- prep(impute_rec, training = biomass_tr)
#'
#' tidy(impute_rec, number = 1)
#'
#' transformed_te <- bake(impute_rec, biomass_te)
#'
#' plot(transformed_te$carbon, biomass_te$carbon,
#' ylab = "pre-imputation", xlab = "imputed"
#' )
step_impute_lower <-
function(recipe,
...,
role = NA,
trained = FALSE,
threshold = NULL,
skip = FALSE,
id = rand_id("impute_lower")) {
add_step(
recipe,
step_impute_lower_new(
terms = enquos(...),
role = role,
trained = trained,
threshold = threshold,
skip = skip,
id = id
)
)
}
#' @rdname step_impute_lower
#' @export
step_lowerimpute <- function(recipe,
...,
role = NA,
trained = FALSE,
threshold = NULL,
skip = FALSE,
id = rand_id("impute_lower")) {
lifecycle::deprecate_stop(
when = "0.1.16",
what = "recipes::step_lowerimpute()",
with = "recipes::step_impute_lower()"
)
step_impute_lower(
recipe,
...,
role = role,
trained = trained,
threshold = threshold,
skip = skip,
id = id
)
}
step_impute_lower_new <-
function(terms, role, trained, threshold, skip, id) {
step(
subclass = "impute_lower",
terms = terms,
role = role,
trained = trained,
threshold = threshold,
skip = skip,
id = id
)
}
#' @export
prep.step_impute_lower <- function(x, training, info = NULL, ...) {
col_names <- recipes_eval_select(x$terms, training, info)
check_type(training[, col_names], types = c("double", "integer"))
threshold <-
vapply(training[, col_names], min, numeric(1), na.rm = TRUE)
if (any(threshold < 0)) {
rlang::abort(
paste0(
"Some columns have negative values. Lower bound ",
"imputation is intended for data bounded at zero."
)
)
}
step_impute_lower_new(
terms = x$terms,
role = x$role,
trained = TRUE,
threshold = threshold,
skip = x$skip,
id = x$id
)
}
#' @export
#' @keywords internal
prep.step_lowerimpute <- prep.step_impute_lower
#' @export
bake.step_impute_lower <- function(object, new_data, ...) {
check_new_data(names(object$threshold), object, new_data)
for (i in names(object$threshold)) {
affected <- which(new_data[[i]] <= object$threshold[[i]])
if (length(affected) > 0) {
new_data[[i]][affected] <- runif(
length(affected),
max = object$threshold[[i]]
)
}
}
new_data
}
#' @export
#' @keywords internal
bake.step_lowerimpute <- bake.step_impute_lower
#' @export
print.step_impute_lower <-
function(x, width = max(20, options()$width - 30), ...) {
title <- "Lower bound imputation for "
print_step(names(x$threshold), x$terms, x$trained, title, width)
invisible(x)
}
#' @export
#' @keywords internal
print.step_lowerimpute <- print.step_impute_lower
#' @rdname tidy.recipe
#' @export
tidy.step_impute_lower <- function(x, ...) {
if (is_trained(x)) {
res <- tibble(
terms = names(x$threshold),
value = unname(x$threshold)
)
} else {
term_names <- sel2char(x$terms)
res <- tibble(terms = term_names, value = na_dbl)
}
res$id <- x$id
res
}
#' @export
#' @keywords internal
tidy.step_lowerimpute <- tidy.step_impute_lower
|
