Как я могу написать рекурсивную функцию компоновки в R?

Я хотел бы создать функцию "compose" в R, которая будет составлять произвольное количество функций, заданных в качестве аргументов.

До сих пор я достиг этого, определяя функцию "из", которая состоит из двух аргументов, а затем Сокращение:

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

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

Кажется, что это работает нормально, но поскольку я изучаю R, я думал, что попытаюсь записать его в явном рекурсивном стиле, то есть отказаться от использования Reduce, то, что вы делаете в 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

Должен быть какой-то способ сделать это, что ускользает от меня. Какие-либо предложения?

Ответы

Ответ 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) Вариант (1), который использует Recall:

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

Ответ 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

Альтернативой катите вашу собственную функциональную композицию является использование пакета гештальт, который обеспечивает композицию как функцию более высокого порядка, 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
  }
}