Skip to content

Commit cbb4fe5

Browse files
kenmawerkenmawer
authored
Merge pull request #9 from kenmawer/km-issue_22_unite_v2
Km issue 22 uniting lag and ahead: Complete
2 parents 3df6009 + be6c421 commit cbb4fe5

File tree

5 files changed

+195
-191
lines changed

5 files changed

+195
-191
lines changed

‎NAMESPACE‎

Lines changed: 4 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,14 @@
11
# Generated by roxygen2: do not edit by hand
22

3-
S3method(bake,step_epi_ahead)
4-
S3method(bake,step_epi_lag)
3+
S3method(bake,step_epi_shift)
54
S3method(epi_keys,default)
65
S3method(epi_keys,epi_df)
76
S3method(epi_keys,recipe)
87
S3method(epi_recipe,default)
98
S3method(epi_recipe,epi_df)
109
S3method(epi_recipe,formula)
11-
S3method(prep,step_epi_ahead)
12-
S3method(prep,step_epi_lag)
13-
S3method(print,step_epi_ahead)
14-
S3method(print,step_epi_lag)
10+
S3method(prep,step_epi_shift)
11+
S3method(print,step_epi_shift)
1512
export("%>%")
1613
export(arx_args_list)
1714
export(arx_forecaster)
@@ -29,6 +26,7 @@ export(smooth_arx_args_list)
2926
export(smooth_arx_forecaster)
3027
export(step_epi_ahead)
3128
export(step_epi_lag)
29+
export(step_epi_shift)
3230
import(recipes)
3331
importFrom(magrittr,"%>%")
3432
importFrom(rlang,"!!")

‎R/epi_ahead.R‎

