#' Modify data with a lens
#'
#' Set the subcomponent of the data referred to by a lens
#' with a new value. See [lens] for details. Merely dispatches
#' to the `set` component of the lens.
#'
#' @param d the data, or an [oscope]
#' @param l the lens, or in the case of an `oscope`, the replacement
#' @param x the replacement value, or nothing in the case of an `oscope`
#' @export
set <- function(d,l,x) UseMethod("set", d)
#' @method set default
#' @export
set.default <- function(d, l, x){
if(!inherits(l,"lens"))
stop("second argument of set must be a lens")
if(attr(l, "getter"))
stop("can't set into a `getter` lens")
l$set(d, x)
}
#' @method set oscope
#' @export
set.oscope <- function(d,l,x){
if(!missing("x"))
stop("Argument `x` cannot be used with `set` and an `oscope`")
set(d$data, d$lens, l)
}
#' View data with a lens
#'
#' Get the subcomponent of the data referred to by a lens. This function
#' merely dispatches to the `view` component of the lens.
#'
#' @param d the data
#' @param l the lens
#' @export
view <- function(d, l) UseMethod("view")
#' @method view default
#' @export
view.default <- function(d, l){
if(!inherits(l, "lens"))
stop("view is only defined for lenses")
l$view(d)
}
#' @method view oscope
#' @export
view.oscope <- function(d, l){
if(!missing("l"))
stop("Argument `l` cannot be used with `view` and an `oscope`")
view(d$data, d$lens)
}
#' Compose lenses
#'
#' Compose two lenses to produce a new lens which represents
#' focussing first with the first lens, then with the second.
#' A `view` using the resulting composite lens will first `view` using
#' the first, then the second, while an `set` will `view` via the first lens,
#' `set` into the resulting piece with the second, and then replace the
#' updated structure in the first with `set`. Lens composition
#' is analogous to the `.` syntax of object-oriented programming or to
#' a flipped version of function composition.
#'
#' @rdname lens-compose
#' @param l the first [lens] (or an [oscope])
#' @param m the second lens
#' @examples
#' lst <- list(b = c(3,4,5))
#' lns <- index_l("b") %.% index_l(2)
#' lst %>% view(lns) # returns 4
#' lst %>% set(lns, 1) # returns list(b = c(3,2,5))
#' lst # returns list(b = c(3,4,5))
#' @export
`%.%` <- function(l, m) UseMethod("%.%")
#' @method "%.%" lens
#' @export
`%.%.lens` <- function(l, m){
if(!inherits(m, "lens"))
stop("the second argument of lens composition must be a lens")
getter <- attr(l, "getter") || attr(m, "getter")
lens(function(d) m$view(l$view(d))
, set = function(d, x){
l$set(d, m$set(l$view(d), x))
}
, getter = getter)
}
#' @method "%.%" oscope
#' @export
`%.%.oscope` <- function(l, m){
if(!inherits(m, "lens"))
stop("the second argument of lens composition must be a lens")
oscope(l$data, l$lens %.% m)
}
#' Map a function over a lens
#'
#' Get the data pointed to by a lens, apply a function
#' and replace it with the result.
#'
#' @param d the data (or an [oscope])
#' @param l the lens (or the function if `d` is an `oscope`)
#' @param f the function (or nothing if `d` is an `oscope`)
#' @examples
#' third_l <- index(3)
#' over(1:5, third_l, function(x) x + 2)
#' # returns c(1:2, 5, 4:5)
#' @export
over <- function(d, l, f) UseMethod("over")
#' @method over default
#' @export
over.default <- function(d, l, f){
f <- as_closure(f)
set(d, l, f(view(d, l)))
}
#' @method over oscope
#' @export
over.oscope <- function(d, l, f){
if(!missing("f"))
stop("Argument `f` cannot be used with `over` and an `oscope`")
over(d$data, d$lens, l)
}
#' Map a function over a list lens
#'
#' Apply the specified function to each element
#' of the subobject.
#'
#' @param d the data
#' @param l the lens
#' @param f the function to use, potentially a `~` specified anonymous function.
#' @export
over_map <- function(d, l, f){
f <- as_closure(f)
sd <- view(d, l)
if(!is.list(sd))
stop("`over_map` can only be used with lenses returning a list")
set(d, l, lapply(sd, f))
}
#' Map a function over an in scope lens
#'
#' Apply the specified function with named elements of
#' the viewed data in scope. Similar to [dplyr::mutate]
#'
#' @param d the data
#' @param l the lens
#' @param f the function to use, potentially a `~` specified anonymous function.
#' The function body is quoted, and evaluated with `rlang::eval_tidy(..., data = view(d,l))`
#' @examples
#' iris %>% over_with(id_l, ~ Sepal.Length)
#' @export
over_with <- function(d, l, f){
f <- as_closure(f)
body(f) <- bquote(rlang::eval_tidy(quote(.(body(f))), data = .(view(d,l))))
set(d, l, f(view(d,l)))
}
#' Set one lens to the view of another
#'
#' @param d the data
#' @param l the lens to view through
#' @param m the lens to set into
#' @export
send <- function(d, l, m){
m$set(d, l$view(d))
}
#' Set one lens to the view of another (transformed)
#'
#' @param d the data
#' @param f the function to apply to the viewed data
#' @param l the lens to view through
#' @param m the lens to set into
#' @export
send_over <- function(d, l, m, f){
f <- as_closure(f)
m$set(d, f(l$view(d)))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.