如何在 R 中编写递归 compose 函数？答案

【问题标题】：How can I write a recursive compose function in R?如何在 R 中编写递归 compose 函数？
【发布时间】：2018-09-23 05:07:16
【问题描述】：

我想在 R 中创建一个“compose”函数，它将组合任意数量的作为参数给出的函数。

到目前为止，我已经通过定义一个由两个参数组成的函数“of”然后对它进行归约来实现这一点：

of <- function(f,g) function(x) f(g(x))
id <- function(x) x

compose <- function(...) {
  argms = c(...)
  Reduce(of,argms,id)
}

这似乎工作正常，但由于我正在学习 R，我想我会尝试以明确的递归风格编写它，即放弃使用 Reduce，iow 那种你会在 Scheme 中做的事情像这样：

(define (compose . args)
  (if (null? args) identity
      ((car args) (apply compose (cdr args)))))

我遇到了许多障碍，目前主要的障碍似乎是参数的第一个元素没有被识别为函数。到目前为止我的弱尝试：

comp <- function(...) {
  argms <- list(...)
  len <- length(argms)
  if(len==0) { return(id) }
  else {
    (argms[1])(do.call(comp,argms[2:len])) 
  }
}

吐槽：Error in comp(sin, cos, tan) : attempt to apply non-function

一定有某种方法可以做到这一点，这让我望而却步。有什么建议吗？

【问题讨论】：

purrr 包包含另一个替代方案，它不使用 Reduce 或递归。由于您正在学习 R，它可能会为您的任务提供更多见解：github.com/tidyverse/purrr/blob/master/R/compose.R
@Artem Sokolov：这是一个有趣的实现——迭代和累积到一个可变变量中。有点像你说的我要求的（递归的，不可变的）完全相反，但仍然很好看，尤其是在学习时。感谢您不厌其烦地链接它！

标签： r functional-programming function-composition

【解决方案1】：

1)试试这个：

comp1 <- function(f, ...) {
  if (missing(f)) identity
  else function(x) f(comp1(...)(x))
}


# test

comp1(sin, cos, tan)(pi/4)
## [1] 0.5143953

# compose is defined in the question
compose(sin, cos, tan)(pi/4)
## [1] 0.5143953

functional::Compose(tan, cos, sin)(pi/4)
## [1] 0.5143953

sin(cos(tan(pi/4)))
## [1] 0.5143953

library(magrittr)
(pi/4) %>% tan %>% cos %>% sin
## [1] 0.5143953

(. %>% tan %>% cos %>% sin)(pi/4)
## [1] 0.5143953

1a) 使用Recall 的(1) 的变体是：

comp1a <- function(f, ...) {
  if (missing(f)) identity
  else {
    fun <- Recall(...)
    function(x) f(fun(x))
  }
}

comp1a(sin, cos, tan)(pi/4)
## [1] 0.5143953

2)这是另一个实现：

comp2 <- function(f, g, ...) {
  if (missing(f)) identity
  else if (missing(g)) f
  else Recall(function(x) f(g(x)), ...)
}

comp2(sin, cos, tan)(pi/4)
## [1] 0.5143953

3) 这个实现更接近问题中的代码。它利用了问题中定义的of：

comp3 <- function(...) {
  if(...length() == 0) identity
  else of(..1, do.call("comp3", list(...)[-1]))
}
comp3(sin, cos, tan)(pi/4)
## [1] 0.5143953

【讨论】：

我已删除注释。再看一遍，问题是Recall 不是直接在顶级函数中，而是在else 分支中定义的匿名函数中。
@ G.Grothendieck 太好了，谢谢，尽管我认为示例 (1) 比 (3) 更接近原始代码。我特别关注不必使用of，这基本上是一种解决方法。感谢您也包含示例（2），我花了一些时间来理解它，但帮助我准确地理解了 Recall 的作用。答案被接受为基本完整。
我认为你的意思是（1）最接近你正在寻找的东西。示例（3）更接近问题中提供的代码。它具有相同的签名并从中选择第一个元素和剩余元素，它使用of，它使用do.call，就像问题中的代码一样。

【解决方案2】：

一个问题是如果len==1，那么argms[2:len]返回一个长度为2的列表；特别是，

> identical(argms[2:1], list(NULL, argms[[1]]))
[1] TRUE

要解决此问题，您可以使用 argms[-1] 删除列表的第一个元素。

您还需要使用您的of 函数，因为您可能注意到sin(cos) 返回的是错误而不是函数。综上所述，我们得到：