Lines changed: 11 additions & 96 deletions
Original file line numberDiff line numberDiff line change
@@ -63,101 +63,16 @@ step_epi_ahead <-
6363
columns = NULL,
6464
skip = FALSE,
6565
id = rand_id("epi_ahead")) {
66-
add_step(
67-
recipe,
68-
step_epi_ahead_new(
69-
terms = dplyr::enquos(...),
70-
role = role,
71-
trained = trained,
72-
ahead = ahead,
73-
prefix = prefix,
74-
default = default,
75-
keys = keys,
76-
columns = columns,
77-
skip = skip,
78-
id = id
79-
)
66+
step_epi_shift(recipe,
67+
...,
68+
role = role,
69+
trained = trained,
70+
shift = ahead,
71+
prefix = prefix,
72+
default = default,
73+
keys = keys,
74+
columns = columns,
75+
skip = skip,
76+
id = id
8077
)
8178
}
82-
83-
step_epi_ahead_new <-
84-
function(terms, role, trained, ahead, prefix, default, keys,
85-
columns, skip, id) {
86-
step(
87-
subclass = "epi_ahead",
88-
terms = terms,
89-
role = role,
90-
trained = trained,
91-
ahead = ahead,
92-
prefix = prefix,
93-
default = default,
94-
keys = keys,
95-
columns = columns,
96-
skip = skip,
97-
id = id
98-
)
99-
}
100-
101-
#' @export
102-
prep.step_epi_ahead <- function(x, training, info = NULL, ...) {
103-
step_epi_ahead_new(
104-
terms = x$terms,
105-
role = x$role,
106-
trained = TRUE,
107-
ahead = x$ahead,
108-
prefix = x$prefix,
109-
default = x$default,
110-
keys = x$keys,
111-
columns = recipes_eval_select(x$terms, training, info),
112-
skip = x$skip,
113-
id = x$id
114-
)
115-
}
116-
117-
#' @export
118-
bake.step_epi_ahead <- function(object, new_data, ...) {
119-
if (!all(object$ahead == as.integer(object$ahead))) {
120-
rlang::abort("step_epi_ahead requires 'ahead' argument to be integer valued.")
121-
}
122-
123-
grid <- tidyr::expand_grid(
124-
col = object$columns, lag_val = -object$ahead) %>%
125-
dplyr::mutate(
126-
ahead_val = -lag_val,
127-
newname = glue::glue("{object$prefix}{ahead_val}_{col}")
128-
) %>%
129-
dplyr::select(-ahead_val)
130-
131-
## ensure no name clashes
132-
new_data_names <- colnames(new_data)
133-
intersection <- new_data_names %in% grid$newname
134-
if (any(intersection)) {
135-
rlang::abort(
136-
paste0("Name collision occured in `", class(object)[1],
137-
"`. The following variable names already exists: ",
138-
paste0(new_data_names[intersection], collapse = ", "),
139-
"."))
140-
}
141-
142-
ok <- object$keys
143-
lagged <- purrr::reduce(
144-
purrr::pmap(grid, epi_shift_single, x = new_data, key_cols = ok),
145-
dplyr::full_join,
146-
by = ok
147-
)
148-
149-
dplyr::full_join(new_data, lagged, by = ok) %>%
150-
dplyr::group_by(dplyr::across(dplyr::all_of(ok[-1]))) %>%
151-
dplyr::arrange(time_value) %>%
152-
dplyr::ungroup()
153-
154-
}
155-
156-
#' @export
157-
print.step_epi_ahead <-
158-
function(x, width = max(20, options()$width - 30), ...) {
159-
## TODO add printing of the lags
160-
title <- "Leading "
161-
recipes::print_step(x$columns, x$terms, x$trained, title, width)
162-
invisible(x)
163-
}

‎R/epi_lag.R‎

Lines changed: 11 additions & 88 deletions
Original file line numberDiff line numberDiff line change
@@ -29,94 +29,17 @@ step_epi_lag <-
2929
columns = NULL,
3030
skip = FALSE,
3131
id = rand_id("epi_lag")) {
32-
add_step(
33-
recipe,
34-
step_epi_lag_new(
35-
terms = dplyr::enquos(...),
36-
role = role,
37-
trained = trained,
38-
lag = lag,
39-
prefix = prefix,
40-
default = default,
41-
keys = keys,
42-
columns = columns,
43-
skip = skip,
44-
id = id
45-
)
32+
step_epi_shift(recipe,
33+
...,
34+
role = role,
35+
trained = trained,
36+
shift = -lag,
37+
prefix = prefix,
38+
default = default,
39+
keys = keys,
40+
columns = columns,
41+
skip = skip,
42+
id = id
4643
)
4744
}
4845

49-
step_epi_lag_new <-
50-
function(terms, role, trained, lag, prefix, default, keys,
51-
columns, skip, id) {
52-
step(
53-
subclass = "epi_lag",
54-
terms = terms,
55-
role = role,
56-
trained = trained,
57-
lag = lag,
58-
prefix = prefix,
59-
default = default,
60-
keys = keys,
61-
columns = columns,
62-
skip = skip,
63-
id = id
64-
)
65-
}
66-
67-
#' @export
68-
prep.step_epi_lag <- function(x, training, info = NULL, ...) {
69-
step_epi_lag_new(
70-
terms = x$terms,
71-
role = x$role,
72-
trained = TRUE,
73-
lag = x$lag,
74-
prefix = x$prefix,
75-
default = x$default,
76-
keys = x$keys,
77-
columns = recipes_eval_select(x$terms, training, info),
78-
skip = x$skip,
79-
id = x$id
80-
)
81-
}
82-
83-
#' @export
84-
bake.step_epi_lag <- function(object, new_data, ...) {
85-
if (!all(object$lag == as.integer(object$lag))) {
86-
rlang::abort("step_epi_lag requires 'lag' argument to be integer valued.")
87-
}
88-
grid <- tidyr::expand_grid(col = object$columns, lag_val = object$lag) %>%
89-
dplyr::mutate(newname = glue::glue("{object$prefix}{lag_val}_{col}"))
90-
91-
## ensure no name clashes
92-
new_data_names <- colnames(new_data)
93-
intersection <- new_data_names %in% grid$newname
94-
if (any(intersection)) {
95-
rlang::abort(
96-
paste0("Name collision occured in `", class(object)[1],
97-
"`. The following variable names already exists: ",
98-
paste0(new_data_names[intersection], collapse = ", "),
99-
"."))
100-
}
101-
ok <- object$keys
102-
lagged <- purrr::reduce(
103-
purrr::pmap(grid, epi_shift_single, x = new_data, key_cols = ok),
104-
dplyr::full_join,
105-
by = ok
106-
)
107-
108-
dplyr::full_join(new_data, lagged, by = ok) %>%
109-
dplyr::group_by(dplyr::across(dplyr::all_of(ok[-1]))) %>%
110-
dplyr::arrange(time_value) %>%
111-
dplyr::ungroup()
112-
113-
}
114-
115-
#' @export
116-
print.step_epi_lag <-
117-
function(x, width = max(20, options()$width - 30), ...) {
118-
## TODO add printing of the lags
119-
title <- "Lagging "
120-
recipes::print_step(x$columns, x$terms, x$trained, title, width)
121-
invisible(x)
122-
}

‎R/epi_shift_internal.R‎

Lines changed: 136 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,136 @@
1+
#' Create a shifted predictor
2+
#'
3+
#' `step_epi_shift` creates a *specification* of a recipe step that
4+
#' will add new columns of shifted data. shifted data will
5+
#' by default include NA values where the shift was induced.
6+
#' These can be removed with [step_naomit()], or you may
7+
#' specify an alternative filler value with the `default`
8+
#' argument.
9+
#'
10+
#' @param shift A vector of integers. Each specified column will be
11+
#' shifted for each value in the vector.
12+
#' @template step-return
13+
#'
14+
#' @details The step assumes that the data are already _in the proper sequential
15+
#' order_ for shifting.
16+
#'
17+
#' @family row operation steps
18+
#' @export
19+
#' @rdname step_epi_ahead
20+
step_epi_shift <-
21+
function(recipe,
22+
...,
23+
role,
24+
trained,
25+
shift,
26+
prefix,
27+
default,
28+
keys,
29+
columns,
30+
skip,
31+
id) {
32+
add_step(
33+
recipe,
34+
step_epi_shift_new(
35+
terms = dplyr::enquos(...),
36+
role = role,
37+
trained = trained,
38+
shift = shift,
39+
prefix = prefix,
40+
default = default,
41+
keys = keys,
42+
columns = columns,
43+
skip = skip,
44+
id = id
45+
)
46+
)
47+
}
48+
49+
step_epi_shift_new <-
50+
function(terms, role, trained, shift, prefix, default, keys,
51+
columns, skip, id) {
52+
step(
53+
subclass = "epi_shift",
54+
terms = terms,
55+
role = role,
56+
trained = trained,
57+
shift = shift,
58+
prefix = prefix,
59+
default = default,
60+
keys = keys,
61+
columns = columns,
62+
skip = skip,
63+
id = id
64+
)
65+
}
66+
67+
#' @export
68+
prep.step_epi_shift <- function(x, training, info = NULL, ...) {
69+
step_epi_shift_new(
70+
terms = x$terms,
71+
role = x$role,
72+
trained = TRUE,
73+
shift = x$shift,
74+
prefix = x$prefix,
75+
default = x$default,
76+
keys = x$keys,
77+
columns = recipes_eval_select(x$terms, training, info),
78+
skip = x$skip,
79+
id = x$id
80+
)
81+
}
82+
83+
#' @export
84+
bake.step_epi_shift <- function(object, new_data, ...) {
85+
if (!all(object$shift == as.integer(object$shift))) {
86+
rlang::abort("step_epi_shift requires 'shift' argument to be integer valued.")
87+
}
88+
grid <- tidyr::expand_grid(col = object$columns, lag_val = -object$shift)
89+
is_lag <- object$role == "predictor"
90+
if (!is_lag) {
91+
grid <- dplyr::mutate(grid,ahead_val = -lag_val)
92+
}
93+
grid <- dplyr::mutate(grid,
94+
newname = glue::glue(
95+
paste0(
96+
"{object$prefix}",
97+
ifelse(is_lag,"{lag_val}","{ahead_val}"),
98+
"_{col}"
99+
)
100+
)
101+
)
102+
if (!is_lag) {
103+
grid <- dplyr::select(grid, -ahead_val)
104+
}
105+
## ensure no name clashes
106+
new_data_names <- colnames(new_data)
107+
intersection <- new_data_names %in% grid$newname
108+
if (any(intersection)) {
109+
rlang::abort(
110+
paste0("Name collision occured in `", class(object)[1],
111+
"`. The following variable names already exists: ",
112+
paste0(new_data_names[intersection], collapse = ", "),
113+
"."))
114+
}
115+
ok <- object$keys
116+
shifted <- purrr::reduce(
117+
purrr::pmap(grid, epi_shift_single, x = new_data, key_cols = ok),
118+
dplyr::full_join,
119+
by = ok
120+
)
121+
122+
dplyr::full_join(new_data, shifted, by = ok) %>%
123+
dplyr::group_by(dplyr::across(dplyr::all_of(ok[-1]))) %>%
124+
dplyr::arrange(time_value) %>%
125+
dplyr::ungroup()
126+
127+
}
128+
129+
#' @export
130+
print.step_epi_shift <-
131+
function(x, width = max(20, options()$width - 30), ...) {
132+
## TODO add printing of the shifts
133+
title <- ifelse(x$role == "predictor","Lagging ","Leading ") # Account for lag/lead
134+
recipes::print_step(x$columns, x$terms, x$trained, title, width)
135+
invisible(x)
136+
}

0 commit comments

Comments
 (0)