/
taylor.R
137 lines (119 loc) · 4.21 KB
/
taylor.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
#' Taylor Series Expansion
#'
#' Computes the Taylor series of \code{functions} or \code{characters}.
#'
#' @param f \code{character}, or \code{function} returning a \code{numeric} scalar value.
#' @param var vector giving the variable names with respect to which the derivatives are to be computed and/or the point where the derivatives are to be evaluated (the center of the Taylor series). See \code{\link{derivative}}.
#' @param params \code{list} of additional parameters passed to \code{f}.
#' @param order the order of the Taylor approximation.
#' @param accuracy degree of accuracy for numerical derivatives.
#' @param stepsize finite differences stepsize for numerical derivatives. It is based on the precision of the machine by default.
#' @param zero tolerance used for deciding which derivatives are zero. Absolute values less than this number are set to zero.
#'
#' @return \code{list} with components:
#' \describe{
#' \item{f}{the Taylor series.}
#' \item{order}{the approximation order.}
#' \item{terms}{\code{data.frame} containing the variables, coefficients and degrees of each term in the Taylor series.}
#' }
#'
#' @examples
#' ### univariate taylor series (in x=0)
#' taylor("exp(x)", var = "x", order = 2)
#'
#' ### univariate taylor series of user-defined functions (in x=0)
#' f <- function(x) exp(x)
#' taylor(f = f, var = c(x=0), order = 2)
#'
#' ### multivariate taylor series (in x=0 and y=1)
#' taylor("x*(y-1)", var = c(x=0, y=1), order = 4)
#'
#' ### multivariate taylor series of user-defined functions (in x=0 and y=1)
#' f <- function(x,y) x*(y-1)
#' taylor(f, var = c(x=0, y=1), order = 4)
#'
#' ### vectorized interface
#' f <- function(x) prod(x)
#' taylor(f, var = c(0,0,0), order = 3)
#'
#' @family polynomials
#' @family derivatives
#'
#' @references
#' Guidotti E (2022). "calculus: High-Dimensional Numerical and Symbolic Calculus in R." Journal of Statistical Software, 104(5), 1-37. \doi{10.18637/jss.v104.i05}
#'
#' @export
#'
taylor <- function(f, var, params = list(), order = 1, accuracy = 4, stepsize = NULL, zero = 1e-7){
# init
cache <- list()
n.v <- length(var)
is.fun <- is.function(f)
# parse
if(is.character(f))
f <- parse(text = f)
# prepare envir to extract coefficients
is.vectorized <- FALSE
if(is.null(names(var))){
if(is.character(var)){
x0 <- rep(0, n.v)
names(x0) <- var
x0 <- as.list(x0)
}
else {
x0 <- var
var <- paste0("x", 1:n.v)
names(x0) <- var
x0 <- as.list(x0)
is.vectorized <- TRUE
}
}
else {
x0 <- as.list(var)
var <- names(var)
}
# coef indexes
nu <- partitions(n = order, length = n.v, fill = TRUE, perm = TRUE, equal = FALSE)
# taylor
for(n in 1:ncol(nu)){
v <- nu[,n]
c <- list(degree = sum(v))
if(!is.fun){
prev <- 1
expr <- f
if(length(cache)>0){
prev <- which(apply(v - nu, 2, function(x) sum(x)==1 & all(x>=0)))[[1]]
expr <- cache[[prev]]$expr
}
c$expr <- derivative(f = expr, var = var, params = params, order = v - nu[,prev], deparse = FALSE)
c$coef <- eval(c$expr, envir = c(x0, params))/prod(factorial(v))
}
else {
x <- unlist(x0)
if(is.vectorized)
names(x) <- NULL
c$coef <- D.num(f = f, x0 = x, params = params, order = v, accuracy = accuracy, stepsize = stepsize, zero = zero, drop = TRUE)
c$coef <- c$coef/prod(factorial(v))
}
idx <- which(v>0)
if(length(idx)==0) {
c$var <- 1
}
else {
vv <- var[idx]
cc <- x0[vv]!=0
if(any(cc)) vv[cc] <- sprintf("(%s-%s)", vv[cc], x0[vv][cc])
c$var <- paste0(vv, "^", v[idx], collapse = "*")
}
cache[[paste(v, collapse = ',')]] <- c
}
# terms
terms <- data.frame(var = sapply(cache, function(x) x$var),
coef = sapply(cache, function(x) x$coef),
degree = sapply(cache, function(x) x$degree),
row.names = names(cache), stringsAsFactors = FALSE)
# taylor series
f <- cpp_collapse(cpp_paste(as.character(wrap(terms$coef)), as.character(terms$var), sep = " * "), sep = " + ")
# return
return(list(f = f, order = order, terms = terms))
}