1#' Lift the domain of a function
2#'
3#' `lift_xy()` is a composition helper. It helps you compose
4#' functions by lifting their domain from a kind of input to another
5#' kind. The domain can be changed from and to a list (l), a vector
6#' (v) and dots (d). For example, `lift_ld(fun)` transforms a
7#' function taking a list to a function taking dots.
8#'
9#' The most important of those helpers is probably `lift_dl()`
10#' because it allows you to transform a regular function to one that
11#' takes a list. This is often essential for composition with purrr
12#' functional tools. Since this is such a common function,
13#' `lift()` is provided as an alias for that operation.
14#'
15#' @inheritParams as_vector
16#' @param ..f A function to lift.
17#' @param ... Default arguments for `..f`. These will be
18#'   evaluated only once, when the lifting factory is called.
19#' @return A function.
20#' @name lift
21#' @seealso [invoke()]
22NULL
23
24#' @rdname lift
25#' @section from ... to `list(...)` or `c(...)`:
26#'   Here dots should be taken here in a figurative way. The lifted
27#'   functions does not need to take dots per se. The function is
28#'   simply wrapped a function in [do.call()], so instead
29#'   of taking multiple arguments, it takes a single named list or
30#'   vector which will be interpreted as its arguments.  This is
31#'   particularly useful when you want to pass a row of a data frame
32#'   or a list to a function and don't want to manually pull it apart
33#'   in your function.
34#' @param .unnamed If `TRUE`, `ld` or `lv` will not
35#'   name the parameters in the lifted function signature. This
36#'   prevents matching of arguments by name and match by position
37#'   instead.
38#' @export
39#' @examples
40#' ### Lifting from ... to list(...) or c(...)
41#'
42#' x <- list(x = c(1:100, NA, 1000), na.rm = TRUE, trim = 0.9)
43#' lift_dl(mean)(x)
44#'
45#' # Or in a pipe:
46#' mean %>% lift_dl() %>% invoke(x)
47#'
48#' # You can also use the lift() alias for this common operation:
49#' lift(mean)(x)
50#'
51#' # Default arguments can also be specified directly in lift_dl()
52#' list(c(1:100, NA, 1000)) %>% lift_dl(mean, na.rm = TRUE)()
53#'
54#' # lift_dl() and lift_ld() are inverse of each other.
55#' # Here we transform sum() so that it takes a list
56#' fun <- sum %>% lift_dl()
57#' fun(list(3, NA, 4, na.rm = TRUE))
58#'
59#' # Now we transform it back to a variadic function
60#' fun2 <- fun %>% lift_ld()
61#' fun2(3, NA, 4, na.rm = TRUE)
62#'
63#' # It can sometimes be useful to make sure the lifted function's
64#' # signature has no named parameters, as would be the case for a
65#' # function taking only dots. The lifted function will take a list
66#' # or vector but will not match its arguments to the names of the
67#' # input. For instance, if you give a data frame as input to your
68#' # lifted function, the names of the columns are probably not
69#' # related to the function signature and should be discarded.
70#' lifted_identical <- lift_dl(identical, .unnamed = TRUE)
71#' mtcars[c(1, 1)] %>% lifted_identical()
72#' mtcars[c(1, 2)] %>% lifted_identical()
73lift <- function(..f, ..., .unnamed = FALSE) {
74  force(..f)
75  defaults <- list(...)
76  function(.x = list(), ...) {
77    if (.unnamed) {
78      .x <- unname(.x)
79    }
80    do.call("..f", c(.x, defaults, list(...)))
81  }
82}
83
84#' @rdname lift
85#' @export
86lift_dl <- lift
87
88#' @rdname lift
89#' @export
90lift_dv <- function(..f, ..., .unnamed = FALSE) {
91  force(..f)
92  defaults <- list(...)
93
94  function(.x, ...) {
95    if (.unnamed) {
96      .x <- unname(.x)
97    }
98    .x <- as.list(.x)
99    do.call("..f", c(.x, defaults, list(...)))
100  }
101}
102
103#' @rdname lift
104#' @section from `c(...)` to `list(...)` or `...`:
105#'   These factories allow a function taking a vector to take a list
106#'   or dots instead. The lifted function internally transforms its
107#'   inputs back to an atomic vector. purrr does not obey the usual R
108#'   casting rules (e.g., `c(1, "2")` produces a character
109#'   vector) and will produce an error if the types are not
110#'   compatible. Additionally, you can enforce a particular vector
111#'   type by supplying `.type`.
112#' @export
113#' @examples
114#' #
115#'
116#'
117#' ### Lifting from c(...) to list(...) or ...
118#'
119#' # In other situations we need the vector-valued function to take a
120#' # variable number of arguments as with pmap(). This is a job for
121#' # lift_vd():
122#' pmap(mtcars, lift_vd(mean))
123#'
124#' # lift_vd() will collect the arguments and concatenate them to a
125#' # vector before passing them to ..f. You can add a check to assert
126#' # the type of vector you expect:
127#' lift_vd(tolower, .type = character(1))("this", "is", "ok")
128lift_vl <- function(..f, ..., .type) {
129  force(..f)
130  defaults <- list(...)
131  if (missing(.type)) .type <- NULL
132
133  function(.x = list(), ...) {
134    x <- as_vector(.x, .type)
135    do.call("..f", c(list(x), defaults, list(...)))
136  }
137}
138
139#' @rdname lift
140#' @export
141lift_vd <- function(..f, ..., .type) {
142  force(..f)
143  defaults <- list(...)
144  if (missing(.type)) .type <- NULL
145
146  function(...) {
147    x <- as_vector(list(...), .type)
148    do.call("..f", c(list(x), defaults))
149  }
150}
151
152#' @rdname lift
153#' @section from list(...) to c(...) or ...:
154#' `lift_ld()` turns a function that takes a list into a
155#' function that takes dots. `lift_vd()` does the same with a
156#' function that takes an atomic vector. These factory functions are
157#' the inverse operations of `lift_dl()` and `lift_dv()`.
158#'
159#' `lift_vd()` internally coerces the inputs of `..f` to
160#' an atomic vector. The details of this coercion can be controlled
161#' with `.type`.
162#'
163#' @export
164#' @examples
165#' #
166#'
167#'
168#' ### Lifting from list(...) to c(...) or ...
169#'
170#' # cross() normally takes a list of elements and returns their
171#' # cartesian product. By lifting it you can supply the arguments as
172#' # if it was a function taking dots:
173#' cross_dots <- lift_ld(cross)
174#' out1 <- cross(list(a = 1:2, b = c("a", "b", "c")))
175#' out2 <- cross_dots(a = 1:2, b = c("a", "b", "c"))
176#' identical(out1, out2)
177#'
178#' # This kind of lifting is sometimes needed for function
179#' # composition. An example would be to use pmap() with a function
180#' # that takes a list. In the following, we use some() on each row of
181#' # a data frame to check they each contain at least one element
182#' # satisfying a condition:
183#' mtcars %>% pmap(lift_ld(some, partial(`<`, 200)))
184#'
185#' # Default arguments for ..f can be specified in the call to
186#' # lift_ld()
187#' lift_ld(cross, .filter = `==`)(1:3, 1:3) %>% str()
188#'
189#'
190#' # Here is another function taking a list and that we can update to
191#' # take a vector:
192#' glue <- function(l) {
193#'   if (!is.list(l)) stop("not a list")
194#'   l %>% invoke(paste, .)
195#' }
196#'
197#' \dontrun{
198#' letters %>% glue()           # fails because glue() expects a list}
199#'
200#' letters %>% lift_lv(glue)()  # succeeds
201lift_ld <- function(..f, ...) {
202  force(..f)
203  defaults <- list(...)
204  function(...) {
205    do.call("..f", c(list(list(...)), defaults))
206  }
207}
208
209#' @rdname lift
210#' @export
211lift_lv <- function(..f, ...) {
212  force(..f)
213  defaults <- list(...)
214  function(.x, ...) {
215    do.call("..f", c(list(as.list(.x)), defaults, list(...)))
216  }
217}
218