-
Notifications
You must be signed in to change notification settings - Fork 0
/
vap.R
151 lines (132 loc) Β· 3.58 KB
/
vap.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
#' vap: Vector apply functions
#'
#' Functions that apply expressions to input objects and return atomic vectors
#' e.g., numeric (double), integer, character, logical.
#'
#' @name vap
#' @family vap
#' @seealso \code{\link{lap}} \code{\link{dap}}
NULL
#' Vector apply double
#'
#' vap_dbl: Iterate over input and return double(s)
#'
#' @param .data Input objectβnumeric, character, list, data frame, etc.βover
#' which elements will be iterated. If matrix or data frame, each
#' column will be treated as an element.
#' @param .f Action to apply to each element of \code{.data}. The action can be
#' articulated in one of the four following ways:
#' \enumerate{
#' \item supplying a function object (e.g., \code{mean})
#' \item defining a function (in-line; e.g., \code{function(x) mean(x)})
#' \item specifying a formula-like call where '.x' is assumed to be the iterated
#' over element of \code{.data} (e.g., \code{~ mean(.x)})
#' \item providing a name or position of \code{.data} to return (e.g.,
#' \code{1}, \code{"varname"}, etc.)
#' }
#' @return A double vector
#' @export
#' @examples
#'
#' ## character
#' vap_chr(letters, ~ paste0(.x, "."))
#'
#' ## double
#' vap_dbl(rnorm(4), round, 3)
#'
#' ## logical
#' vap_lgl(letters, ~ .x %in% c("a", "e", "i", "o", "u"))
#'
#' ## integer
#' vap_int(as.data.frame(replicate(10, sample(1:10))), 8)
#'
#' @rdname vap
vap_dbl <- function(.data, .f, ...) UseMethod("vap_dbl")
#' @export
vap_dbl.default <- function(.data, .f, ...) {
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
vapply(.data,
function(.x) eval(.f, list(.x = .x), e),
FUN.VALUE = numeric(1))
} else if (is.atomic(.f)) {
as.numeric(getElement(.data, .f))
} else {
vapply(.data, .f, ...,
FUN.VALUE = numeric(1))
}
}
#' Vector apply character
#'
#' vap_chr: Iterate over input and return character(s)
#'
#' @inheritParams vap_dbl
#' @return A character vector
#' @param ... Other values passed to function call.
#' @export
#' @rdname vap
vap_chr <- function(.data, .f, ...) UseMethod("vap_chr")
#' @export
vap_chr.default <- function(.data, .f, ...) {
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
vapply(.data,
function(.x) eval(.f, list(.x = .x), e),
FUN.VALUE = character(1))
} else if (is.atomic(.f)) {
as.character(getElement(.data, .f))
} else {
vapply(.data, .f, ...,
FUN.VALUE = character(1))
}
}
#' Vector apply logical
#'
#' vap_lgl: Iterate over input and return logical(s)
#'
#' @inheritParams vap_dbl
#' @return A logical vector
#' @export
#' @rdname vap
vap_lgl <- function(.data, .f, ...) UseMethod("vap_lgl")
#' @export
vap_lgl.default <- function(.data, .f, ...) {
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
vapply(.data,
function(.x) eval(.f, list(.x = .x), e),
FUN.VALUE = logical(1))
} else if (is.atomic(.f)) {
as.logical(getElement(.data, .f))
} else {
vapply(.data, .f, ...,
FUN.VALUE = logical(1))
}
}
#' Vector apply integer
#'
#' vap_int: Iterate over input and return integer(s)
#'
#' @inheritParams vap_dbl
#' @return An integer vector
#' @export
#' @rdname vap
vap_int <- function(.data, .f, ...) UseMethod("vap_int")
#' @export
vap_int.default <- function(.data, .f, ...) {
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
vapply(.data,
function(.x) eval(.f, list(.x = .x), e),
FUN.VALUE = integer(1))
} else if (is.atomic(.f)) {
as.integer(getElement(.data, .f))
} else {
vapply(.data, .f, ...,
FUN.VALUE = integer(1))
}
}