comp <- function(...) {
  argms <- c(...)
  len <- length(argms)
  if(len==1) { return(of(argms[[1]], id)) }
  else {
    of(argms[[1]], comp(argms[-1]))
  }
}

> comp(sin, cos, tan)(1)
[1] 0.0133878
> compose(sin, cos, tan)(1)
[1] 0.0133878

【讨论】：

【解决方案3】：

滚动您自己的函数组合的另一种方法是使用gestalt 包，它提供组合作为高阶函数compose() 和中缀运算符%>>>%。（为了让它们读起来相同，函数是从从左到右组成的。）

基本用法很简单：

library(gestalt)

f <- compose(tan, cos, sin)  # apply tan, then cos, then sin
f(pi/4)
#> [1] 0.514395258524

g <- tan %>>>% cos %>>>% sin
g(pi/4)
#> [1] 0.514395258524

但是您可以获得很多额外的灵活性：

## You can annotate composite functions and apply list methods
f <- first: tan %>>>% cos %>>>% sin
f[[1]](pi/4)
#> [1] 1
f$first(pi/4)
#> [1] 1

## magrittr %>% semantics, such as implicity currying, is supported
scramble <- sample %>>>% paste(collapse = "")
set.seed(1); scramble(letters, 5)
#> [1] "gjnue"

## Compositions are list-like; you can inspect them using higher-order functions
stepwise <- lapply(`%>>>%`, print) %>>>% compose
stepwise(f)(pi/4)
#> [1] 1
#> [1] 0.540302305868
#> [1] 0.514395258524

## formals are preserved
identical(formals(scramble), formals(sample))
#> [1] TRUE

关于 R 中的函数调用，您应该记住的一件事是它们的成本不可忽略。与进行文字函数组合不同，compose()（和%>>>%）在调用时会展平组合。特别是，以下调用会产生相同的功能，操作上：

fs <- list(tan, cos, sin)

## compose(tan, cos, sin)
Reduce(compose, fs)
Reduce(`%>>>%`, fs)
compose(fs)
compose(!!!fs)  # tidyverse unquote-splicing

【讨论】：

【解决方案4】：

这是一个返回函数的解决方案，很容易理解

func <- function(f, ...){
  cl <- match.call()
  if(length(cl) == 2L)
    return(eval(bquote(function(...) .(cl[[2L]]))))

  le <- max(which(sapply(cl, inherits, "name")))
  if(le == length(cl)){
    tmp <- cl[le]
    tmp[[2L]] <- quote(...)
    cl[[length(cl)]] <- tmp

  } else if(le == length(cl) - 1L){
    tmp <- cl[le]
    tmp[[2L]] <- cl[[le + 1L]]
    cl[[le]] <- tmp
    cl[[le + 1L]] <- NULL

  } else
    stop("something is wrong...")

  eval(cl)
}

func(sin, cos, tan) # clear what the function does
#R function (...) 
#R sin(cos(tan(...)))
#R <environment: 0x000000001a189778>
func(sin, cos, tan)(pi/4) # gives correct value
#R [1] 0.5143953

可能需要将sapply(cl, inherits, "name") 行调整为更通用的内容...

【讨论】：

【解决方案5】：

这是一个通过调用构建函数的解决方案，它提供了类似于 Benjamin 的可读输出：

compose_explicit <- function(...){
  funs <- as.character(match.call()[-1])
  body <- Reduce(function(x,y) call(y,x), rev(funs), init = quote(x))
  eval.parent(call("function",as.pairlist(alist(x=)),body))
}
compose_explicit(sin, cos, tan)
# function (x) 
# sin(cos(tan(x)))

compose_explicit(sin, cos, tan)(pi/4)
# [1] 0.5143953

看起来很健壮：

compose_explicit()
# function (x) 
# x

compose_explicit(sin)
# function (x) 
# sin(x)

不相关但有用，这里是purrr:compose的代码：

#' Compose multiple functions
#'
#' @param ... n functions to apply in order from right to left.
#' @return A function
#' @export
#' @examples
#' not_null <- compose(`!`, is.null)
#' not_null(4)
#' not_null(NULL)
#'
#' add1 <- function(x) x + 1
#' compose(add1, add1)(8)
compose <- function(...) {
  fs <- lapply(list(...), match.fun)
  n <- length(fs)

  last <- fs[[n]]
  rest <- fs[-n]

  function(...) {
    out <- last(...)
    for (f in rev(rest)) {
      out <- f(out)
    }
    out
  }
}

【讨论】：