-
Notifications
You must be signed in to change notification settings - Fork 0
/
lap.R
127 lines (117 loc) Β· 3.12 KB
/
lap.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
#' lap: List apply functions
#'
#' Function(s) that apply expressions to input data objects and return lists.
#'
#' @name lap
#' @seealso \code{\link{dap}} \code{\link{vap}}
NULL
#' List apply
#'
#' lap: Iterate over input and return list(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 the elements which are to be iterated over.
#' @param .f Function to apply to each element of input object. This can be
#' written as a single function name e.g., \code{mean}, a formula-like
#' function call where '.x' is assumed to be the iterated over element of
#' input data e.g., \code{~ mean(.x)}, or an in-line function definition e.g.,
#' \code{function(x) mean(x)}.
#' @param ... Other values passed to function call.
#' @return A list
#' @family lap
#' @examples
#'
#' ## return string list
#' lap(letters, ~ paste0(.x, "."))
#'
#' ## return list of columns
#' lap(mtcars[1:5, ], as.character)
#'
#' ## map over two vectors
#' lap2(letters, LETTERS, ~ paste0(.x, .y, .x, .y))
#'
#' @export
lap <- function(.data, .f, ...) UseMethod("lap")
#' @export
lap.default <- function(.data, .f, ...) {
assert_that(is_vector(.data))
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
lapply(.data, function(.x) {
eval(.f, list(.x = .x), e)
})
} else {
lapply(.data, .f, ...)
}
}
#' List apply-to-row
#'
#' lapr: Iterate over input rows and return list(s)
#'
#' @rdname lap
#' @inheritParams lap
#' @export
lapr <- function(.data, .f, ...) {
assert_that(is_2d(.data))
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
lapply(seq_len(nrow(.data)), function(.i) {
eval(.f, list(.x = .data[.i, , drop = FALSE]), e)
})
} else {
lapply(seq_len(nrow(.data)), function(.i) {
.f(.data[.i, , drop = FALSE], ...)
})
}
}
#' List apply-to-column
#'
#' lapr: Iterate over input columbs and return list(s)
#'
#' @rdname lap
#' @inheritParams lap
#' @export
lapc <- function(.data, .f, ...) {
assert_that(is_2d(.data))
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
lapply(seq_len(ncol(.data)), function(.i) {
eval(.f, list(.x = .data[, .i, drop = FALSE]), e)
})
} else {
lapply(seq_len(ncol(.data)), function(.i) {
.f(.data[, .i, drop = FALSE], ...)
})
}
}
#' @rdname lap
#' @inheritParams lap
#' @param .x First data vector input (for lap2)
#' @param .y Second data vector input (for lap2)
#' @export
lap2 <- function(.x, .y, .f, ...) UseMethod("lap2")
#' @export
lap2.default <- function(.x, .y, .f, ...) {
assert_that(is_vector(.x))
assert_that(is_vector(.y))
assert_that(length(.x) == length(.y))
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
# .f <- as.call(.f)
# tfse::cat_line(class(.f))
# tfse::cat_line(deparse(.f))
# mapply(
# .f, .x, .y, SIMPLIFY = FALSE
# )
lapply(seq_along(.x), function(.i) {
eval(.f, list(.x = .x[[.i]], .y = .y[[.i]]), e)
})
} else {
mapply(.f, .x, .y, ..., SIMPLIFY = FALSE)
}
}