-
Notifications
You must be signed in to change notification settings - Fork 1
/
select_strings.R
212 lines (193 loc) · 7.18 KB
/
select_strings.R
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
202
203
204
205
206
207
208
209
210
211
212
#' Select string parts or patterns of column names
#'
#' @description
#'
#' These functions are [selection helpers][selection_helpers].
#' They are intended to be used inside `over()` to extract parts or patterns of
#' the column names of the underlying data.
#'
#' * [cut_names()] selects strings by removing (cutting off) the specified `.pattern`.
#' This functionality resembles `stringr::str_remove_all()`.
#'
#' * [extract_names()] selects strings by extracting the specified `.pattern`.
#' This functionality resembles `stringr::str_extract()`.
#'
#' @param .pattern Pattern to look for.
#' @param .vars A character vector with variables names. When used inside `over`
#' all column names of the underlying data are automatically supplied to `.vars`.
#' This argument is useful when testing the functionality outside the context of
#' `over()`.
#' @param .remove Pattern to remove from the variable names provided in `.vars`.
#' When this argument is provided, all variables names in `.vars` that match
#' the pattern specified in `.remove` will be removed, before the `.pattern` to
#' look for will be applied.
#'
#' @return
#' A character vector.
#'
#' @section Examples:
#'
#' ```{r, child = "man/rmd/setup.Rmd"}
#' ```
#'
#' Selection helpers can be used inside `dplyover::over()` which in turn must be
#' used inside `dplyr::mutate` or `dplyr::summarise`. Let's first attach `dplyr`
#' (and `stringr` for comparision):
#'
#' ```{r, comment = "#>", collapse = TRUE}
#' library(dplyr)
#' library(stringr)
#'
#' # For better printing
#' iris <- as_tibble(iris)
#' ```
#'
#' Let's first compare `cut_names()` and `extract_names()` to their {stringr}
#' equivalents `stringr::str_remove_all()` and `stringr::str_extract()`:
#'
#' We can observe two main differences:
#'
#' (1) `cut_names()` and `extract_names()` only return strings where the function
#' was applied successfully (when characters have actually been removed or
#' extracted). `stringr::str_remove_all()` returns unmatched strings as is, while
#' `stringr::str_extract()` returns `NA`.
#'
#' ```{r, comment = "#>", collapse = TRUE}
#' cut_names("Width", .vars = names(iris))
#' str_remove_all(names(iris), "Width")
#'
#' extract_names("Length|Width", .vars = names(iris))
#' str_extract(rep(names(iris), 2), "Length|Width")
#' ```
#'
#' (2) `cut_names()` and `extract_names()` return only unique values:
#'
#' ```{r, comment = "#>", collapse = TRUE}
#' cut_names("Width", .vars = rep(names(iris), 2))
#' str_remove_all(rep(names(iris), 2), "Width")
#'
#' extract_names("Length|Width", .vars = names(iris))
#' str_extract(rep(names(iris), 2), "Length|Width")
#' ```
#'
#' The examples above do not show that `cut_names()` removes *all* strings matching
#' the `.pattern` argument, while `extract_names()` does only extract the `.pattern`
#' *one* time:
#'
#' ```{r, comment = "#>", collapse = TRUE}
#' cut_names("Width", .vars = "Width.Petal.Width")
#' str_remove_all("Width.Petal.Width", "Width")
#'
#' extract_names("Width", .vars = "Width.Petal.Width")
#' str_extract("Width.Petal.Width", "Width")
#' ```
#'
#' Within [`over()`] `cut_names()` and `extract_names()` automatically use the
#' column names of the underlying data:
#'
#' ```{r, comment = "#>", collapse = TRUE}
#' iris %>%
#' mutate(over(cut_names(".Width"),
#' ~ .("{.x}.Width") * .("{.x}.Length"),
#' .names = "Product_{x}"))
#'
#' iris %>%
#' mutate(over(extract_names("Length|Width"),
#' ~.("Petal.{.x}") * .("Sepal.{.x}"),
#' .names = "Product_{x}"))
#' ```
#'
#' What problem does `cut_names()` solve?
#' In the example above using `cut_names()` might not seem helpful, since we could easily
#' use `c("Sepal", "Petal")` instead. However, there are cases where we have
#' data with a lot of similar pairs of variables sharing a common prefix or
#' suffix. If we want to loop over them using `over()` then `cut_names()` comes
#' in handy.
#'
#' The usage of `extract_names()` might be less obvious. Lets look at raw data
#' from a customer satifsaction survey which contains the following variables.
#'
#' ```{r, comment = "#>", collapse = TRUE}
#' csatraw %>% glimpse(width = 50)
#' ```
#'
#' The survey has several 'item's consisting of two sub-questions / variables 'a'
#' and 'b'. Lets say we want to calculate the product of those two variables for
#' each item. `extract_names()` helps us to select all variables containing
#' 'item' followed by a digit using the regex `"item\\d"` as `.pattern`.
#' However, there is 'item1' and 'item1_open' which are not followed by `a` and
#' `b`. `extract_names()` lets us exclude these items by setting the `.remove`
#' argument to `[^item1]`:
#'
#' ```{r, comment = "#>", collapse = TRUE}
#' csatraw %>%
#' transmute(over(extract_names("item\\d", "^item1"),
#' ~ .("{.x}a") * .("{.x}b"))
#' )
#' ```
#' @name select_vars
NULL
#' @rdname select_vars
#' @export
cut_names <- function(.pattern, .remove = NULL, .vars = NULL) {
.varn <- .vars
if (is.null(.vars) && sys.call(sys.nframe() - 2)[[1]] == "meta_setup") {
.varn <- names(dplyr::cur_data_all())
}
if (is.null(.remove)) {
.selected <- .varn
} else {
.notselected <- grep(.remove, .varn, perl = TRUE, value = TRUE)
if (length(.notselected) == 0) {
rlang::abort(
c("Problem with `cut_names()` input `.remove`.",
i = paste0("The character string provided in `.remove` ('",
.remove, "') must at least match one ",
ifelse(is.null(.vars), "column name.", "element in `.vars`.")),
x = "No match was found."))
}
.selected <- setdiff(.varn, .notselected)
}
.match <- grepl(.pattern, .selected, perl = TRUE)
.extract <- gsub(.pattern, "", .selected, perl = TRUE)[.match]
if (length(.extract) == 0) {
rlang::abort(
c("Problem with `cut_names()` input `.pattern`.",
i = paste0("The character string provided in `.pattern` ('",
.pattern, "') must at least return one match."),
x = "No match was found."))
}
unique(.extract[nchar(.extract) > 0])
}
#' @rdname select_vars
#' @export
extract_names <- function(.pattern, .remove = NULL, .vars = NULL) {
.varn <- .vars
if (is.null(.vars) && sys.call(sys.nframe() - 2)[[1]] == "meta_setup") {
.varn <- names(dplyr::cur_data_all())
}
if (is.null(.remove)) {
.selected <- .varn
} else {
.notselected <- grep(.remove, .varn, perl = TRUE, value = TRUE)
if (length(.notselected) == 0) {
rlang::abort(
c("Problem with `extract_names()` input `.remove`.",
i = paste0("The character string provided in `.remove` ('",
.remove, "') must at least match one ",
ifelse(is.null(.vars), "column name.", "element in `.vars`.")),
x = "No match was found."))
}
.selected <- setdiff(.varn, .notselected)
}
.extract <- regexpr(.pattern, .selected, perl = TRUE)
.res <- regmatches(.selected, .extract)
if (length(.res) == 0) {
rlang::abort(
c("Problem with `extract_names()` input `.pattern`.",
i = paste0("The character string provided in `.pattern` ('",
.pattern, "') must at least return one match."),
x = "No match was found."))
}
unique(.res)
}