-
Notifications
You must be signed in to change notification settings - Fork 0
/
dap.R
153 lines (135 loc) Β· 4.14 KB
/
dap.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
#' dap: Data frame apply functions
#'
#' Functions that apply expressions to input data objects and return data
#' frames.
#'
#' @name dap
#' @seealso \code{\link{lap}} \code{\link{vap}}
NULL
#' Data frame apply functions
#'
#' dapc: Apply function to columns of a data frame.
#'
#' @param .data Data frame input.
#' @param .f Function to apply to element (columns or rows). 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 data frame
#' @family dap
#' @export
#' @rdname dap
dapc <- function(.data, .f, ...) UseMethod("dapc")
#' @export
dapc.default <- function(.data, .f, ...) {
assert_that(is_vector(.data))
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
.data[] <- lapply(.data, function(.x) {
eval(.f, list(.x = .x), e)
})
} else {
.data[] <- lapply(.data, .f, ...)
}
.data
}
#' @rdname dap
#' @description dapr: Apply function to rows of a data frame.
#' @family dap
#' @export
dapr <- function(.data, .f, ...) UseMethod("dapr")
#' @export
dapr.default <- function(.data, .f, ...) {
assert_that(is_vector(.data))
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
.data[seq_len(nrow(.data)), ] <- t(apply(.data, 1,
function(.x) eval(.f, list(.x = .x), e)
))
} else {
.data[seq_len(nrow(.data)), ] <- t(apply(.data, 1, .f, ...))
}
.data
}
#' @rdname dap
#' @description dapc_if: Apply function to certain columns of a data frame.
#' @inheritParams dap
#' @param .predicate Logical vector or expression evaluating to a logical vector.
#' If not a logical vector, this can be written as a single function name
#' e.g., \code{is.numeric}, a formula-like function call where '.x' is assumed
#' to be the iterated over element of input data e.g.,
#' \code{~ is.numeric(.x)}, or an in-line function definition e.g.,
#' \code{function(x) is.numeric(x)}. Regardless, if a logical vector is not
#' provided, this expression must return a logical vector of the same length
#' as the input .data object.
#'
#' The resulting logical vector is used to determine which elements (rows or
#' columns) to iterate over with the .f function/expression.
#' @family dap
#' @export
dapc_if <- function(.data, .predicate, .f, ...) UseMethod("dapc_if")
#' @export
dapc_if.default <- function(.data, .predicate, .f, ...) {
assert_that(is_vector(.data))
if (is.logical(.predicate)) {
lg <- .predicate
} else if (is_lang(.predicate)) {
e <- call_env()
.predicate <- eval(.predicate, envir = e)[[2]]
lg <- vapply(.data,
function(.x) eval(.predicate, list(.x = .x), e),
FUN.VALUE = logical(1))
} else {
lg <- vapply(.data, .predicate,
FUN.VALUE = logical(1))
}
assert_that(is.logical(lg))
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
.data[lg] <- lapply(.data[lg],
function(.x) eval(.f, list(.x = .x), e)
)
} else {
.data[lg] <- lapply(.data[lg], .f, ...)
}
.data
}
#' @rdname dap
#' @description dapr_if: Apply function to certain rows of a data frame.
#' @inheritParams dap
#' @family dap
#' @export
dapr_if <- function(.data, .predicate, .f, ...) UseMethod("dapr_if")
#' @export
dapr_if.default <- function(.data, .predicate, .f, ...) {
assert_that(is_vector(.data))
if (is.logical(.predicate)) {
lg <- .predicate
} else if (is_lang(.predicate)) {
e <- call_env()
.predicate <- eval(.predicate, envir = e)[[2]]
lg <- unlist(apply(.data, 1,
function(.x) eval(.predicate, list(.x = .x), e)
))
} else {
lg <- vapply(.data, .predicate,
FUN.VALUE = logical(1))
}
assert_that(is.logical(lg))
if (sum(lg) == 0) return(.data)
if (is_lang(.f)) {
e <- call_env()
.f <- eval(.f, envir = e)[[2]]
.data[lg, ] <- t(apply(.data[lg, ], 1,
function(.x) eval(.f, list(.x = .x), e)
))
} else {
.data[lg, ] <- t(apply(.data[lg, ], 1, .f, ...))
}
.data
}