Deriv/0000755000176200001440000000000015025276042011326 5ustar liggesusersDeriv/tests/0000755000176200001440000000000013745525152012476 5ustar liggesusersDeriv/tests/testthat/0000755000176200001440000000000014671052064014332 5ustar liggesusersDeriv/tests/testthat/test_Simplify.R0000644000176200001440000001047713745525152017325 0ustar liggesuserscontext("Symbolic simplifications") lc_orig=Sys.getlocale(category = "LC_COLLATE") Sys.setlocale(category = "LC_COLLATE", locale = "C") expect_equal_lang=function(t, r) { test=substitute(t) right=substitute(r) ans=Simplify(as.expression(test))[[1]] #print(deparse(ans)) eval(bquote(expect_equal(format1(quote(.(ans))), format1(quote(.(right)))))) } test_that("rational simplifications", { expect_equal_lang(a*b, a*b) # no change must occur expect_equal_lang(a/2, a/2) # no change must occur expect_equal_lang(a*2, 2*a) # numeric first expect_equal_lang(a/a, 1) # complete single simplification expect_equal_lang(2/2, 1) # complete single numeric simplification expect_equal_lang(a*b/(b*a), 1) # complete multiple simplification expect_equal_lang(a/(b*a^x), a^(1 - x)/b) # diff numeric - symbol expect_equal_lang(a^x/(b*a), a^(x - 1)/b) # diff symbol - numeric expect_equal_lang(a/(b*a), 1/b) # single simplification in denominator expect_equal_lang(-a/(b*a), -(1/b)) # single negative simplification in denominator expect_equal_lang(2/(b*2), 1/b) # single numeric simplification in denominator expect_equal_lang(-2/(b*2), -(1/b)) # single negative numeric simplification in denominator expect_equal_lang((a*b)/b, a) # single simplification in numerator expect_equal_lang((a*b)/-b, -a) # single simplification in numerator expect_equal_lang((a*2)/2, a) # single numeric simplification in numerator expect_equal_lang((a*2)/-2, -a) # single negative numeric simplification in numerator expect_equal_lang(a*c/(c*b*a), 1/b) # multiple simplification (denominator) expect_equal_lang(a*-c/(c*b*a), -(1/b)) # multiple negative simplification (denominator) expect_equal_lang((a*c*b)/(c*a), b) # multiple simplification (numerator) expect_equal_lang((-a*c*b)/(c*a), -b) # multiple negative simplification (numerator) }) test_that("log simplifications", { expect_equal_lang(log(a), log(a)) # no change must occur expect_equal_lang(log(a*b), log(a)+log(b)) expect_equal_lang(log(exp(a)), a) expect_equal_lang(log(a^n), n*log(a)) expect_equal_lang(log(sqrt(a)), 0.5*log(a)) expect_equal_lang(log(1+x), log1p(x)) }) test_that("sqrt simplifications", { expect_equal_lang(sqrt(a), sqrt(a)) # no change must occur expect_equal_lang(sqrt(a*a), abs(a)) expect_equal_lang(sqrt(a^4), a^2) expect_equal_lang(sqrt(exp(a)), exp(a/2)) expect_equal_lang(sqrt(a^n), abs(a)^(n/2)) expect_equal_lang(sqrt(sqrt(a)),a^0.25) }) test_that("abs simplifications", { expect_equal_lang(abs(a), abs(a)) # no change must occur expect_equal_lang(abs(a*a), a^2) }) test_that("factorizations", { expect_equal_lang(a+b, a+b) # no change must occur expect_equal_lang(3-5*x, 3-5*x) # no change must occur expect_equal_lang(a*a+b*a, a*(a+b)) expect_equal_lang(a^2+b*a^3, a^2*(1+a*b)) expect_equal_lang(a^2/c**5+b*a^3/d/c**3, a^2*(1/c^2+a*b/d)/c^3) expect_equal_lang(a+1-a, 1) expect_equal_lang(1+x-1, x) }) test_that("term order", { expect_equal_lang(a(1+x)+a(x-1), a(1+x)+a(x-1)) # no change must occur expect_equal_lang(a(x-1)+a(x+1), a(1+x)+a(x-1)) # "+" is before "-" in C collate. It is inverse in fr_FR.UTF8 expect_equal_lang(1+a, 1+a) # no change must occur expect_equal_lang(a+1, 1+a) }) test_that("{...}", { expect_equal_lang({a=x^2; 0}, 0) expect_equal_lang(2*{x}, 2*x) }) test_that("indexing", { expect_equal_lang(list(a=x, b=y)$a, x) expect_equal_lang(c(a=x, b=y)[["a"]], x) expect_equal_lang(0$a, 0) }) test_that("logical operation", { expect_equal_lang(a || TRUE, TRUE) expect_equal_lang(a || FALSE, a) expect_equal_lang(a && TRUE, a) expect_equal_lang(a && FALSE, FALSE) }) test_that("missing args", { expect_equal_lang(f(a,b,), f(a,b)) expect_equal_lang(f(a,c=,b), f(a,c=,b)) # no change must occur }) context("expression caching") test_that("Cache test", { expect_equal(Cache(quote(c(a+b, sin(a+b)))), quote({ .e1 <- a + b c(.e1, sin(.e1)) } )) expect_equal(Cache(quote({t=a+b; c(a+b, sin(a+b))})), quote({ t = a + b c(t, sin(t)) } )) expect_equal(Cache(Simplify(deCache(quote({t=a+b; c(a+b, sin(a+b))})))), quote({ .e1 <- a + b c(.e1, sin(.e1)) } )) expect_equal(Cache(quote({a=x^2; b=x^2})), quote({ a = x^2 b = a } )) }) Sys.setlocale(category = "LC_COLLATE", locale = lc_orig) Deriv/tests/testthat/test_Deriv.R0000644000176200001440000004101514671052055016566 0ustar liggesuserscontext(paste("Symbolic differentiation rules v", packageVersion("Deriv"), sep="")) lc_orig=Sys.getlocale(category = "LC_COLLATE") Sys.setlocale(category = "LC_COLLATE", locale = "C") num_test_deriv <- function(fun, larg, narg, h=1.e-5, tolerance=2000*h^2) { # test the first derivative of a function fun() (given as a character # string) by Deriv() and central difference. # larg is a named list of parameters to pass to fun # narg indicates the argument name by which the differentiation must be made # h is the small perturbation in the central differentiation: x-h and x+h # Parameter tolerance is used in comparison test. if (length(names(larg)) == 0) stop(sprintf("No argument for function %s() to differentiate. There must be at leat one argument.", fun)) if (h <= 0) stop("Parameter h must be positive") larg_ph=larg_mh=larg larg_ph[[narg]]=larg_ph[[narg]]+h larg_mh[[narg]]=larg_mh[[narg]]-h f_ph=do.call(fun, larg_ph) f_mh=do.call(fun, larg_mh) dnum=(f_ph-f_mh)/(2*h) sym_larg=larg sym_larg[[narg]]=as.symbol(narg) flang=as.symbol(fun) dsym=try(do.call(as.function(c(sym_larg, list(Deriv(as.call(c(flang, sym_larg)), narg)))), larg, quote=TRUE)) if (inherits(dsym, "try-error")) { stop(sprintf("failed to calculate symbolic derivative of '%s'", format1(as.call(c(flang, sym_larg))))) } #cat(sprintf("comparing %s by %s\n", format1(as.call(c(flang, larg))), nm_x)) expect_equal(as.vector(dnum), as.vector(dsym), tolerance=tolerance, info=sprintf("%s by %s", format1(as.call(c(flang, larg))), narg)) } f=function(x) {} # empty place holder expect_equal_deriv <- function(t, r, nmvar="x") { test=substitute(t) ref=substitute(r) # compare as language ans=Deriv(test, nmvar, cache.exp=FALSE) #print(deparse(ans)) eval(bquote(expect_equal(format1(quote(.(ans))), format1(quote(.(ref)))))) # compare as string ans=Deriv(format1(test), nmvar, cache.exp=FALSE) #print(ans) eval(bquote(expect_equal(.(ans), format1(quote(.(ref)))))) # compare as formula ans=Deriv(call("~", test), nmvar, cache.exp=FALSE) #print(deparse(ans)) eval(bquote(expect_equal(format1(quote(.(ans))), format1(quote(.(ref)))))) # compare as expression ans=Deriv(as.expression(test), nmvar, cache.exp=FALSE) #print(deparse(ans)) eval(bquote(expect_equal(format1(.(ans)), format1(expression(.(ref)))))) # compare as function body(f)=test ans=Deriv(f, nmvar, cache.exp=FALSE) body(f)=ref #cat("\nf deriv=", format1(ans), "\n", sep="") #cat("\nsimplify=", format1(Simplify(ans)), "\n", sep="") #cat("f ref=", format1(f), "\n", sep="") eval(bquote(expect_equal(quote(.(ans)), quote(.(f)), check.environment=FALSE))) # compare with central differences x=seq(0.1, 1, len=10) h=1.e-7 suppressWarnings(f1 <- try(sapply(x-h, function(val) eval(test, list(x=val))), silent=TRUE)) suppressWarnings(f2 <- try(sapply(x+h, function(val) eval(test, list(x=val))), silent=TRUE)) if (!inherits(f1, "try-error") && !inherits(f2, "try-error")) { numder=(f2-f1)/h/2 refder=sapply(x, function(val) eval(ref, list(x=val))) i=is.finite(refder) & is.finite(numder) expect_gt(sum(i), 0, label=sprintf("length of central diff for %s", format1(test))) expect_equal(numder[i], refder[i], tolerance=5.e-8, label=sprintf("Central diff. of '%s'", format1(test)), expected.label=sprintf("'%s'", format1(ref))) } } expect_equal_format1 <- function(t, r) { eval(bquote(expect_equal(format1(.(t)), format1(.(r))))) } test_that("elementary functions", { expect_equal(Deriv("x", "x"), "1") expect_equal(Deriv(quote(x), "x"), 1) expect_equal(Deriv(quote((x)), "x"), 1) expect_equal_deriv(x**2, 2*x) expect_equal_deriv(x**n, n*x^(n-1)) expect_equal_deriv(2**x, 0.693147180559945 * 2^x) expect_equal_deriv(sin(x), cos(x)) expect_equal_deriv(cos(x), -sin(x)) expect_equal_deriv(tan(x), 1/cos(x)^2) expect_equal_deriv(asin(x), 1/sqrt(1 - x^2)) expect_equal_deriv(acos(x), -(1/sqrt(1 - x^2))) expect_equal_deriv(atan(x), 1/(1+x^2)) expect_equal_deriv(atan2(x, y), y/(x^2+y^2)) expect_equal_deriv(atan2(0.5, x), -(0.5/(0.25 + x^2))) expect_equal_deriv(exp(x), exp(x)) expect_equal_deriv(expm1(x), exp(x)) expect_equal_deriv(log(x), 1/x) expect_equal_deriv(log1p(x), 1/(1+x)) expect_equal_deriv(abs(x), sign(x)) expect_equal_deriv(sign(x), 0) expect_equal_deriv(sinh(x), cosh(x)) expect_equal_deriv(cosh(x), sinh(x)) expect_equal_deriv(tanh(x), 1-tanh(x)^2) }) if (getRversion() >= "3.1.0") { test_that("trigonometric functions with pi", { expect_equal_deriv(sinpi(x), pi*cospi(x)) expect_equal_deriv(cospi(x), -(pi*sinpi(x))) expect_equal_deriv(tanpi(x), pi/cospi(x)**2) }) } test_that("special functions", { expect_equal_deriv(beta(x, y), beta(x, y) * (digamma(x) - digamma(x + y))) expect_equal_deriv(beta(x, y), beta(x, y) * (digamma(y) - digamma(x + y)), "y") expect_equal_deriv(besselI(x, 0), besselI(x, 1)) expect_equal_deriv(besselI(x, 0, FALSE), besselI(x, 1)) expect_equal_deriv(besselI(x, 0, TRUE), besselI(x, 1, TRUE)-besselI(x, 0, TRUE)) expect_equal_deriv(besselI(x, 1), 0.5 * (besselI(x, 0) + besselI(x, 2))) expect_equal_deriv(besselI(x, 1, FALSE), 0.5 * (besselI(x, 0) + besselI(x, 2))) expect_equal_deriv(besselI(x, 1, TRUE), 0.5 * (besselI(x, 0, TRUE) + besselI(x, 2, TRUE))-besselI(x, 1, TRUE)) expect_equal_deriv(besselI(x, n), if (n == 0) besselI(x, 1) else 0.5 * (besselI(x, 1 + n) + besselI(x, n - 1))) expect_equal_deriv(besselI(x, n, TRUE), (if (n == 0) besselI(x, 1, TRUE) else 0.5 * (besselI(x, 1 + n, TRUE) + besselI(x, n - 1, TRUE)))-besselI(x, n, TRUE)) expect_equal_deriv(besselK(x, 0), -besselK(x, 1)) expect_equal_deriv(besselK(x, 0, FALSE), -besselK(x, 1)) expect_equal_deriv(besselK(x, 0, TRUE), besselK(x, 0, TRUE)-besselK(x, 1, TRUE)) expect_equal_deriv(besselK(x, 1), -(0.5 * (besselK(x, 0) + besselK(x, 2)))) expect_equal_deriv(besselK(x, 1, FALSE), -(0.5 * (besselK(x, 0) + besselK(x, 2)))) expect_equal_deriv(besselK(x, 1, TRUE), besselK(x, 1, TRUE)-0.5 * (besselK(x, 0, TRUE) + besselK(x, 2, TRUE))) expect_equal_deriv(besselK(x, n), if (n == 0) -besselK(x, 1) else -(0.5 * (besselK(x, 1 + n) + besselK(x, n - 1)))) expect_equal_deriv(besselK(x, n, FALSE), if (n == 0) -besselK(x, 1) else -(0.5 * (besselK(x, 1 + n) + besselK(x, n - 1)))) expect_equal_deriv(besselK(x, n, TRUE), besselK(x, n, TRUE)+if (n == 0) -besselK(x, 1, TRUE) else -(0.5 * (besselK(x, 1 + n, TRUE) + besselK(x, n - 1, TRUE)))) expect_equal_deriv(besselJ(x, 0), -besselJ(x, 1)) expect_equal_deriv(besselJ(x, 1), 0.5 * (besselJ(x, 0) - besselJ(x, 2))) expect_equal_deriv(besselJ(x, n), if (n == 0) -besselJ(x, 1) else 0.5 * (besselJ(x, n - 1) - besselJ(x, 1 + n))) expect_equal_deriv(besselY(x, 0), -besselY(x, 1)) expect_equal_deriv(besselY(x, 1), 0.5 * (besselY(x, 0) - besselY(x, 2))) expect_equal_deriv(besselY(x, n), if (n == 0) -besselY(x, 1) else 0.5 * (besselY(x, n - 1) - besselY(x, 1 + n))) expect_equal_deriv(gamma(x), digamma(x) * gamma(x)) expect_equal_deriv(lgamma(x), digamma(x)) expect_equal_deriv(digamma(x), trigamma(x)) expect_equal_deriv(trigamma(x), psigamma(x, 2L)) expect_equal_deriv(psigamma(x), psigamma(x, 1L)) expect_equal_deriv(psigamma(x, n), psigamma(x, 1L+n)) expect_equal_deriv(beta(x, y), beta(x, y) * (digamma(x) - digamma(x + y))) expect_equal_deriv(beta(x, y), beta(x, y) * (digamma(y) - digamma(x + y)), "y") expect_equal_deriv(lbeta(x, y), digamma(x) - digamma(x + y)) expect_equal_deriv(lbeta(x, y), digamma(y) - digamma(x + y), "y") }) test_that("probability densities", { expect_equal_deriv(dbinom(1,3,x), (1 - 3 * x) * dbinom(1, 3, x)/(x * (1 - x))) expect_equal_deriv(dnorm(x, m=0.5), -(dnorm(x, 0.5, 1) * (x - 0.5))) }) test_that("normal quantile", { expect_equal_deriv(qnorm(x, mu, lower.tail=FALSE), -(1/dnorm(qnorm(x, mean = mu, sd = 1, lower.tail = FALSE, log.p = FALSE), mean = mu, sd = 1))) expect_equal_deriv(qnorm(x, mu, lower.tail=TRUE), 1/dnorm(qnorm(x, mean = mu, sd = 1, lower.tail = TRUE, log.p = FALSE), mean = mu, sd = 1)) expect_equal_deriv(qnorm(x, mu, log.p=TRUE), exp(x)/dnorm(qnorm(x, mean = mu, sd = 1, lower.tail = TRUE, log.p = TRUE), mean = mu, sd = 1)) expect_equal_deriv(qnorm(x, mu, log.p=FALSE), 1/dnorm(qnorm(x, mean = mu, sd = 1, lower.tail = TRUE, log.p = FALSE), mean = mu, sd = 1)) }) a=0.1 test_that("chain rule: multiply by a const", { expect_equal_deriv(a*x, a) expect_equal_deriv(a[1]*x, a[1]) expect_equal_deriv(a[[1]]*x, a[[1]]) expect_equal_deriv(a$b*x, a$b) expect_equal_deriv((a*x)**2, 2*(a^2*x)) expect_equal_deriv((a*x)**n, a*n*(a*x)^(n-1)) expect_equal_deriv(sin(a*x), a*cos(a*x)) expect_equal_deriv(cos(a*x), -(a*sin(a*x))) expect_equal_deriv(tan(a*x), a/cos(a*x)^2) expect_equal_deriv(exp(a*x), a*exp(a*x)) expect_equal_deriv(log(a*x), 1/x) }) test_that("particular cases", { expect_equal_deriv(log(x, x), 0) expect_equal_deriv(x^n+sin(n*x), n * (cos(n * x) + x^(n - 1))) expect_equal_deriv(x*(1-x), 1-2*x) expect_equal_deriv(x^x, x^x*(1+log(x))) }) test_that("indexing", { expect_equal_deriv(a[['b']], 0) }) test_that("matrix calculus", { expect_equal_deriv(solve(matrix(c(1, x, x**2, x**3), nrow=2, ncol=2)), -solve(matrix(c(1, x, x^2, x^3), nrow = 2, ncol = 2)) %*% matrix(c(0, 1, 2 * x, 3 * x^2), nrow = 2, ncol = 2, byrow = , dimnames = ) %*% solve(matrix(c(1, x, x^2, x^3), nrow = 2, ncol = 2))) }) test_that("language constructs", { expect_equal_deriv(ifelse(x>0, x^2, x^3), ifelse(test=x>0, yes=2*x, no=3*x^2)) expect_equal_deriv(with(list(c=2), x^c), with(list(c = 2), c * x^(c - 1))) }) # test AD and caching # gaussian function g <- function(x, m=0, s=1) exp(-0.5*(x-m)^2/s^2)/s/sqrt(2*pi) g1c <- Deriv(g, "x") # cache enabled by default g1n <- Deriv(g, "x", cache.exp=FALSE) # cache disabled g2c <- Deriv(g1c, "x") # cache enabled by default g2n <- Deriv(g1n, "x", cache.exp=FALSE) # cache disabled m <- 0.5 s <- 3. x=seq(-2, 2, len=11) f <- function(a) (1+a)^(1/a) f1c <- Deriv(f) f2c <- Deriv(f1c) f3c <- Deriv(f2c) f1 <- Deriv(f, cache.exp=FALSE) f2 <- Deriv(f1, cache.exp=FALSE) f3 <- Deriv(f2, cache.exp=FALSE) a=seq(0.01, 2, len=11) test_that("expression cache test", { expect_equal_deriv(exp(-0.5*(x-m)^2/s^2)/s/sqrt(2*pi), -(exp(-(0.5 * ((x - m)^2/s^2))) * (x - m)/(s^3 * sqrt(2 * pi)))) expect_equal(g2n(x, m, s), g2c(x, m, s)) expect_equal(f3(a), f3c(a)) }) test_that("reused variables", { # (issue #12) expect_equal(Deriv(~{sum=x; sum=sum*(1+x); sum=sum*y}, c("x", "y")), quote(c(x = y * (1 + 2 * x), y = x * (1 + x)))) }) # composite function differentiation/caching (issue #6) f <- function(x){ t<-x^2; log(t) } g <- function(x) cos(f(x)) test_that("composite function", { expect_equal(Deriv(g,"x"), function (x) -(2 * (sin(f(x))/x)), check.environment=FALSE) }) # user function with non diff arguments ifel <- ifelse drule[["ifel"]]<-alist(test=NULL, yes=(test)*1, no=(!test)*1) suppressWarnings(rm(t)) expect_equal(Deriv(~ifel(abs(t)<0.1, t**2, abs(t)), "t"), quote({ .e2 <- abs(t) < 0.1 (!.e2) * sign(t) + 2 * (t * .e2) })) rm("ifel", envir=drule) # long function name (issu #26) eedddddddddddddddddddddddlog=function(x) log(x) expect_error(Deriv(function(x) eedddddddddddddddddddddddlog(x)^(1-sig)*exp(x)*h, "x"), NA) # test error reporting test_that("error reporting", { expect_error(Deriv(rnorm), "is not in derivative table", fixed=TRUE) expect_error(Deriv(~rnorm(x), "x"), "is not in derivative table", fixed=TRUE) expect_error(Deriv(~x+rnorm(x), "x"), "is not in derivative table", fixed=TRUE) }) # systematic central difference tests set.seed(7) test_that("central differences", { #browser() for (nm_f in ls(drule)) { fargs=head(as.list(args(nm_f)), -1L) fargs[["..."]]=NULL ilo=sapply(fargs, isTRUE) | sapply(fargs, isFALSE) rule <- drule[[nm_f]] larg <- fargs narg <- length(larg) if (nm_f == "rep.int") { larg["x"]=pi larg["times"]=2 } else if (nm_f == "rep.int") { larg["x"]=pi larg["length.out"]=2 } else { larg[] <- runif(narg) } if (nm_f == "det") { larg[["x"]]=as.matrix(larg[["x"]]) } else if (nm_f == "acosh") { larg[["x"]]=1+larg[["x"]] } else if (nm_f == "diag" || nm_f == "matrix") { larg[["nrow"]]=larg[["ncol"]]=1L if (nm_f == "matrix") { #browser() larg[["dimnames"]]=NULL ilo=ilo[-which(names(ilo) %in% "dimnames")] } } # possible logical parameters are swithed on/off if (any(ilo)) logrid=do.call(expand.grid, rep(list(c(TRUE, FALSE)), sum(ilo))) for (arg in names(rule)) { if (is.null(rule[[arg]]) || arg == "_missing") next if (is.null(fargs) || !any(ilo)) { tmp=try(num_test_deriv(nm_f, larg, narg=arg), silent=TRUE) if (inherits(tmp, "try-error")) { stop(sprintf("Failed num. deriv test on '%s(%s)'", nm_f, paste(names(larg), larg, sep="=", collapse=", "))) } } else { apply(logrid, 1, function(lv) { #browser() lolarg=larg lolarg[ilo]=lv if (nm_f == "qnorm" && isTRUE(lolarg[["log.p"]])) { lolarg[["p"]]=log(lolarg[["p"]]) } suppressWarnings(num_test_deriv(nm_f, lolarg, narg=arg)) }) } } } }) tmp <- Deriv(Deriv(quote(dnorm(x ** 2 - x)), "x"), "x") test_that("dsym cleaning after nested call", { expect_identical(Deriv(quote(.e1*x), "x"), quote(.e1)) # was issue #2 }) # doc examples fsq <- function(x) x^2 fsc <- function(x, y) sin(x) * cos(y) f_ <- Deriv(fsc) fc <- function(x, h=0.1) if (abs(x) < h) 0.5*h*(x/h)**2 else abs(x)-0.5*h myfun <- function(x, y=TRUE) NULL # do something usefull dmyfun <- function(x, y=TRUE) NULL # myfun derivative by x. drule[["myfun"]] <- alist(x=dmyfun(x, y), y=NULL) # y is just a logical #cat("Deriv(myfun)=", format1(Deriv(myfun)), "\n") theta <- list(m=0.1, sd=2.) x <- names(theta) names(x)=rep("theta", length(theta)) # GMM example set.seed(777) ncomp=2 a=runif(ncomp) a=a/sum(a) # amplitude or weight of each component m=rnorm(ncomp) # mean s=runif(ncomp) # sd # two column matrix of probabilities: one row per x value, one column per component pn=function(x, a, m, s, log=FALSE) { n=length(a) structure(vapply(seq(n), function(i) a[i]*dnorm(x, m[i], s[i], log), double(length(x))), dim=c(length(x), n)) } p=function(x, a, m, s) rowSums(pn(x, a, m, s)) # overall probability dp=Deriv(p, "x") test_that("doc examples", { expect_equal_format1(Deriv(fsq), function (x) 2 * x) expect_equal_format1(Deriv(fsc), function (x, y) c(x = cos(x) * cos(y), y = -(sin(x) * sin(y)))) expect_equal(f_(3, 4), c(x=0.6471023, y=0.1068000), tolerance = 1.e-7) expect_equal(Deriv(~ fsc(x, y^2), "y"), quote(-(2 * (y * sin(x) * sin(y^2))))) expect_equal(Deriv(quote(fsc(x, y^2)), c("x", "y"), cache.exp=FALSE), quote(c(x = cos(x) * cos(y^2), y = -(2 * (y * sin(x) * sin(y^2)))))) expect_equal(Deriv(expression(sin(x^2) * y), "x"), expression(2 * (x * y * cos(x^2)))) expect_equal(Deriv("sin(x^2) * y", "x"), "2 * (x * y * cos(x^2))") expect_equal(Deriv(fc, "x", cache=FALSE), function(x, h=0.1) if (abs(x) < h) x/h else sign(x), check.environment=FALSE) expect_equal(Deriv(~myfun(z^2, FALSE), "z"), quote(2 * (z * dmyfun(z^2, FALSE)))) expect_equal(Deriv(~exp(-(x-theta$m)**2/(2*theta$sd)), x, cache.exp=FALSE), quote(c(theta_m = exp(-((x - theta$m)^2/(2 * theta$sd))) * (x - theta$m)/theta$sd, theta_sd = 2 * (exp(-((x - theta$m)^2/(2 * theta$sd))) * (x - theta$m)^2/(2 * theta$sd)^2)))) expect_equal(Deriv(~with(theta, exp(-(x-m)**2/(2*sd))), x, cache.exp=FALSE), quote(c(theta_m = with(theta, exp(-((x - m)^2/(2 * sd))) * (x - m)/sd), theta_sd = with(theta, 2 * (exp(-((x - m)^2/(2 * sd))) * (x - m)^2/(2 * sd)^2))))) expect_equal(dp(0, a, m, s), -0.9547048, tolerance=1.e-6) }) drule[["myfun"]] <- NULL # test renaming primitive function (issue #10) f=cos g = function(f) Deriv(f) test_that("renaming primitive", { expect_identical(g(f), Deriv(cos)) }) # test returning a constant vector of length > 1 and c()-argument (issues #14 and #15) f <- function(x, y) x + y res=c(x=1, y=1) fd=as.function(alist(x=, y=, res)) body(fd)=res f2=function(x, y) c(x, y)^2 test_that("multivar diff", { expect_identical(Deriv(f), fd) expect_equal(Deriv(f2, cache=FALSE), function (x, y) c(x = c(2, 0) * c(x, y), y = c(0, 2) * c(x, y)), check.environment=FALSE) }) Sys.setlocale(category = "LC_COLLATE", locale = lc_orig) Deriv/tests/testthat.R0000644000176200001440000000012213745525152014454 0ustar liggesusersSys.setenv("R_TESTS" = "") library(testthat) library(Deriv) test_check("Deriv") Deriv/MD50000644000176200001440000000133515025276042011640 0ustar liggesusersfde2a064fae56f8b8d2c808e82d499a1 *DESCRIPTION 82bbc4a3ae479f1c4c16263120f58fd6 *NAMESPACE 5b78b47ae7b9276047e76136fb6ae54f *NEWS 4aca813ef1ac43f3c668ba7a7b84d851 *R/Deriv.R 82302c83e1c3316d78d3d582dc420480 *R/Simplify.R 27d0698e72c3b4f397b0914beb12c1bc *README.md 83ae13da0bf4e8e3834479f3f25af141 *cleanup 4d7721964963ad77ffb1ac0406cea61e *inst/CITATION 67eba30edf17adb66c34760580b1f554 *man/Deriv-package.Rd 4199ad84696c73109142810f5589144e *man/Deriv.Rd 5442ddcf2843b543f4b72e45cdea67c6 *man/Simplify.Rd a54af14656eb4e532d695d0faca6e330 *man/format1.Rd 1dd3c53a683b40b3ed62abc2ed98af20 *tests/testthat.R 191f6c3dc58aefe2bf00b8b3ed5013ac *tests/testthat/test_Deriv.R 3d01ebb2d92979c9d992d1b775f523e5 *tests/testthat/test_Simplify.R Deriv/R/0000755000176200001440000000000015025260035011522 5ustar liggesusersDeriv/R/Simplify.R0000644000176200001440000010566015025260035013451 0ustar liggesusers#' @name Simplify #' @title Symbollic simplification of an expression or function #' @description Symbollic simplification of an expression or function #' @aliases Simplify simplifications Cache deCache #' @concept symbolic simplification # \usage{ # Simplify(expr, env=parent.frame(), scache=new.env()) # } #' #' #' @param expr An expression to be simplified, expr can be #' \itemize{ #' \item an expression: \code{expression(x+x)} #' \item a string: \code{"x+x"} #' \item a function: \code{function(x) x+x} #' \item a right hand side of a formula: \code{~x+x} #' \item a language: \code{quote(x+x)} #' } #' @param env An environment in which a simplified function is created #' if \code{expr} is a function. This argument is ignored in all other cases. #' @param scache An environment where there is a list in which simplified expression are cached #' @param st A language expression to be cached #' @param prefix A string to start the names of the cache variables #' @return A simplified expression. The result is of the same type as #' \code{expr} except for formula, where a language is returned. #' @details An environment \code{simplifications} containing simplification rules, is exported in the namespace accessible by the user. #' Cache() is used to remove redundunt calculations by storing them in #' cache variables. Default parameters to Cache() does not have to be provided #' by user. deCache() makes the inverse job -- a series of assignements #' are replaced by only one big expression without assignement. #' Sometimes it is usefull to #' apply deChache() and only then pass its result to Cache(). Simplify <- function(expr, env=parent.frame(), scache=new.env()) { if (is.null(scache$l)) scache$l <- list() # for stand alone use of Simplify if (is.expression(expr)) { as.expression(Simplify_(expr[[1]], scache)) } else if (is.function(expr)) { as.function(c(as.list(formals(expr)), Simplify_(body(expr), scache)), envir=env) } else if (is.call(expr) && expr[[1]] == as.symbol("~")) { Simplify_(expr[[length(expr)]], scache) } else if (is.character(expr)) { format1(Simplify_(parse(text=expr)[[1]], scache)) } else { Simplify_(expr, scache) } } #' @name format1 #' @title Wrapper for base::format() function #' @description Wrapper for base::format() function # \usage{ # format1(expr) # } #' #' #' @param expr An expression or symbol or language to be converted to a string. #' @return A character vector of length 1 contrary to base::format() which #' can split its output over several lines. format1 <- function(expr) { res <- if (is.symbol(expr)) as.character(expr) else if (is.call(expr) && expr[[1]]==as.symbol("{")) c(sapply(as.list(expr), format1), "}") else format(expr) n <- length(res) if (n > 1) { if (endsWith(res[1], "{") && n > 2) { b <- paste0(res[-1], collapse="; ") res <- paste0(res[1], b, collapse="") } else { res <- paste0(res, collapse=" ") } } return(res) } Simplify_ <- function(expr, scache) { if (is.call(expr)) { che <- format1(expr) res <- scache$l[[che]] if (!is.null(res)) { if (typeof(res) == "logical" && is.na(res)) { # recursive infinite call scache$l[[che]] <- expr return(expr) } else { return(res) } } che1 <- as.character(expr[[1L]]) if (che1 == "stop") { scache$l[[che]] <- expr return(expr) } if (che1 == "arg_missing" || ((che1 == "::" || che1 == ":::") && as.character(expr[[2L]]) == "Deriv" && as.character(expr[[3L]][[1L]]) == "arg_missing")) { res <- eval(expr) scache$l[[che]] <- res return(res) } scache$l[[che]] <- NA # token holder #cat("simp expr=", format1(expr), "\n", sep="") # skip missing unnamed args but for "[" call if (che1 != "[") { imi <- sapply(expr, function(it) identical(nchar(it), 0L)) } else { imi=rep(FALSE, length(expr)) } if (any(imi) && length(nms <- names(expr)) > 0L) imi <- imi & sapply(nms, function(it) identical(nchar(it), 0L)) expr <- as.call(as.list(expr)[!imi]) args <- lapply(as.list(expr)[-1], Simplify_, scache) expr[-1] <- args if (all(sapply(args, is.conuloch))) { # if all arguments are like numeric, evaluate them res <- eval(expr) scache$l[[che]] <- res return(res) } else { # is there a rule in the table? sym.name <- format1(expr[[1]]) Simplify.rule <- simplifications[[sym.name]] res <- if (!is.null(Simplify.rule)) Simplify.rule(expr, scache=scache) else expr scache$l[[che]] <- res return(res) } } else { expr } } # in what follows no need to Simplify_ args neither to check if # all arguments are numeric. It is done in the upper Simplify_() `Simplify.(` <- function(expr, scache=NULL) { expr[[2]] } `Simplify.+` <- function(expr, add=TRUE, scache=NULL) { if (length(expr) == 2) { if (add) return(expr[[2]]) else if (is.uminus(expr[[2]])) return(expr[[2]][[2]]) else if (is.uplus(expr[[2]])) return(call("-", expr[[2]][[2]])) else return(expr) } a <- expr[[2]] b <- expr[[3]] if (is.numconst(a, 0) || (is.call(a) && format1(a[[1]]) %in% c("rep", "rep.int", "rep_len") && is.numconst(a[[2]], 0))) { #browser() return(if (add) b else call("-", b)) } else if (is.numconst(b, 0) || (is.call(b) && format1(b[[1]]) %in% c("rep", "rep.int", "rep_len") && is.numconst(b[[2]], 0))) { #browser() return(a) } else if (add && is.uminus(a) && !is.uminus(b)) { a <- b b <- expr[[2]][[2]] add <- FALSE expr <- call("-", a, b) } else if (identical(a, b)) { return(if (add) Simplify_(call("*", 2, a), scache) else 0) } else if (!is.call(a) && !is.call(b)) { if (add) { # just reorder expr[-1] <- expr[1+order(sapply(expr[-1], format1))] } return(expr) } # factorise most repeated terms alc <- Lincomb(a) blc <- Lincomb(b) if (add) { lc <- c(alc, blc) } else { # inverse sminus in b blc <- lapply(blc, function(it) {it$sminus <- !it$sminus; it}) lc <- c(alc, blc) } #browser() # sum purely numeric terms inum <- which(sapply(lc, function(it) length(it$num)==0 && length(it$den)==0)) if (length(inum) > 1) { term <- sum(sapply(lc[inum], function(it) (if (it$sminus) -1 else 1)*it$fa$num/it$fa$den)) lc[[inum[1]]] <- list(fa=list(num=abs(term), den=1), sminus=term<0) lc <- lc[-inum[-1]] } bch <- ta <- tsim <- po <- ilc <- ind <- list() for (cnd in c("num", "den")) { # character bases in num/den bch[[cnd]] <- unlist(lapply(lc, function(it) {lapply(it[[cnd]]$b, format1)})) # powers po[[cnd]] <- do.call(c, lapply(lc, function(it) it[[cnd]]$p), quote=TRUE) # index of the lc term for each bnch ta[[cnd]] <- table(bch[[cnd]]) ta[[cnd]] <- ta[[cnd]][ta[[cnd]] > 1] # keep only repeated bases tsim[[cnd]] <- outer(bch[[cnd]], names(ta[[cnd]]), `==`) ilc[[cnd]] <- unlist(lapply(seq_along(lc), function(i) {rep(i, length(lc[[i]][[cnd]]$b))})) # index of the base in a given term (nd) for each bnch ind[[cnd]] <- unlist(lapply(seq_along(lc), function(i) {seq_along(lc[[i]][[cnd]]$b)})) } #browser() # fnd will be the name "num" or "den" where the first factor # will be taken. ond is the "other" name (if fnd=="num", then ond == "den") # we select the candidate which is most repeated provided that it # has at least one numeric power occurance. taa <- unlist(ta) ota <- order(taa, decreasing=TRUE) ntan <- length(ta$num) fnd <- NA #browser() for (i in ota) { cnd <- if (i > ntan) "den" else "num" ita <- i - if (i > ntan) ntan else 0 ib <- bch[[cnd]] == names(ta[[cnd]])[ita] pisnum=any(sapply(po[[cnd]][ib], is.numeric)); if (pisnum || (idup <- anyDuplicated(sapply(po[[cnd]][ib], format1)))) { fnd <- cnd iit <- which(ib) # the bases equal to factor if (pisnum) { p_fa <- min(sapply(po[[cnd]][ib], function(p) if (is.numeric(p)) p else NA), na.rm=TRUE) } else { p_fa <- po[[cnd]][ib][[idup]] } i_lc <- ilc[[cnd]][iit] i_nd <- ind[[cnd]][iit] break } } if (is.na(fnd)) return(lc2expr(lc, scache)) # nothing to factorize, just order terms ond <- if (fnd == "num") "den" else "num" # create nd with the first factor fa_nd <- list(num=list(b=list(), p=list()), den=list(b=list(), p=list()), sminus=FALSE, fa=list(num=1, den=1)) fa_nd[[fnd]]$b <- lc[[i_lc[1]]][[fnd]]$b[i_nd[1]] fa_nd[[fnd]]$p <- list(p_fa) # decrease p in the lc terms for (i in seq_along(i_lc)) lc[[i_lc[i]]][[fnd]]$p[[i_nd[i]]] <- Simplify_(call("-", lc[[i_lc[i]]][[fnd]]$p[[i_nd[i]]], p_fa), scache) for (cnd in c(fnd, ond)) { # see if other side can provide factors for (i in seq_along(ta[[cnd]])) { if ((cnd == fnd && i == ita) || ta[[fnd]][ita] != ta[[cnd]][i] || any(ilc[[cnd]][tsim[[cnd]][,i]] != i_lc)) { next # no common layout with the factor } ib <- bch[[cnd]] == names(ta[[cnd]])[i] # see if it has numeric power if (!any(sapply(po[[cnd]][ib], is.numeric))) { next } iit <- which(ib) # the bases equal to factor p_fa <- min(sapply(po[[cnd]][ib], function(p) if (is.numeric(p)) p else NA), na.rm=TRUE) i_lc <- ilc[[cnd]][iit] i_nd <- ind[[cnd]][iit] fa_nd[[cnd]]$b <- append(fa_nd[[cnd]]$b, lc[[i_lc[1]]][[cnd]]$b[i_nd[1]]) fa_nd[[cnd]]$p <- append(fa_nd[[cnd]]$p, p_fa) # decrease p in the lc terms for (i in seq_along(i_lc)) { lc[[i_lc[i]]][[cnd]]$p[[i_nd[i]]] <- Simplify_(call("-", lc[[i_lc[i]]][[cnd]]$p[[i_nd[i]]], p_fa), scache) } } } #browser() # form final symbolic expression # replace all i_lc by one product of fa_nd and lincomb of the reduced nds rest <- Simplify_(lc2expr(lc[i_lc], scache), scache) if (is.neg.expr(rest)) { rest <- negate.expr(rest) fa_nd$sminus <- !fa_nd$sminus } fa_nd$num$b <- append(fa_nd$num$b, rest) fa_nd$num$p <- append(fa_nd$num$p, 1) lc <- c(list(fa_nd), lc[-i_lc]) return(lc2expr(lc, scache)) } `Simplify.-` <- function(expr, scache=NULL) { `Simplify.+`(expr, add=FALSE, scache=scache) } `Simplify.*` <- function(expr, div=FALSE, scache=NULL) { #print(expr) #browser() a <- expr[[2]] b <- expr[[3]] if (is.uminus(a)) { sminus <- TRUE a <- a[[2]] } else { sminus <- FALSE } if (is.uminus(b)) { sminus <- !sminus b <- b[[2]] } #browser() if (is.numconst(a, 0) || (is.call(a) && format1(a[[1]]) %in% c("rep", "rep.int", "rep_len") && is.numconst(a[[2]], 0)) || (is.numconst(b, 0) || (is.call(b) && format1(b[[1]]) %in% c("rep", "rep.int", "rep_len") && is.numconst(b[[2]], 0)) && !div)) { # if (a == 0 || (b == 0 && !div)) { #browser() 0 } else if (is.numconst(a, 1) && !div) { if (sminus) call("-", b) else b } else if (is.numconst(b, 1)) { if (sminus) call("-", a) else a } else if (div && identical(a, b)) { if (sminus) -1 else 1 } else { #browser() # get numerator and denominator for a and b then combine them nd_a <- Numden(a) nd_b <- Numden(b) if (div) { nd <- list( num=list(b=c(nd_a$num$b, nd_b$den$b), p=c(nd_a$num$p, nd_b$den$p)), den=list(b=c(nd_a$den$b, nd_b$num$b), p=c(nd_a$den$p, nd_b$num$p)) ) sminus=xor(sminus, xor(nd_a$sminus, nd_b$sminus)) } else { nd <- list( num=list(b=c(nd_a$num$b, nd_b$num$b), p=c(nd_a$num$p, nd_b$num$p)), den=list(b=c(nd_a$den$b, nd_b$den$b), p=c(nd_a$den$p, nd_b$den$p)) ) sminus=xor(sminus, xor(nd_a$sminus, nd_b$sminus)) } # reduce numerics to only one factor fa=list() if (div) { fa$num <- nd_a$fa$num*nd_b$fa$den fa$den <- nd_a$fa$den*nd_b$fa$num } else { fa$num <- nd_a$fa$num*nd_b$fa$num fa$den <- nd_a$fa$den*nd_b$fa$den } res <- fa$num/fa$den suppressWarnings(ires <- as.integer(res)) if (!anyNA(ires) && all(ires == res)) { fa$num <- res fa$den <- 1 } else if (fa$den != 1) { res <- fa$den/fa$num suppressWarnings(ires <- as.integer(res)) if (!anyNA(ires) && all(ires == res)) { fa$num <- 1 fa$den <- res } } # group identical bases by adding their powers #browser() bch=list() for (na in c("num", "den")) { bch[[na]] <- sapply(nd[[na]]$b, format1) if (length(nd[[na]]$b) <= 1) next ta <- table(bch[[na]]) ta <- ta[ta > 1] if (length(ta) == 0) next nd_eq <- outer(bch[[na]], names(ta), `==`) for (inum in seq(len=ncol(nd_eq))) { isim <- which(nd_eq[,inum]) if (length(isim)) { # add powers for this base nd[[na]]$p[[isim[1]]] <- Simplify_(li2sum(nd[[na]]$p[isim]), scache) # set grouped powers to 0 nd[[na]]$p[isim[-1]] <- 0 } } # remove power==0 terms ize <- isim[-1] if (length(ize)) { nd[[na]]$b <- nd[[na]]$b[-ize] nd[[na]]$p <- nd[[na]]$p[-ize] bch[[na]] <- bch[[na]][-ize] } } # simplify identical terms in num and denum by subtracting powers nd_eq <- outer(bch$den, bch$num, `==`) ipair <- matrix(0, nrow=2, ncol=0) for (inum in seq(len=ncol(nd_eq))) { iden <- which(nd_eq[,inum]) # of length at most 1 as terms are already grouped if (length(iden)) { # simplify power for this pair ipair <- cbind(ipair, c(inum, iden)) res <- Simplify_(call("-", nd$num$p[[inum]], nd$den$p[[iden]]), scache) if (is.neg.expr(res)) { nd$num$p[[inum]] <- 0 nd$den$p[[iden]] <- negate.expr(res) } else { nd$num$p[[inum]] <- res nd$den$p[[iden]] <- 0 } } } #browser() # remove power==0 terms for (na in c("num", "den")) { if (length(nd[[na]]$b) == 0) next ize=sapply(nd[[na]]$p, `==`, 0) nd[[na]]$b <- nd[[na]]$b[!ize] nd[[na]]$p <- nd[[na]]$p[!ize] } nd[["fa"]] <- fa nd[["sminus"]] <- sminus expr <- nd2expr(nd, scache) expr } } `Simplify./` <- function(expr, scache=NULL) { `Simplify.*`(expr, div=TRUE, scache=scache) } `Simplify.^` <- function(expr, scache=NULL) { a <- expr[[2]] b <- expr[[3]] if (is.numconst(a, 0)) { 0 } else if (is.numconst(b, 0) || is.numconst(a, 1)) { 1 } else if (is.numconst(b, 1)) { a } else if (identical(b, 0.5)) { substitute(sqrt(a)) } else if (b == -0.5) { substitute(1/sqrt(a)) } else if (is.call(a)) { if (a[[1]] == as.symbol("^")) { # product of exponents b <- Simplify_(call("*", a[[3]], b), scache) a <- a[[2]] } else if (a[[1]] == as.symbol("sqrt")) { # divide by 2 b <- Simplify_(call("/", b, 2), scache) a <- a[[2]] } else if (a[[1]] == as.symbol("abs") && is.numeric(b) && b%%2 == 0) { # remove abs() for even power a <- a[[2]] } expr[[2]] <- a expr[[3]] <- b expr } else { expr } } Simplify.log <- function(expr, scache=NULL) { if (is.call(expr[[2]])) { # the argument of log is a function subf <- format1(expr[[2]][[1]]) if (subf == "^") { p <- expr[[2]][[3]] expr[[2]] <- expr[[2]][[2]] expr <- Simplify_(call("*", p, expr), scache) } else if (subf == "exp") { if (length(expr) == 2) expr <- expr[[2]][[2]] else expr <- Simplify_(call("/", expr[[2]][[2]], call("log", expr[[3]])), scache) } else if (subf == "sqrt") { expr[[2]] <- expr[[2]][[2]] expr <- Simplify_(call("*", 0.5, expr), scache) } else if (subf == "*") { a <- expr a[[2]] <- expr[[2]][[2]] expr[[2]] <- expr[[2]][[3]] # unitary "+" cannot appear here expr <- Simplify_(call("+", a, expr), scache) } else if (subf == "/") { a <- expr a[[2]] <- expr[[2]][[2]] expr[[2]] <- expr[[2]][[3]] # unitary "+" cannot appear here expr <- Simplify_(call("-", a, expr), scache) } else if (subf == "+") { # replace log(1+x) by log1p(x) if (expr[[2]][[2]] == 1) { expr <- call("log1p", expr[[2]][[3]]) } else if (expr[[2]][[3]] == 1) { expr <- call("log1p", expr[[2]][[2]]) } } } if (length(expr) == 3 && identical(expr[[2]], expr[[3]])) { 1 } else { expr } } Simplify.sqrt <- function(expr, scache=NULL) { if (is.call(expr[[2]])) { # the argument of sqrt is a function subf <- format1(expr[[2]][[1]]) if (subf == "^") { p <- expr[[2]][[3]] Simplify_(call("^", call("abs", expr[[2]][[2]]), call("/", p, 2)), scache) } else if (subf == "exp") { expr[[2]][[2]] <- Simplify_(call("/", expr[[2]][[2]], 2), scache) expr[[2]] } else if (subf == "sqrt") { Simplify_(call("^", expr[[2]][[2]], 0.25), scache) } else if (subf == "*" && identical(expr[[2]][[2]], expr[[2]][[3]])) { Simplify_(call("abs", expr[[2]][[2]]), scache) } else { expr } } else { expr } } Simplify.abs <- function(expr, scache=NULL) { if (is.uminus(expr[[2]])) { expr[[2]] <- expr[[2]][[2]] } else if (is.call(expr[[2]])) { subf <- format1(expr[[2]][[1]]) if (subf == "^") { p <- expr[[2]][[3]] if (is.numeric(p) && p%%2 == 0) expr <- expr[[2]] } else if (subf == "exp" || subf == "sqrt") { expr <- expr[[2]] } } expr } Simplify.sign <- function(expr, scache=NULL) { if (is.uminus(expr[[2]])) { expr[[2]] <- expr[[2]][[2]] expr <- call("-", expr) } else if (is.call(expr[[2]])) { subf <- format1(expr[[2]][[1]]) if (subf == "^") { p <- expr[[2]][[3]] if (is.numeric(p) && p%%2 == 0) expr <- 1 } else if (subf == "exp" || subf == "sqrt") { expr <- 1 } } expr } Simplify.if <- function(expr, scache=NULL) { cond <- expr[[2]] if ((is.logical(cond) || is.numeric(cond)) && isTRUE(!!cond)) { expr <- expr[[3]] } else if (length(expr) == 4) { if ((is.logical(cond) || is.numeric(cond)) && isTRUE(!cond)) { expr <- expr[[4]] } else if (identical(expr[[3]], expr[[4]])) { expr <- expr[[3]] } } expr } Simplify.bessel <- function(expr, scache=NULL) { if (length(expr) < 4) return(expr) cond <- expr[[4]] if ((is.logical(cond) || is.numeric(cond)) && isTRUE(!cond)) { expr[[4]] <- NULL } expr } `Simplify.=` <- function(expr, scache=NULL) { # just strore the rhs in the scache if (is.symbol(expr[[2]]) && is.call(expr[[3]])) { scache$l[[format1(expr[[3]])]] <- expr[[2]] } expr } `Simplify.{` <- function(expr, scache=NULL) { n <- length(expr) # if only one expression, return it if (n == 2) { expr <- expr[[n]] } else { # if the last expression is a constant just return it la <- expr[[n]] if (is.conuloch(la)) { expr <- la } expr } } `Simplify.%*%` <- function(expr, scache=NULL) { a <- expr[[2]] b <- expr[[3]] if (identical(a, 0) || identical(a, 0L) || identical(b, 0) || identical(b, 0L)) return(0) if (identical(a, 1) || identical(a, 1L)) { return(b) } else if (identical(b, 1) || identical(b, 1L)) { return(a) } else { expr } } `Simplify.$` <- function(expr, scache=NULL) { #browser() # list(a=smth, b=...)$a -> smth a <- expr[[2]] if (identical(a, 0) || identical(a, 0L)) return(a) b <- expr[[3]] bch <- as.character(b) if (((is.call(a) && "list" == as.character(a[[1]])) || is.list(a)) && is.name(b) && !is.na(i <- pmatch(bch, names(a)))) { return(a[[i]]) } expr } `Simplify.[` <- function(expr, scache=NULL) { #browser() # 0[smth] -> 0 a <- expr[[2]] if (identical(a, 0) || identical(a, 0L)) return(a) expr } `Simplify.[[` <- function(expr, scache=NULL) { #browser() # list(a=smth, b=...)$a -> smth a <- expr[[2]] if (identical(a, 0) || identical(a, 0L)) return(a) b <- expr[[3]] if (((is.call(a) && ((ach <- as.character(a[[1]])) == "list" || ach == "c")) || is.vector(a)) && length(b) == 1 && is.character(b) && !is.na(i <- match(b, names(a)))) { return(a[[i]]) } expr } `Simplify.||` <- function(expr, scache=NULL) { #browser() # a || TRUE -> TRUE # a || FALSE -> a a <- expr[[2L]] b <- expr[[3L]] if (identical(a, TRUE) || identical(b, TRUE)) return(TRUE) if (identical(a, FALSE)) return(b) if (identical(b, FALSE)) return(a) expr } `Simplify.&&` <- function(expr, scache=NULL) { #browser() # a && TRUE -> a # a && FALSE -> FALSE a <- expr[[2L]] b <- expr[[3L]] if (identical(a, FALSE) || identical(b, FALSE)) return(FALSE) if (identical(a, TRUE)) return(b) if (identical(b, TRUE)) return(a) expr } `Simplify.ifelse` <- function(expr, scache=NULL) { #browser() # ifelse(TRUE, a, b) -> a # ifelse(FALSE, a, b) -> b n=length(expr) if (n > 1L) { cond=expr[[2L]] } else { return(expr) } if (isTRUE(cond) && n > 2) return(expr[[3L]]) if (isFALSE(cond) && n > 3) return(expr[[4L]]) expr } Numden <- function(expr) { # Return a list with "num" as numerator and "den" as denominator sublists. # "fa" field is for numeric factors in "num" and "den" subfields. # "sminus" is logical for applying or not "-" to the whole expression # Each sublist regroups the language expressions which are not products neither # divisions. The terms are decomposed in b^p sublists #print(expr) #browser() if (is.uminus(expr)) { a=Numden(expr[[2]]) a$sminus <- !a$sminus a } else if (is.uplus(expr)) { Numden(expr[[2]]) } else if (is.symbol(expr)) { list(num=list(b=list(expr), p=list(1)), sminus=FALSE, fa=list(num=1, den=1)) } else if (is.numeric(expr)) { sminus <- length(expr) == 1 && expr < 0 list(fa=list(num=if (sminus) -expr else expr, den=1), sminus=sminus) } else if (is.call(expr)) { if (expr[[1]] == as.symbol("*")) { # recursive call a=Numden(expr[[2]]) b=Numden(expr[[3]]) list(num=list(b=c(a$num$b, b$num$b), p=c(a$num$p, b$num$p)), den=list(b=c(a$den$b, b$den$b), p=c(a$den$p, b$den$p)), sminus=xor(a$sminus, b$sminus), fa=list(num=a$fa$num*b$fa$num, den=a$fa$den*b$fa$den)) } else if (expr[[1]] == as.symbol("/")) { # recursive call a=Numden(expr[[2]]) b=Numden(expr[[3]]) list(num=list(b=c(a$num$b, b$den$b), p=c(a$num$p, b$den$p)), den=list(b=c(a$den$b, b$num$b), p=c(a$den$p, b$num$p)), sminus=xor(a$sminus, b$sminus), fa=list(num=a$fa$num*b$fa$den, den=a$fa$den*b$fa$num)) } else if (expr[[1]] == as.symbol("^")) { if (is.neg.expr(expr[[3]])) { # make the power look positive list(den=list(b=list(expr[[2]]), p=list(negate.expr(expr[[3]]))), sminus=FALSE, fa=list(num=1, den=1) ) } else { list(num=list(b=list(expr[[2]]), p=list(expr[[3]])), sminus=FALSE, fa=list(num=1, den=1) ) } } else { list(num=list(b=list(expr), p=list(1)), sminus=FALSE, fa=list(num=1, den=1)) } } else { list(num=list(b=list(expr), p=list(1)), sminus=FALSE, fa=list(num=1, den=1)) } } is.uminus <- function(e) { # detect if e is unitary minus, e.g. "-a" return(is.call(e) && length(e) == 2 && e[[1]] == as.symbol("-")) } is.uplus <- function(e) { # detect if e is unitary plus, e.g. "+a" return(is.call(e) && length(e) == 2 && e[[1]] == as.symbol("+")) } is.unumeric <- function(e) { # detect if numeric with optional unitary sign(s) return(is.numeric(e) || ((is.uminus(e) || is.uplus(e)) && is.unumeric(e[[2]]))) } is.conuloch <- function(e) { # detect if e is complex, numeric, logical or character return(is.numeric(e) || is.logical(e) || is.complex(e) || is.character(e)) } is.neg.expr <- function(e) { # detect if e is a negative expression, i.e. is one of: # - negative real number # - unitary minus (-a) return((is.numeric(e) && e < 0) || is.uminus(e)) } negate.expr <- function(e) { # make negative expression looking positive or inverse the difference if (is.numeric(e)) -e else # e is supposed to be a unitary minus e[[2]] } is.assign <- function(e) { # detect if it is an assignment operator is.call(e) && (e[[1]] == as.symbol("<-") || e[[1]] == as.symbol("=")) } is.subindex <- function(e) { # is e a simple subindex expression? is.call(e) && any(format1(e[[1]]) == c("$", "[", "[[")) && (is.symbol(e[[2]]) && (is.symbol(e[[3]]) || is.conuloch(e[[3]]))) } is.numconst <- function(e, val=NULL) { res=is.numeric(e) && length(e) == 1L if (res && !is.null(val)) res = res && is.numconst(val) && e == val return(res) } Lincomb <- function(expr) { # decompose expr in a list of product terms (cf Numden) # the sign of each term is determined by the nd$sminus logical item. if (is.call(expr) && length(expr) == 3) { if (expr[[1]] == as.symbol("+")) { # recursive call c(Lincomb(expr[[2]]), Lincomb(expr[[3]])) } else if (expr[[1]] == as.symbol("-")) { # recursive call a <- Lincomb(expr[[2]]) b <- Lincomb(expr[[3]]) # inverse the sign in b terms b <- lapply(b, function(it) {it$sminus <- !it$sminus; it}) c(a, b) } else { list(Numden(expr)) } } else { list(Numden(expr)) } } # return an environement in which stored subexpressions with # an index giving the position of each subexpression in the # whole statement st ("rhs" entry). Index is given as a string i1.i2.i3... # where the integeres iN refer to st[[i2]][[i3]][[...]] # "lhs" is index to char mapping (what is defined where) # "def" is a mapping of lhs (char) to rhs (char) # "{" where accolade operators are Leaves <- function(st, ind="1", res=new.env()) { if (is.null(res$rhs)) { res$rhs <- list() res$lhs <- list() res$def <- list() # store definitions by asignments } if (is.call(st)) { stch=as.character(st[[1]]) if (stch != "<-" && stch != "=") { if (stch == "function") { #browser() st[[3L]]=Cache(st[[3L]]) res$rhs[[ind]] <- format1(st) res$st=st return(res) } res$rhs[[ind]] <- format1(st) } else { if (!is.null(res$lhs[[ind]])) stop("Re-assignment is not supported yet in caching.") if (is.call(st[[2]])) stop("Cannot handle yet indexing in left values.") lhs <- format1(st[[2]]) res$lhs[[ind]] <- lhs # we cannot handle yet `[`, `$` etc. res$def[[lhs]] <- format1(st[[3]]) # exclude this assignement from replacements if .eX #if (regexpr("\\.+e[0-9]+", lhs) > 0) # return(res) } args <- as.list(st)[-1] l <- lapply(seq_along(args), function(i) {Leaves(args[[i]], paste(ind, i+1, sep="."), res); st[[i+1]] <<- res$st}) } res$st=st return(res) } # convert index calculated by Leaves() to a call like st[[i2]][[i3]]... # the first two chars "1." are striped out ind2call <- function(ind, st="st") if (ind == "1") as.symbol(st) else parse(text=sprintf("%s[[%s]]", st, gsub(".", "]][[", substring(ind, 3), fixed=TRUE)))[[1]] # replace repeated subexpressions by cached values # prefix is used to form auxiliary variable ##' @rdname Simplify Cache <- function(st, env=Leaves(st), prefix="") { st=env$st stch <- if (is.call(st)) format1(st[[1]]) else "" env$lhs <- unlist(env$lhs) #if (stch == "<-" || stch == "=") { # return(call("<-", st[[2]], Cache(st[[3]], env=env, prefix=paste(".", st[[2]], sep="")))) #} else if (stch == "{" || stch == "c") { # return(as.call(c(list(st[[1]]), lapply(as.list(st)[-1], Cache, env=env)))) #} alva <- all.vars(st) p <- grep(sprintf("^%s.e[0-9]+", prefix), alva, value=TRUE) if (nchar(prefix) == 0 && length(p) > 0) { prefix <- max(p) } ve <- unlist(env$rhs) defs <- unlist(env$def) tdef <- outer(ve, defs, "==") #browser() # if the subexpression is in defs, replace it with the symbol in the lhs for (ic in seq_len(ncol(tdef))) { v <- tdef[,ic] nme <- colnames(tdef)[ic] idef <- names(which(env$lhs==nme)) for (i in which(v)) { ind <- names(v)[i] # subexpression index in st # skip self assignment ispl <- strsplit(ind, ".", fixed=TRUE)[[1]] indup <- paste(ispl[-length(ispl)], collapse=".") stup <- eval(ind2call(indup)) if ((is.assign(stup) && (format1(stup[[2]]) == nme || natcompare(indup, idef) < 0))) next ve[i] <- NA do.call(`<-`, list(ind2call(ind), quote(as.symbol(nme)))) } } suppressWarnings(ve <- ve[!is.na(ve)]) # skip simple subindex isi <- sapply(ve, function(e) is.subindex(parse(text=e)[[1]])) ve <- ve[!isi] ta <- table(ve) ta <- ta[ta > 1] if (length(ta) == 0) return(st) e <- list() # will store the result code alva <- list() for (sub in names(sort(ta, decreasing=TRUE))) { # get st indexes for this subexpression isubs <- names(which(ve == sub)) for (i in seq_along(isubs)) { isub <- isubs[i] subst <- ind2call(isub) if (i == 1) { esubst <- try(eval(subst), silent=TRUE) if (inherits(esubst, "try-error")) break # was already cached # add subexpression to the final code ie=length(e)+1 estr <- sprintf("%s.e%d", prefix, ie) esub <- as.symbol(estr) e[[ie]] <- call("<-", esub, esubst) alva[[estr]] <- all.vars(esubst) } # replace subexpression in st by .eX do.call(`<-`, list(subst, as.symbol("esub"))) } } alva[["end"]] <- all.vars(st) # where .eX are used? If only once, develop, replace and remove it wh <- lapply(seq_along(e), function(i) { it=sprintf("%s.e%d", prefix, i) which(sapply(alva, function(v) any(it == v))) }) dere <- sapply(wh, function(it) if (length(it) == 1 && names(it) != "end") it[[1]] else 0) for (i in which(dere != 0)) { idest <- dere[i] li <- list() li[[sprintf("%s.e%d", prefix, i)]] <- e[[i]][[3]] e[[idest]][[3]] <- do.call("substitute", c(e[[idest]][[3]], list(li))) } e <- e[which(!dere)] #browser() # place auxiliary vars after the definition of the used vars if (stch != "{") { l <- c(as.symbol("{"), e, st) st <- as.call(l) } else { n <- length(st) res <- c(e, as.list(st)[-c(1, n)]) alva <- lapply(res, all.vars) i <- toporder(alva) res <- c(as.symbol("{"), res[i], st[[n]]) st <- as.call(res) } return(st) } ##' @rdname Simplify deCache <- function(st) { # do the job inverse to Cache(), i.e. substitute all auxiliary expressions # in the final one # NB side effect: all assignement not used in the last operation in {...} are # just lost. if (!is.call(st)) { return(st) } stch <- format1(st[[1]]) stl <- as.list(st) if (stch == "{") { repl <- list() for (op in stl[-1]) { # gather substitutions if (is.assign(op)) { repl[[as.character(op[[2]])]] <- do.call("substitute", list(deCache(op[[3]]), repl)) } } # the last operation subst la <- stl[[length(stl)]] if (is.assign(la)) { st <- repl[[length(repl)]] } else { st <- do.call("substitute", list(deCache(la), repl)) } } else { # recurrsive call to deCache on all arguments of the statement stl <- lapply(stl, deCache) st <- as.call(stl) } return(st) } nd2expr <- function(nd, scache, sminus=NULL) { # form symbolic products # if sminus is not null, use it instead of the nd's one if (length(nd) == 0) return(0) eprod <- list() sminus <- (!is.null(sminus) && sminus) || (is.null(sminus) && nd$sminus) for (na in c("num", "den")) { if (length(nd[[na]]$b) == 0) next # alphabetic order for bases, symbols first, then calls for (i in order(sapply(nd[[na]]$b, is.call), sapply(nd[[na]]$b, format1))) { p <- nd[[na]]$p[[i]] if (p == 0) next term <- if (p == 1) nd[[na]]$b[[i]] else Simplify_(call("^", nd[[na]]$b[[i]], p), scache) if (term == 0) return(if (na == "num") 0 else if (sminus) -Inf else Inf) if (is.null(eprod[[na]])) eprod[[na]] <- term # start the sequence else eprod[[na]] <- call("*", eprod[[na]], term) } } expr <- if (is.null(eprod$num)) 1 else eprod$num if (!is.null(eprod$den)) { expr <- call("/", expr, eprod$den) } # put numeric factor at first place fa=nd$fa if (any(fa$num != 1) && any(fa$den != 1)) { # add to both num. and denom. if (!is.null(eprod$den)) { expr[[2]] <- call("*", fa$num, expr[[2]]) expr[[3]] <- call("*", fa$den, expr[[3]]) } else { expr <- call("/", call("*", fa$num, expr), fa$den) } } else if (any(fa$num != 1)) { if (is.call(expr) && expr[[1]] == as.symbol("/") && expr[[2]] == 1) expr[[2]] <- fa$num else if (expr == 1) expr <- fa$num else expr <- call("*", fa$num, expr) } else if (any(fa$den != 1)) { if (is.call(expr) && expr[[1]] == as.symbol("/")) expr[[3]] <- call("*", fa$den, expr[[3]]) else expr <- call("/", expr, fa$den) } expr <- if (sminus) call("-", expr) else expr #print(sprintf("nd->%s", format1(expr))) return(expr) } lc2expr <- function(lc, scache) { # form symbolic sum and diff form a list of nds # separate in positive and negative smin <- sapply(lc, "[[", "sminus") epos <- lapply(lc[which(!smin)], nd2expr, scache) if (length(epos) > 1) { #cat("epos orig=", sapply(epos, format1), sep="\n") #cat("epos order=", order(sapply(epos, format1)), sep="\n") #cat("order - +=", order(c("-", "+")), sep="\n") epos <- epos[order(sapply(epos, format1), decreasing = FALSE)] #cat("epos=", sapply(epos, format1), sep="\n") } eneg <- lapply(lc[which(smin)], nd2expr, scache, sminus=FALSE) if (length(eneg) > 1) { eneg <- eneg[order(sapply(eneg, format1))] } if (length(epos) == 0) return(if (length(eneg) == 0) 0 else call("-", li2sum(eneg))) else return(if (length(eneg) == 0) li2sum(epos) else Simplify_(call("-", li2sum(epos), li2sum(eneg)), scache)) } li2sum <- function(li) { # form a long sum of expressions from the list li len <- length(li) if (len == 0) 0 else if (len == 1) li[[1]] else if (len == 2) if (li[[1]] == 0) li[[2]] else if (li[[2]] == 0) li[[1]] else call("+", li[[1]], li[[2]]) else call("+", li2sum(li[-len]), li[[len]]) } toporder <- function(l, ind=seq_along(l), vars=sapply(l, `[[`, 1)) { # Topological ordering of assignement operators # l is a list whose memebers are resulted from all.vars(op) # ind is a subindexing vector for l (for recursive call) # vars is a vector of variable which are assigned in ops[ind] # return a vector of indexes like in order() # find independet assignements, i.e. whose rhs vars are not in vars #cat("ind=", ind, "\n") if (length(ind) <= 1) { return(ind) } rhsvar <- lapply(l[ind], `[`, -1) indep <- which(!sapply(rhsvar, function(v) any(v %in% vars))) #cat("indep=", ind[indep], "\n") return(c(ind[indep], toporder(l, ind[-indep], vars[-indep]))) } natcompare <- function(s1, s2, sep="[^0-9]+") { # Compare two strings in natural ordering, # i.e. natlower("1.12", "1.2") returns 1 (i.e s1 is greater than s2) # while plain "1.12" < "1.2" returns TRUE # sep is separator for string splitting # By default any non number chain of characters # is used as a single separator and thus is exlculed # from comparison. # The fields after string splitting are compared as numerics # Empty string or NA are considered as -Inf, i.e. they are less # than any other finite number. # Return -1 if s1 is lower s2, 0 if s1 is equal to s2 and 1 otherwise # v1 <- as.numeric(strsplit(s1, sep[1])[[1]]) v1[is.na(v1)] <- -Inf v2 <- as.numeric(strsplit(s2, sep[1])[[1]]) v2[is.na(v2)] <- -Inf l1 <- length(v1) l2 <- length(v2) lmin <- min(l1, l2) # complete the shortest vector by -Inf v1 <- c(v1, rep(-Inf, l2-lmin)) v2 <- c(v2, rep(-Inf, l1-lmin)) m1 <- v1 < v2 eq <- v1 == v2 p1 <- v1 > v2 if (all(m1) || (any(m1) && all(!p1)) || any(head(which(m1), 1) < head(which(p1), 1))) { -1 } else if (all(eq)) { 0 } else { 1 } } simplifications <- new.env() assign("+", `Simplify.+`, envir=simplifications) assign("-", `Simplify.-`, envir=simplifications) assign("*", `Simplify.*`, envir=simplifications) assign("/", `Simplify./`, envir=simplifications) assign("(", `Simplify.(`, envir=simplifications) assign("^", `Simplify.^`, envir=simplifications) assign("log", `Simplify.log`, envir=simplifications) assign("logb", `Simplify.log`, envir=simplifications) assign("sqrt", `Simplify.sqrt`, envir=simplifications) assign("abs", `Simplify.abs`, envir=simplifications) assign("sign", `Simplify.sign`, envir=simplifications) assign("if", `Simplify.if`, envir=simplifications) assign("besselI", `Simplify.bessel`, envir=simplifications) assign("besselK", `Simplify.bessel`, envir=simplifications) #assign("<-", `Simplify.=`, envir=simplifications) #assign("=", `Simplify.=`, envir=simplifications) assign("{", `Simplify.{`, envir=simplifications) assign("%*%", `Simplify.%*%`, envir=simplifications) assign("$", `Simplify.$`, envir=simplifications) assign("[", `Simplify.[`, envir=simplifications) assign("[[", `Simplify.[[`, envir=simplifications) assign("||", `Simplify.||`, envir=simplifications) assign("&&", `Simplify.&&`, envir=simplifications) assign("ifelse", `Simplify.ifelse`, envir=simplifications) Deriv/R/Deriv.R0000644000176200001440000010401614671050461012726 0ustar liggesusers#' @name Deriv #' @title Symbolic differentiation of an expression or function #' @description Symbolic differentiation of an expression or function #' @aliases Deriv drule #' @concept symbolic differentiation #' #' @param f An expression or function to be differentiated. #' f can be \itemize{ #' \item a user defined function: \code{function(x) x**n} #' \item a string: \code{"x**n"} #' \item an expression: \code{expression(x**n)} #' \item a call: \code{call("^", quote(x), quote(n))} #' \item a language: \code{quote(x**n)} #' \item a right hand side of a formula: \code{~ x**n} or \code{y ~ x**n} #' } #' @param x An optional character vector with variable name(s) with respect to which #' \code{f} must be differentiated. If not provided (i.e. x=NULL), x is #' guessed either from \code{names(formals(f))} (if \code{f} is a function) #' or from all variables in f in other cases. #' To differentiate expressions including components of lists or vectors, i.e. by expressions like #' \code{p[1]}, \code{theta[["alpha"]]} or \code{theta$beta}, the vector of #' variables \code{x} #' must be a named vector. For the cited examples, the argument \code{x} must be given #' as follows \code{c(p="1", theta="alpha", theta="beta")}. #' Note the repeated name \code{theta} which must be provided for every component #' of the list \code{theta} by which a #' differentiation is required. #' @param env An environment where the symbols and functions are searched for. #' Defaults to \code{parent.frame()} for \code{f} expression and to #' \code{environment(f)} if \code{f} is a function. For primitive function, #' it is set by default to .GlobalEnv #' @param use.D An optional logical (default FALSE), indicates if base::D() #' must be used for differentiation of basic expressions. #' @param cache.exp An optional logical (default TRUE), indicates if #' final expression must be optimized with cached sub-expressions. #' If enabled, repeated calculations are made only once and their #' results stored in cache variables which are then reused. #' @param nderiv An optional integer vector of derivative orders to calculate. #' Default NULL value correspond to one differentiation. If length(nderiv)>1, #' the resulting expression is a list where each component corresponds to derivative order #' given in nderiv. Value 0 corresponds to the original function or expression non #' differentiated. All values must be non negative. If the entries in nderiv #' are named, their names are used as names in the returned list. Otherwise #' the value of nderiv component is used as a name in the resulting list. #' @param combine An optional character scalar, it names a function to combine #' partial derivatives. Default value is "c" but other functions can be #' used, e.g. "cbind" (cf. Details, NB3), "list" or user defined ones. It must #' accept any number of arguments or at least the same number of arguments as #' there are items in \code{x}. #' @param drule An optional environment-like containing derivative rules (cf. Details for syntax rules). #' #' @return \itemize{ #' \item a function if \code{f} is a function #' \item an expression if \code{f} is an expression #' \item a character string if \code{f} is a character string #' \item a language (usually a so called 'call' but may be also a symbol or just a numeric) for other types of \code{f} #' } #' #' @details #' R already contains two differentiation functions: \code{stats::D} and \code{stats:deriv}. #' \code{D} does #' simple univariate differentiation while \code{deriv} uses \code{D} #' to do multivariate #' differentiation. The output of \code{D} is an expression, whereas the output of #' \code{deriv} can be an executable function. #' #' R's existing functions have several limitations. They can probably be fixed, #' but since they are written in C, this would probably require a lot of work. #' Limitations include: #' \itemize{ #' \item The derivatives table can't be modified at runtime, and is only available #' in C. #' \item Function cannot substitute function calls. e.g.: #' f <- function(x, y) x + y; deriv(~f(x, x^2), "x") is not working. #' } #' #' So, here are the advantages of this implementation: #' #' \itemize{ #' \item It is entirely written in R, so would be easier to maintain. #' \item Can do multi-variate differentiation. #' \item Can differentiate function calls: #' \itemize{ #' \item if the function is in the derivative table, then the chain rule #' is applied. For example, if you declared that the derivative of #' \code{sin} is \code{cos}, then it would figure out how to call #' \code{cos} correctly in case of complex argument. #' \item if the function is not in the derivative table (or it is anonymous), #' then the function body is substituted in. #' \item these two methods can be mixed. An entry in the derivative table #' need not be self-contained -- you don't need to provide an infinite #' chain of derivatives. #' } #' \item It's easy to add custom entries to the derivatives table, e.g. #' #' \code{drule[["cos"]] <- alist(x=-sin(x))} #' #' The chain rule will be automatically applied if needed. In their custom rules, #' users should avoid using variable names like \code{.e1}, \code{.e2} etc. which #' can be confounded with those automatically created by \code{Deriv} for code caching #' purposes. #' \item The output is an executable function, which makes it suitable #' for use in optimization problems. #' \item Compound functions (i.e. piece-wise functions based on if-else operator) can #' be differentiated (cf. examples section). #' \item in case of multiple derivatives (e.g. gradient and hessian calculation), #' caching can make calculation economies for both #' \item Starting from v4.0, some matrix calculus operations are possible (contribution of Andreas Rappold). See an example hereafter for differentiation of the inverse of 2x2 matrix and whose elements depend on variable of differentiation \code{x}. #' } #' #' Two environments \code{drule} and \code{simplifications} are #' exported in the package's NAMESPACE. #' As their names indicate, they contain tables of derivative and #' simplification rules. #' To see the list of defined rules do \code{ls(drule)}. #' To add your own derivative rule for a function called say \code{sinpi(x)} calculating sin(pi*x), do \code{drule[["sinpi"]] <- alist(x=pi*cospi(x))}. #' Here, "x" stands for the first and unique argument in \code{sinpi()} definition. For a function that might have more than one argument, #' e.g. \code{log(x, base=exp(1))}, the drule entry must be a list with a named rule #' per argument. See \code{drule$log} for an example to follow. #' After adding \code{sinpi} you can differentiate expressions like #' \code{Deriv(~ sinpi(x^2), "x")}. The chain rule will automatically apply. #' #' Starting from v4.0, user can benefit from a syntax \code{.d_X} in the rule writing. #' Here \code{X} must be replaced by an argument name (cf. \code{drule[["solve"]]} for #' an example). A use of this syntax leads to a replacement of this place-holder by a #' derivative of the function (chain rule is automatically integrated) by the named argument. #' \cr #' Another v4.0 novelty in rule's syntax is a possible use of optional parameter #' \code{`_missing`} which can be set to TRUE or FALSE (default) to indicate how #' to treat missing arguments. By default, i.e. in absence of this parameter #' or set to FALSE, missing arguments were replaced by their default values. #' Now, if \code{`_missing`=TRUE} is specified in a rule, the missing arguments #' will be left missed in the derivative. Look \code{drule[["solve"]]} for an example. #' #' NB. In \code{abs()} and \code{sign()} function, singularity treatment #' at point 0 is left to user's care. #' For example, if you need NA at singular points, you can define the following: #' \code{drule[["abs"]] <- alist(x=ifelse(x==0, NA, sign(x)))} #' \code{drule[["sign"]] <- alist(x=ifelse(x==0, NA, 0))} #' #' NB2. In Bessel functions, derivatives are calculated only by the first argument, #' not by the \code{nu} argument which is supposed to be constant. #' #' NB3. There is a side effect with vector length. E.g. in #' \code{Deriv(~a+b*x, c("a", "b"))} the result is \code{c(a = 1, b = x)}. #' To avoid the difference in lengths of a and b components (when x is a vector), #' one can use an optional parameter \code{combine} #' \code{Deriv(~a+b*x, c("a", "b"), combine="cbind")} which gives #' \code{cbind(a = 1, b = x)} producing a two column matrix which is #' probably the desired result here. #' \cr Another example illustrating a side effect is a plain linear #' regression case and its Hessian: #' \code{Deriv(~sum((a+b*x - y)**2), c("a", "b"), n=c(hessian=2)} #' producing just a constant \code{2} for double differentiation by \code{a} #' instead of expected result \code{2*length(x)}. It comes from a simplification of #' an expression \code{sum(2)} where the constant is not repeated as many times #' as length(x) would require it. Here, using the same trick #' with \code{combine="cbind"} would not help as all 4 derivatives are just scalars. #' Instead, one should modify the previous call to explicitly use a constant vector #' of appropriate length: #' \code{Deriv(~sum((rep(a, length(x))+b*x - y)**2), c("a", "b"), n=2)} #' #' NB4. Differentiation of \code{*apply()} family (available starting from v4.1) is #' done only on the body of the \code{FUN} argument. It implies that this #' body must use the same variable names as in argument \code{x} and they must not #' appear in \code{FUN}s arguments (cf. GMM example). #' #' NB5. Expressions are differentiated as scalar ones. However in some cases, obtained result #' remains valid if the variable of differentiation is a vector. This is just a coincidence. #' If you need to differentiate by vectors, you can try to write your own differentiation rule. #' For example, derivative of \code{sum(x)} where \code{x} is a vector can be done as: #' \code{vsum=function(x) sum(x)} #' \code{drule[["vsum"]] <- alist(x=rep_len(1, length(x)))} # drule is exported from Deriv namespace #' \code{Deriv(~vsum(a*x), "x", drule=drule)} #' \code{# a * rep_len(1, length(a * x))} #' #' NB6. Since v4.2, it is possible to differentiate by named components of lists and vectors #' that are used in \code{with(data, expr)} expressions (cf. "with()" example). #' The names of argument \code{x} ("theta" in an example above) must be used #' directly, e.g \code{with(theta, ...)} or \code{with(as.list(theta), ...)}. #' Otherwise, the \code{expr} of \code{with()} will be differentiated as plain code. #' #' @author Andrew Clausen (original version) and Serguei Sokol (actual version and maintainer) #' @examples #' #' \dontrun{f <- function(x) x^2} #' \dontrun{Deriv(f)} #' # function (x) #' # 2 * x #' #' \dontrun{f <- function(x, y) sin(x) * cos(y)} #' \dontrun{Deriv(f)} #' # function (x, y) #' # c(x = cos(x) * cos(y), y = -(sin(x) * sin(y))) #' #' \dontrun{f_ <- Deriv(f)} #' \dontrun{f_(3, 4)} #' # x y #' # [1,] 0.6471023 0.1068000 #' #' \dontrun{Deriv(~ f(x, y^2), "y")} #' # -(2 * (y * sin(x) * sin(y^2))) #' #' \dontrun{Deriv(quote(f(x, y^2)), c("x", "y"), cache.exp=FALSE)} #' # c(x = cos(x) * cos(y^2), y = -(2 * (y * sin(x) * sin(y^2)))) #' #' \dontrun{Deriv(expression(sin(x^2) * y), "x")} #' # expression(2*(x*y*cos(x^2))) #' #' Deriv("sin(x^2) * y", "x") # differentiate only by x #' "2 * (x * y * cos(x^2))" #' #' Deriv("sin(x^2) * y", cache.exp=FALSE) # differentiate by all variables (here by x and y) #' "c(x = 2 * (x * y * cos(x^2)), y = sin(x^2))" #' #' # Compound function example (here abs(x) smoothed near 0) #' fc <- function(x, h=0.1) if (abs(x) < h) 0.5*h*(x/h)**2 else abs(x)-0.5*h #' Deriv("fc(x)", "x", cache.exp=FALSE) #' "if (abs(x) < h) x/h else sign(x)" #' #' # Example of a first argument that cannot be evaluated in the current environment: #' \dontrun{ #' suppressWarnings(rm("xx", "yy")) #' Deriv(xx^2+yy^2) #' } #' # c(xx = 2 * xx, yy = 2 * yy) #' #' # Automatic differentiation (AD), note intermediate variable 'd' assignment #' \dontrun{Deriv(~{d <- ((x-m)/s)^2; exp(-0.5*d)}, "x", cache.exp=FALSE)} #' #{ #' # d <- ((x - m)/s)^2 #' # .d_x <- 2 * ((x - m)/s^2) #' # -(0.5 * (.d_x * exp(-(0.5 * d)))) #' #} #' #' # Custom differentiation rule #' \dontrun{ #' myfun <- function(x, y=TRUE) NULL # do something useful #' dmyfun <- function(x, y=TRUE) NULL # myfun derivative by x. #' drule[["myfun"]] <- alist(x=dmyfun(x, y), y=NULL) # y is just a logical => no derivate #' Deriv(~myfun(z^2, FALSE), "z", drule=drule) #' # 2 * (z * dmyfun(z^2, FALSE)) #' } #' #' # Differentiation by list components #' \dontrun{ #' theta <- list(m=0.1, sd=2.) #' x <- names(theta) #' names(x)=rep("theta", length(theta)) #' Deriv(~exp(-(x-theta$m)**2/(2*theta$sd)), x, cache.exp=FALSE) #' # c(theta_m = exp(-((x - theta$m)^2/(2 * theta$sd))) * #' # (x - theta$m)/theta$sd, theta_sd = 2 * (exp(-((x - theta$m)^2/ #' # (2 * theta$sd))) * (x - theta$m)^2/(2 * theta$sd)^2)) #' } #' #' # Differentiation by list components used in "with()" expression (since v4.2) #' # Compare with precedent example. #' \dontrun{ #' theta <- list(m=0.1, sd=2.) #' x <- names(theta) #' names(x)=rep("theta", length(theta)) #' Deriv(~with(theta, exp(-(x-m)**2/(2*sd))), x, cache.exp=FALSE) #' # c(theta_m = with(theta, exp(-((x - m)^2/(2 * sd))) * (x - m)/sd), #' # theta_sd = with(theta, 2 * (exp(-((x - m)^2/(2 * sd))) * #' # (x - m)^2/(2 * sd)^2))) #' } #' # Differentiation in matrix calculus #' \dontrun{ #' Deriv(~solve(matrix(c(1, x, x**2, x**3), nrow=2, ncol=2))) #' } #' #' # Two component Gaussian mixture model (GMM) example #' \dontrun{ #' # define GMM probability density function -> p(x, ...) #' ncomp=2 #' a=runif(ncomp) #' a=a/sum(a) # amplitude or weight of each component #' m=rnorm(ncomp) # mean #' s=runif(ncomp) # sd #' # two column matrix of probabilities: one row per x value, one column per component #' pn=function(x, a, m, s, log=FALSE) { #' n=length(a) #' structure(vapply(seq(n), function(i) a[i]*dnorm(x, m[i], s[i], log), #' double(length(x))), dim=c(length(x), n)) #' } #' p=function(x, a, m, s) rowSums(pn(x, a, m, s)) # overall probability #' dp=Deriv(p, "x") #' # plot density and its derivative #' xp=seq(min(m-2*s), max(m+2*s), length.out=200) #' matplot(xp, cbind(p(xp, a, m, s), dp(xp, a, m, s)), #' xlab="x", ylab="p, dp/dx", type="l", main="Two component GMM") #' } Deriv <- function(f, x=if (is.function(f)) NULL else all.vars(if (is.character(f)) parse(text=f) else f), env=if (is.function(f)) environment(f) else parent.frame(), use.D=FALSE, cache.exp=TRUE, nderiv=NULL, combine="c", drule=Deriv::drule) { tf <- try(f, silent=TRUE) fch <- deparse1(substitute(f)) if (is.null(f)) return(NULL) if (is.primitive(f)) { # get the true function name (may be after renaming in caller env like f=cos) fch=sub('^\\.Primitive\\("(.+)"\\)', "\\1", format1(f)) } if (inherits(tf, "try-error")) { f <- substitute(f) } # create dsym and scache local envs (to keep clean nested calls) dsym <- new.env() dsym$l <- list() scache <- new.env() scache$l <- list() if (is.null(env)) env <- .GlobalEnv if (is.null(x)) { # primitive function or function given by a list member or alike if (is.function(f)) { af <- formals(args(f)) } else { af <- formals(f) } x <- names(af) rule <- drule[[fch]] if (!is.null(rule)) { # exclude arguments by which we cannot not differentiate from x x=as.list(x) x[sapply(rule, is.null)] <- NULL if (length(x) == 0) { stop(sprintf("There is no differentiable argument in the function %s", fch)) } x=unlist(x) } if (is.function(f)) { #browser() rmget=mget(fch, mode="function", envir=env, inherits=TRUE, ifnotfound=NA) if (!is.function(rmget[[fch]])) { # no function with name stored in fch => replace it by its body fd=body(f) } else { fd <- as.call(c(as.symbol(fch), lapply(names(af), as.symbol))) } } pack_res <- as.call(alist(as.function, c(af, list(res)), envir=env)) } else { x[] <- as.character(x) if (any(nchar(x) == 0)) { stop("Names in the second argument must not be empty") } fd <- NULL } # prepare fd (a call to differentiate) # and pack_res (a call to evaluate and return as result) if (!is.null(fd)) { ; # we are already set } else if (is.character(f)) { # f is to parse fd <- parse(text=f)[[1]] pack_res <- as.call(alist(format1, res)) } else if (is.function(f)) { #browser() b <- body(f) if ((is.call(b) && (b[[1]] == as.symbol(".Internal") || b[[1]] == as.symbol(".External") || b[[1]] == as.symbol(".Call"))) || (is.null(b) && (is.primitive(f)) || !is.null(drule[[fch]]))) { if (fch %in% dlin || fch %in% names(dplin) || !is.null(drule[[fch]])) { arg <- lapply(names(formals(args(f))), as.symbol) fd <- as.call(c(as.symbol(fch), arg)) pack_res <- as.call(alist(as.function, c(formals(args(f)), list(res)), envir=env)) } else { stop(sprintf("Internal or external function '%s()' is not in derivative table.", fch)) } } else { fd <- b pack_res <- as.call(alist(as.function, c(formals(f), list(res)), envir=env)) } } else if (is.expression(f)) { fd <- f[[1]] pack_res <- as.call(alist(as.expression, res)) } else if (is.language(f)) { if (is.call(f) && f[[1]] == as.symbol("~")) { # rhs of the formula fd <- f[[length(f)]] pack_res <- quote(res) } else { # plain call derivation fd <- f pack_res <- quote(res) } } else { fd <- substitute(f) pack_res <- quote(res) #stop("Invalid type of 'f' for differentiation") } res <- Deriv_(fd, x, env, use.D, dsym, scache, combine, drule.=drule) if (!is.null(nderiv)) { # multiple derivatives # prepare their names if (any(nderiv < 0)) { stop("All entries in nderiv must be non negative") } nm_deriv <- names(nderiv) nderiv <- as.integer(nderiv) if (is.null(nm_deriv)) nm_deriv <- nderiv iempt <- nchar(nm_deriv)==0 nm_deriv[iempt] <- seq_along(nderiv)[iempt] # prepare list of repeated derivatives lrep <- as.list(nderiv) names(lrep) <- nm_deriv # check if 0 is nderiv iz <- nderiv==0 lrep[iz] <- list(fd) # set first derivative i <- nderiv==1 lrep[i] <- list(res) maxd <- max(nderiv) for (ider in seq_len(maxd)) { if (ider < 2) next res <- Deriv_(res, x, env, use.D, dsym, scache, combine, drule.=drule) i <- ider == nderiv lrep[i] <- list(res) } if (length(lrep) == 1) { res <- lrep[[1]] } else { res <- as.call(c(quote(list), lrep)) } } #browser() if (cache.exp) res <- Cache(Simplify(deCache(res), scache=scache)) else res <- Simplify(res, scache=scache) eval(pack_res) } # workhorse function doing the main work of differentiation Deriv_ <- function(st, x, env, use.D, dsym, scache, combine="c", drule.=Deriv::drule) { if (is.null(st)) return(NULL) stch <- format1(if (is.call(st)) st[[1]] else st) # Make x scalar and wrap results in a c() call if length(x) > 1 iel=which("..." == x) if (length(iel) > 0) { # remove '...' from derivable arguments x=as.list(x) x[iel]=NULL x=unlist(x) } nm_x <- names(x) if (!is.null(nm_x)) nm_x[is.na(nm_x)] <- "" else nm_x <- rep("", length(x)) if (length(x) > 1 && stch != "{") { #browser() # many variables => recursive call on single name # we exclude the case '{' as we put partial derivs inside of '{' # so it can be well optimized by Cache() res <- lapply(seq_along(x), function(ix) Deriv_(st, x[ix], env, use.D, dsym, scache, combine, drule.=drule.)) names(res) <- if (is.null(nm_x)) x else ifelse(is.na(nm_x) | nchar(nm_x) == 0, x, paste(nm_x, x, sep="_")); return(as.call(c(as.symbol(combine), res))) } # differentiate R statement 'st' (a call, or a symbol or numeric) by a name in 'x' get_sub_x <- !(is.null(nm_x) | nchar(nm_x) == 0 | is.na(nm_x)) is_index_expr <- is.call(st) && any(format1(st[[1]]) == c("$", "[", "[[")) is_sub_x <- is_index_expr && format1(st[[2]]) == nm_x && format1(st[[3]]) == x #browser() if (is.conuloch(st)) { return(0) } else if (is_index_expr && !is_sub_x) { #browser() st[[2]] <- Deriv_(st[[2]], x, env, use.D, dsym, scache, drule.=drule.) if (identical(st[[2]], 0) || identical(st[[2]], 0L)) { return(0) } else { return(Simplify(st, scache=scache)) } } else if (length(x) == 1 && (is.symbol(st) || (get_sub_x && is_index_expr))) { #browser() stch <- format1(st) if ((stch == x && !get_sub_x) || (get_sub_x && is_sub_x)) { return(1) } else if ((get_sub_x && is_index_expr && !is_sub_x) || (if (get_sub_x) is.null(dsym$l[[nm_x]][[x]][[stch]]) else is.null(dsym$l[[x]][[stch]]))) { return(0) } else { return(if (get_sub_x) dsym$l[[nm_x]][[x]][[stch]] else dsym$l[[x]][[stch]]) } } else if (is.call(st)) { #browser() stch <- format1(st[[1]]) args <- as.list(st)[-1] if (stch %in% dlin) { # linear case # differentiate all arguments then pass them to the function dargs <- lapply(args, Deriv_, x, env, use.D, dsym, scache, drule.=drule.) return(Simplify_(as.call(c(st[[1]], dargs)), scache)) } else if (stch %in% names(dplin)) { #browser() # partial linear case # differentiate part of arguments then pass them to the function stmc=match.call(args(stch), st) args <- as.list(stmc)[-1] nmd=dplin[[stch]] stmc[nmd]=lapply(as.list(stmc)[nmd], Deriv_, x, env, use.D, dsym, scache, drule.=drule.) return(Simplify_(stmc, scache)) } nb_args=length(st)-1 # special cases: out of rule table or args(stch) -> NULL if (stch == "{") { #browser() # AD differentiation (may be with many x) res <- list(st[[1]]) # initiate dsym[[x[ix]]] or dsym[[nm_x[ix]}}[[x[ix]]] for (ix in seq_along(x)) { if (get_sub_x[ix]) { if (is.null(dsym$l[[nm_x[ix]]][[x[ix]]])) dsym$l[[nm_x[ix]]][[x[ix]]] <- list() } else { if (is.null(dsym$l[[x[ix]]])) dsym$l[[x[ix]]] <- list() } } # collect defined var names (to avoid re-differentiation) defs <- sapply(args, function(e) if (is.assign(e)) format1(e[[2]]) else "") # alva <- list() last_res <- list() for (iarg in seq_along(args)) { #browser() a <- args[[iarg]] if (is.assign(a)) { if (!is.symbol(a[[2]])) stop(sprintf("In AD mode, don't know how to deal with a non symbol '%s' at lhs", format1(a[[2]]))) # put in scache the assignment ach <- format1(a[[2]]) for (ix in seq_along(x)) { d_ach <- paste(".", ach, "_", x[ix], sep="") d_a <- as.symbol(d_ach) if (any(d_ach == defs)) { # already differentiated in previous calls if (get_sub_x[ix]) dsym$l[[nm_x[ix]]][[x[ix]]][[ach]] <- d_a else dsym$l[[x[ix]]][[ach]] <- d_a next } de_a <- Deriv_(a[[3]], x[ix], env, use.D, dsym, scache, drule.=drule.) if (get_sub_x[ix]) dsym$l[[nm_x[ix]]][[x[ix]]][[ach]] <- de_a else dsym$l[[x[ix]]][[ach]] <- de_a if (is.numconst(de_a, 0)) { if (iarg < length(args)) next } else if (!is.call(de_a)) { if (iarg < length(args)) next } if (get_sub_x[ix]) dsym$l[[nm_x[ix]]][[x[ix]]][[ach]] <- d_a else dsym$l[[x[ix]]][[ach]] <- d_a res <- append(res, call("<-", d_a, de_a)) # alva <- append(alva, list(c(d_ach, all.vars(de_a)))) # store it in scache too #scache$l[[format1(de_a)]] <- as.symbol(d_a) if (iarg == length(args)) last_res[[ix]] <- d_a } Simplify_(a, scache) res <- append(res, a) # alva <- append(alva, list(all.vars(a))) if (iarg == length(args)) { names(last_res) <- ifelse(get_sub_x, paste(nm_x, x, sep="_"), x) res <- append(res, as.call(c(as.symbol(combine), last_res))) } } else { de_a <- lapply(seq_along(x), function(ix) Deriv_(a, x[ix], env, use.D, dsym, scache, drule.=drule.)) if (length(x) > 1) { names(de_a) <- ifelse(get_sub_x, paste(nm_x, x, sep="_"), x) res <- append(res, as.call(c(as.symbol(combine), de_a))) } else { res <- append(res, de_a) } } } return(Simplify(as.call(res))) } else if (is.uminus(st)) { return(Simplify(call("-", Deriv_(st[[2]], x, env, use.D, dsym, scache, drule.=drule.)), scache=scache)) } else if (stch == "(") { #browser() return(Simplify(Deriv_(st[[2]], x, env, use.D, dsym, scache, drule.=drule.), scache=scache)) } else if (stch == "if") { return(if (nb_args == 2) Simplify(call("if", st[[2]], Deriv_(st[[3]], x, env, use.D, dsym, scache, drule.=drule.)), scache=scache) else Simplify(call("if", st[[2]], Deriv_(st[[3]], x, env, use.D, dsym, scache, drule.=drule.), Deriv_(st[[4]], x, env, use.D, dsym, scache, drule.=drule.)), scache=scache)) } else if (stch == "with") { #browser() if (format1(st[[2L]]) %in% nm_x || (is.call(st[[2L]]) && format1(st[[2L]][[1L]]) == "as.list" && format1(st[[2L]][[2L]]) %in% nm_x)) { # diff expr of with() by unnamed x return(Simplify(call("with", st[[2]], Deriv_(st[[3]], unname(x), env, use.D, dsym, scache, drule.=drule.)), scache=scache)) } else { # diff expr as is return(Simplify(call("with", st[[2]], Deriv_(st[[3]], x, env, use.D, dsym, scache, drule.=drule.)), scache=scache)) } } rule <- drule.[[stch]] if (is.null(rule) && !identical(drule., Deriv::drule)) rule <- Deriv::drule[[stch]] # complete by the classic table if (is.null(rule)) { #browser() # no derivative rule for this function # see if its arguments depend on x. If not, just send 0 dargs <- lapply(args, Deriv_, x, env, use.D, dsym, scache, drule.=drule.) if (all(sapply(dargs, identical, 0))) { return(0) } # otherwise try to get the body and differentiate it ff <- get(stch, mode="function", envir=env) bf <- body(ff) if (is.null(bf)) { stop(sprintf("Could not retrieve body of '%s()'", stch)) } if (is.call(bf) && (bf[[1]] == as.symbol(".External") || bf[[1]] == as.symbol(".Internal") || bf[[1]] == as.symbol(".Call"))) { #cat("aha\n") stop(sprintf("Function '%s()' is not in derivative table", stch)) } mc <- match.call(ff, st) af=formals(args(ff)) # formal args # update af with mc to get actual arguments -> aa aa=modifyList(af, as.list(mc)[-1]) st <- Simplify_(do.call("substitute", list(bf, aa)), scache) dst <- Deriv_(st, x, env, use.D, dsym, scache, drule.=drule.) #dst <- Simplify(do.call("substitute", list(dst, aa)), scache) # missed arguments can appear from drule # wrap new body in f_d_x(), add it to drule and place a call to it return(dst) } # there is a rule! if (use.D) { return(Simplify(D(st, x), scache=scache)) } #if (stch == "vsum") #browser() # prepare replacement list da <- try(args(stch), silent=TRUE) if (inherits(da, "try-error")) { # last chance to get unknown function definition # may be it is a user defined one? da <- args(get(stch, mode="function", envir=env)) } mc <- as.list(match.call(definition=da, call=st, expand.dots=FALSE))[-1] da <- as.list(da) da <- da[-length(da)] # all declared arguments with default values if (isTRUE(rule$`_missing`)) { aa <- mc aa[setdiff(names(da), names(mc))] <- list(alist(x=)$x) # missing arguments are set missing } else { aa <- modifyList(da, mc) # all arguments with actual values } #browser() rule$`_missing`=NULL # deCache rule expressions rule <- lapply(rule, deCache) # actualize the rule with actual arguments rule <- lapply(rule, function(r) do.call("substitute", list(r, aa))) # which arguments can be differentiated? iad <- which(!sapply(rule, is.null)) rule <- rule[iad] lsy <- unlist(lapply(dsym$l, function(it) if (get_sub_x && is.list(it)) unlist(lapply(it, ls, all.names=TRUE)) else ls(it, all.names=TRUE))) if (!any(names(which(sapply(mc, function(it) {av <- all.vars(it); (if (get_sub_x) any(nm_x == av) else any(x == av)) || any(av %in% lsy)}))) %in% names(rule))) { #warning(sprintf("A call %s cannot be differentiated by the argument '%s'", format1(st), x)) return(0) } dargs <- lapply(names(rule), function(nm_a) if (is.null(mc[[nm_a]])) 0 else Deriv_(mc[[nm_a]], x, env, use.D, dsym, scache, drule.=drule.)) names(dargs) <- names(rule) ize <- sapply(dargs, identical, 0) | sapply(dargs, identical, matrix(0)) dargs <- dargs[!ize] rule <- rule[!ize] if (length(rule) == 0) { return(0) } #browser() # actualize the rule with differentiated arguments lrep=structure(dargs, names=paste0('.d_', names(dargs))) rule <- lapply(rule, methods::substituteDirect, lrep) # apply chain rule where needed if (! stch %in% c("matrix", "%*%", "det", "solve", "diag")) { ione <- sapply(dargs, identical, 1) imone <- sapply(dargs, identical, -1) for (i in seq_along(rule)[!(ione|imone)]) { rule[[i]] <- Simplify(call("*", dargs[[i]], rule[[i]]), scache=scache) } for (i in seq_along(rule)[imone]) { rule[[i]] <- Simplify(call("-", rule[[i]]), scache=scache) } } return(Simplify(li2sum(rule), scache=scache)) } else if (is.function(st)) { #browser() # differentiate its body if can get it args <- as.list(st)[-1] names(args)=names(formals(ff)) if (is.null(names(args))) { stop(sprintf("Could not retrieve arguments of '%s()'", stch)) } st <- do.call("substitute", list(body(ff), args)) Deriv_(st, x, env, use.D, dsym, scache, drule.=drule.) } else { stop("Invalid type of 'st' argument. It must be constant, symbol or a call.") } } arg_missing <- function(x) missing(x) drule <- new.env() # linear functions, i.e. d(f(x))/dx == f(d(arg)/dx) dlin=c("+", "-", "c", "t", "sum", "cbind", "rbind", "list") # partially linear functions, i.e. linear only on a subset of arguments # here, function name points to a vector of argument names (or indexes in a full call) which we have to differentiate dplin=list(apply="FUN", lapply="FUN", sapply="FUN", vapply="FUN", lapply="FUN", ifelse=c("yes", "no"), "function"=3L, rep="x", rep.int="x", rep_len="x", rowSums="x", colSums="x", rowMeans="x", colMeans="x", structure=".Data" ) # rule table # arithmetic drule[["*"]] <- alist(e1=e2, e2=e1) drule[["^"]] <- alist(e1=e2*e1^(e2-1), e2=e1^e2*log(e1)) drule[["/"]] <- alist(e1=1/e2, e2=-e1/e2^2) # log, exp, sqrt drule[["sqrt"]] <- alist(x=0.5/sqrt(x)) drule[["log"]] <- alist(x=1/(x*log(base)), base=-log(x, base)/(base*log(base))) drule[["logb"]] <- drule[["log"]] drule[["log2"]] <- alist(x=1/(x*log(2))) drule[["log10"]] <- alist(x=1/(x*log(10))) drule[["log1p"]] <- alist(x=1/(x+1)) drule[["exp"]] <- alist(x=exp(x)) drule[["expm1"]] <- alist(x=exp(x)) # trigonometric drule[["sin"]] <- alist(x=cos(x)) drule[["cos"]] <- alist(x=-sin(x)) drule[["tan"]] <- alist(x=1/cos(x)^2) drule[["asin"]] <- alist(x=1/sqrt(1-x^2)) drule[["acos"]] <- alist(x=-1/sqrt(1-x^2)) drule[["atan"]] <- alist(x=1/(1+x^2)) drule[["atan2"]] <- alist(y=x/(x^2+y^2), x=-y/(x^2+y^2)) if (getRversion() >= "3.1.0") { drule[["sinpi"]] <- alist(x=pi*cospi(x)) drule[["cospi"]] <- alist(x=-pi*sinpi(x)) drule[["tanpi"]] <- alist(x=pi/cospi(x)^2) } # hyperbolic drule[["sinh"]] <- alist(x=cosh(x)) drule[["cosh"]] <- alist(x=sinh(x)) drule[["tanh"]] <- alist(x=(1-tanh(x)^2)) drule[["asinh"]] <- alist(x=1/sqrt(x^2+1)) drule[["acosh"]] <- alist(x=1/sqrt(x^2-1)) drule[["atanh"]] <- alist(x=1/(1-x^2)) # sign depending functions drule[["abs"]] <- alist(x=sign(x)) drule[["sign"]] <- alist(x=0) #drule[["abs"]] <- alist(x=ifelse(x==0, NA, sign(x))) #drule[["sign"]] <- alist(x=ifelse(x==0, NA, 0)) # special functions drule[["besselI"]] <- alist(x=(if (nu == 0) besselI(x, 1, expon.scaled) else 0.5*(besselI(x, nu-1, expon.scaled) + besselI(x, nu+1, expon.scaled)))-if (expon.scaled) besselI(x, nu, TRUE) else 0, nu=NULL, expon.scaled=NULL) drule[["besselK"]] <- alist(x=(if (nu == 0) -besselK(x, 1, expon.scaled) else -0.5*(besselK(x, nu-1, expon.scaled) + besselK(x, nu+1, expon.scaled)))+if (expon.scaled) besselK(x, nu, TRUE) else 0, nu=NULL, expon.scaled=NULL) drule[["besselJ"]] <- alist(x=if (nu == 0) -besselJ(x, 1) else 0.5*(besselJ(x, nu-1) - besselJ(x, nu+1)), nu=NULL) drule[["besselY"]] <- alist(x=if (nu == 0) -besselY(x, 1) else 0.5*(besselY(x, nu-1) - besselY(x, nu+1)), nu=NULL) drule[["gamma"]] <- alist(x=gamma(x)*digamma(x)) drule[["lgamma"]] <- alist(x=digamma(x)) drule[["digamma"]] <- alist(x=trigamma(x)) drule[["trigamma"]] <- alist(x=psigamma(x, 2L)) drule[["psigamma"]] <- alist(x=psigamma(x, deriv+1L), deriv=NULL) drule[["beta"]] <- alist(a=beta(a, b)*(digamma(a)-digamma(a+b)), b=beta(a, b)*(digamma(b)-digamma(a+b))) drule[["lbeta"]] <- alist(a=digamma(a)-digamma(a+b), b=digamma(b)-digamma(a+b)) # probability densities drule[["dbinom"]] <- alist(x=NULL, size=NULL, prob=ifelse(x == 0, -size*(1-prob)^(size-1), ifelse (x == size, size*prob^(size-1), dbinom(x, size, prob)*(x-prob*size)/(prob-prob*prob)))/(if (log) dbinom(x, size, prob, log=FALSE) else 1)) drule[["dnorm"]] <- alist(x=-(x-mean)/sd^2*(if (log) 1 else dnorm(x, mean, sd)), mean=(x-mean)/sd^2*(if (log) 1 else dnorm(x, mean, sd)), sd=(((x - mean)/sd)^2 - 1)/sd * (if (log) 1 else dnorm(x, mean, sd)), log=NULL) drule[["pnorm"]] <- alist(q=dnorm(q, mean, sd)*(if (lower.tail) 1 else -1)/(if (log.p) pnorm(q, mean, sd, lower.tail) else 1), mean=dnorm(q, mean, sd)*(if (lower.tail) -1 else 1)/(if (log.p) pnorm(q, mean, sd, lower.tail) else 1), sd=dnorm(q, mean, sd)*(mean-q)/sd*(if (lower.tail) 1 else -1)/(if (log.p) pnorm(q, mean, sd, lower.tail) else 1), lower.tail=NULL, log.p=NULL) drule[["qnorm"]] = alist(p=(if(lower.tail) 1 else -1)*(if(log.p) exp(p) else 1)/dnorm(qnorm(p, mean=mean, sd=sd, lower.tail=lower.tail, log.p=log.p), mean=mean, sd=sd), mean=1, sd=(qnorm(p, mean=mean, sd=sd, lower.tail=lower.tail, log.p=log.p) - mean)/sd) # data mangling drule[["length"]] <- alist() # derivative is always 0 # matrix calculus drule[["matrix"]] <- alist(`_missing`=TRUE, data=matrix(.d_data, nrow=nrow, ncol=ncol, byrow=byrow, dimnames=dimnames)) drule[["%*%"]] <- alist(x=.d_x%*%y, y=x%*%.d_y) drule[["det"]] <- alist(x=det(x)*sum(diag(as.matrix(solve(x, .d_x))))) drule[["solve"]] <- alist(`_missing`=TRUE, a=-solve(a)%*%.d_a%*%solve(a, b), b=solve(a, .d_b)) drule[["diag"]] = alist(`_missing`=TRUE, x=(if (!is.matrix(x) && length(x) == 1 && arg_missing(nrow) && arg_missing(ncol)) matrix(0, nrow=x, ncol=x) else diag(x=.d_x, nrow, ncol, names=names))) Deriv/cleanup0000755000176200001440000000033215025260500012671 0ustar liggesusersfind \( -name '*.bck' -o -name '*.o' -o -name '*.so' -o -name .RData -o -name .Rhistory -o -name '*.dll' -o -name '*.a' -o -name '*.mod' \) -exec rm -f {} \; find \( -name 'tmp' -o -name 'build' \) -exec rm -fr {} \; Deriv/NEWS0000644000176200001440000002567715025256562012053 0ustar liggesusersVersion 4.2.0 ============= * 2025-06-20 - added `with()` construct - fixed as.integer() for big numbers in simplification of fractions (fixing issue #29) Version 4.1.6 ============= * 2024-09-13 - fixed Simplify(x^x+x^x*log(x)) Version 4.1.5 ============= * 2023-01-18 - fixed deparse() use (issue #26, reported and resolved by philschus@github) Version 4.1.4 ============= * 2021-12-15 - fixed dbinom rule and corresponding test (issue #25, reported by Rolf Turner, U. of Auckland) - fixed use of new and incomplete environment with new rule(s) (idem) - fixed use of composed expressions, e.g. {...} in drule (idem) Version 4.1.3 ============= * 2021-02-24 - added 'drule=drule' argument to 'Deriv()' for easier derivative rule customization Version 4.1.2 ============= * 2020-12-10 - added 'check.environment=FALSE' to tests on functions (requested by CRAN team to conform to new R-devel feature) Version 4.1.1 ============= * 2020-10-26 - fixed formatting some '{...}' expressions leading to wrong simplifications and hence wrong results (reported by Bertrand KOEBEL, Strasbourg University, France) - added a simplification case for '{...}' expressions - fixed left browser() call Version 4.1.0 ============= * 2020-10-02 - added new category of functions: partially linear (i.e. linear on a subset of their arguments) - rewritten with(data){expr}, ifelse(test,yes,no), rep(x,...), rep.int(x,n) and rep_len(x,n) cases as partially linear functions - added *apply() family of functions (differentiation of FUN argument) - added rowSums(), colSums(), rowMeans(), colMeans() - added differentiation of anonymous function bodies - added example and test on 2 component Gaussian mixture model. - fixed NULL entry to Deriv() - fixed missed x fulfillment for calls just by function name - fixed format1() for function formatting - fixed Simplify() evaluating stop() in expressions - fixed Simplify() omitting missed arguments in '[' calls - fixed Cache() placing and using local function variables out of their scope Version 4.0.1 ============= * 2020-08-20 - added differentiation with respect to 'expr' in a language construct 'with(data, expr)' (due to Oscar Garcia ) Version 4.0 =========== * 2019-12-10 - added matrix calculus (contribution from Andreas Rappold, issue #20). Additional functions that can be differentiated now are: matrix(), solve(), det(), diag() and `%*%` - added qnorm() differentiation rule (contribution idem) Version 3.9.0 ============= * 2019-09-20 - added AD-like differentiation of values stored in an explicitly identified component of a list or vector - added differentiation by variables stored in a matrix - fixed missing Simplify() call when cache.exp is FALSE - fixed "length > 1 in coercion to logical" Version 3.8.5 ============= * 2018-06-11 - fixed Deriv::Simplify(quote(y + c(1, 2))) (issue #18) - fixed Deriv::Simplify(quote(y + c(0, 1))) (issue #19) - fixed format1() for numerical vectors requiring different digit numbers Version 3.8.4 ============= * 2018-02-15 - fixed calls to Deriv() when f is a closure (issue #17) - fixed call to Deriv_() when some arguments of f are not differentiable Version 3.8.3 ============= * 2017-11-21 - fixed derivation of arguments passed as c() call (issue #15) - edited README.md to push forward possibility to add custom differentiation rules (issue #16) Version 3.8.2 ============= * 2017-10-16 - fixed mixing part of returned function body and its arguments when the result is a constant vector of length > 1 (issue #14) Version 3.8.1 ============= * 2017-06-13 - fixed use of argument 'combine' (which was ignored in some cases) - added proceeding of renamed primitive functions (e.g. f=cos; Deriv(f)) (issue #10) Version 3.8.0 ============= * 2016-11-22 - variable reassignment is now allowed in the body of differentiated function (issue #12) - added new optional parameter 'combine' which can be helpful in multivariate context - added rep.int() and rep_len() to the table of derivative definitions - added list() to the table of linear functions - fixed format1() for '{...}' language expression - in the manual, added NB3 remark about possible vector length issues - fixed some simplification cases when a constant numerical vector is a part of the expression - fixed automatic numerical diff. tests for rep.int() and rep_len() Version 3.7.0 ============= * 2016-04-05 - added optional parameter nderiv for multiple derivatives - expressions with indexes other than variable of differentiation are considered as constants (fixes issue#8, reported by genwei007@github) - functions that are not in drule table and not depending on x, differentiate to 0 - for x=NULL, fixed x guess by excluding non differentiable arguments - fixed presence of '...' in function argument list - added rep() function for differentiation - in Cache(), simple subindex expressions are no more cached Version 3.6.1 ============= * 2016-01-19 - added 'ifelse' function to differentiable expressions (AleMorales@github) - fixed trying to differentiate arguments that should not be Version 3.6.0 ============= * 2015-11-04 - added differentiation by named components of vectors or lists - added deCache() call prior to Cache(). - fixed over-simplification in composite functions (issue #6 submitted by VilmosProkaj@github) - removed qlist() usage, deprecated from v3.5.3 Version 3.5.6 ============= * 2015-09-23 - fixed circular variable definitions in Cache() (issue #5 submitted by notEvil@github) - fixed simplification of "{...; const}" expressions - fixed NOTEs from r-devel Version 3.5.5 ============= * 2015-06-11 - fixed assignement order in Deriv_() and Cache() (issue #5 submitted by notEvil@github) Version 3.5.4 ============= * 2015-06-09 - added the left hand side of assignment operator to simplification cache - Cache() is optimized to use assignements already present in the expression - fixed placement of auxiliary variable in Cache() - AD produces better code for multiple x Version 3.5.3 ============= * 2015-06-03 - qlist() is re-exported and signaled as deprecated. It will be removed in v3.6 - added simplification log(1+x) -> log1p(x) - fixed power simplification in rational expressions (issue #4 submitted by notEvil@github) - fixed unnecessary repetetive differentiation in case of higher order derivatives - fixed alphabetique term order in simple additions Version 3.5.2 ============= * 2015-05-28 - fixed limit of 10000 chars for variable names in scache and dsym (issue #3 submitted by notEvil@github) Version 3.5.1 ============= * 2015-05-27 - fixed Cache() when applied to c() expression Version 3.5 =========== * 2015-05-26 - fixed abusive capturing of error messages in Simplify() (issue #1, reported by notEvil@github) - fixed interference in dsym and scache environements in nested calls to Deriv() (issue #2, reported by notEvil@github) - the function qlist() is deprecated for rule creation. Use alist() instead (seen in issue #1) - added pnorm() for derivative table (based on suggestion in issue # 1) - minor twiks in the documentation Version 3.4 =========== * 2015-05-05 - fixed usage of sinpi() and alike in R older than 3.1.0 (reported by R-core team) - fixed dependence of term order on LC_COLLATE in test suite Version 3.3 =========== * 2015-04-10 - fixed qlist() export in namespace (reported by Irucka Embry) - fixed drule example in Deriv-package manual and some other minor typos Version 3.2 =========== * 2015-04-07 - fixed date format in DESCRIPTION - reference to rSymPy in the package manual Version 3.1 =========== * 2015-04-07 - new syntaxe for the rule table to simplify rule writing (chain rule is implicite, non need for quote() calls) - added dbinom() and dnorm() to derivative table - sums are ordered alphabeticaly now - several bugs are fixed Version 3.0 =========== * 2015-03-06 - Added automatic differentiation (AD) of a code with intermediate assignements - Added optional expression caching (enabled by default) - Added new functions to rule table: abs() and sign(); special functions (beta(), gamma(), bessel() and co.; sinpi(), cospi(), tanpi(), atan2(), log1p(), expm1() - Added factorization of sum expressions - Added optional use.D parameter - In manual, added an example for compound function differentiation - If not provided, variable names are guessed from an expression to differentiate - If cannot be evaluted or evaluates to numeric type, the first argument of Deriv() and Simplify() is considered as a language expression - In unit tests, added comparison with an estimation by central differences - Fixed Deriv(`-`) call - Fixed Deriv(f) when f is of type .Internal() Version 2.0 =========== * 2015-02-05 - New derivative engine suppresses a need for helper functions like neg.sin() - Derivative table of differetiable functions is completed by trigonometric fucntions and their inverse as well as hyperbolic functions and their inverse - Derivative table admits different rules for a function called with different number of arguments. E.g., log() can be differentiated when called with one or two arguments. In the latter case, the base which can be constant or variable, is different from exp(1)) - New syntax in derivative table facilitates adding user defined functions to differentiate. The same function can have several rules of differentiation depending on the number of arguments at the call moment - Deriv() is now the only entry point for all expressions to derive. No more need for Deriv.function() which is suppressed - It is now possible to pass primitive function as first argument, e.g. Deriv(sin) - In addition to previously possible differentiation of functions and expressions, the argument to differentiate can be submitted as * character string, e.g. '"x**2"' * right hand side of a formula, e.g '~ x**2' * quote() call, e.g 'quote(x**2)' - Power expression can be differentiated with symbolic power, e.g. 'x**n' or 'x^n' - Simplifications are pushed further for rational expressions (i.e. having terms united by '*' and/or '/'), all numeric terms are explicitly calculated and identical terms in numerator and denominator are simplified, identical factors are regrouped in a power term. - Simplifications are pushed further for linear combinations where identical terms are grouped in one term and their numerical coefficients are summed. - Added some simplifications for log(), exp(), power function, sqrt() and abs() - Some unit tests are added for Deriv() and Simplfy() (based on testthat package) Version 1.0 =========== * 2014-12-10 - Andrew Clausen passed the maintenance to Serguei Sokol - Serguei Sokol has fixed a bug in simplification of "a-b" - revamped the documentation and code as an R package - put the code to GitHub https://github.com/sgsokol/Deriv - submitted the package to CRAN * 2009-2-21 Mark Reid's patch * 2007 Andrew Clausen has written an original code Deriv.R and Simplify.R distributed on his site https://andrewclausen.net/computing/deriv.html Deriv/NAMESPACE0000644000176200001440000000031213573730646012554 0ustar liggesusersexport(Deriv, Simplify, format1, drule, simplifications, Cache, deCache) importFrom("stats", "D") importFrom("utils", "modifyList") importFrom("utils", "head") importFrom("methods", "substituteDirect") Deriv/inst/0000755000176200001440000000000014671052277012313 5ustar liggesusersDeriv/inst/CITATION0000644000176200001440000000052614671052277013453 0ustar liggesusersbibentry(bibtype = "Manual", title = "{Deriv}: R-based Symbolic Differentiation", author = c(person(given="Andrew", family="Clausen"), person(given="Serguei", family="Sokol")), year = 2024, note = "Deriv package version 4.2", url = "https://CRAN.R-project.org/package=Deriv" ) Deriv/README.md0000644000176200001440000000400013241322676012602 0ustar liggesusersDeriv ===== Symbolic differentiation ------------------------- The original version of this software was written in R by Andrew Clausen (clausen at econ.upenn.edu) in 2007. Mark Reid (mark.reid at anu.edu.au) sent a patch, applied 21/2/2009. In 2014, Andrew has passed the maintenance to Serguei Sokol (sokol at insa-toulouse.fr). Since then, the software was deeply rewritten and completed. Main new features include: - new derivative engine allowing simple syntaxe for differentiation rules; - many new functions are added to the rule table; - custom differentiation rules can be added by user; - automatic differentiation (AD) of a code with multiple assignement operators; - when taking derivative of a function Deriv() returns a function too. The later can be called with the same arguments as the original function; - can differentiate by variables stored in vectors or lists, e.g. `param$theta` or `x[1]`, `x[2]` etc. - simplifications are extended to rational expressions and factorizations; - expression caching is enabled by default; - Deriv() is made the only entry point for all types of entries: * expression * language * function * right hand side of a formula * character string * plain unevaluated code - few unit tests were added to the package Installation ------------ > devtools::install_github("sgsokol/Deriv") Usage ----- In R session do: > library(Deriv) > f <- function(x, n=2) x^n+sin(n*x) # user defined function to diffierentiate > (df <- Deriv(f)) # -> c(x = n * x^(n - 1) + n * cos(n * x), n = log(x) * x^n + x * cos(n * x)) > df(2, 3) # -> x n # -> 14.880511 7.465518 > Deriv(expression(f(y, 3)), "y") # -> expression(3 * y^2 + 3 * cos(3 * y)) > Deriv(~ f(y, 3), "y") # -> 3 * y^2 + 3 * cos(3 * y) > y <- 2; eval(Deriv(~ f(y, 3), "y")) # -> 14.88051 For more information and examples: > ?Deriv Deriv/man/0000755000176200001440000000000014671052332012101 5ustar liggesusersDeriv/man/Deriv-package.Rd0000644000176200001440000000406214671052332015034 0ustar liggesusers\name{Deriv-package} \alias{Deriv-package} \docType{package} \title{ Symbolic Differentiation } \description{ R already contains two differentiation functions: D and deriv. These functions have several limitations: \itemize{ \item the derivatives table can't be modified at runtime, and is only available in C. \item function cannot substitute function calls. eg: \code{f <- function(x, y) x + y; deriv(~f(x, x^2), "x")} } The advantages of this package include: \itemize{ \item It is entirely written in R, so would be easier to maintain. \item Can differentiate function calls: \itemize{ \item if the function is in the derivative table, then the chain rule is applied. \item if the function is not in the derivative table (or it is anonymous), then the function body is substituted in. \item these two methods can be mixed. An entry in the derivative table need not be self-contained -- you don't need to provide an infinite chain of derivatives. } \item It's easy to add custom entries to the derivatives table, e.g. \code{drule[["cos"]] <- alist(x=-sin(x))} \item The output can be an executable function, which makes it suitable for use in optimization problems. \item Starting from v4.0, some matrix calculus operations are possible (contribution of Andreas Rappold). See an example in \code{help("Deriv")} for differentiation of the inverse of 2x2 matrix and whose elements depend on variable of differentiation \code{x}. } } \details{ \tabular{ll}{ Package: \tab Deriv\cr Type: \tab Package\cr Version: \tab 4.2\cr Date: \tab 2024-??-??\cr License: \tab GPL (>= 3)\cr } Two main functions are Deriv() for differentiating and Simplify() for simplifying symbolically. } \author{ Andrew Clausen, Serguei Sokol Maintainer: Serguei Sokol (sokol at insa-toulouse.fr) } \references{ \url{https://andrewclausen.net/computing/deriv.html} } \keyword{ package } \seealso{ \code{\link{D}}, \code{\link{deriv}}, packages Ryacas, rSymPy } \examples{ \dontrun{f <- function(x) x^2} \dontrun{Deriv(f)} # function (x) # 2 * x } Deriv/man/format1.Rd0000644000176200001440000000070013573730646013751 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Simplify.R \name{format1} \alias{format1} \title{Wrapper for base::format() function} \usage{ format1(expr) } \arguments{ \item{expr}{An expression or symbol or language to be converted to a string.} } \value{ A character vector of length 1 contrary to base::format() which can split its output over several lines. } \description{ Wrapper for base::format() function } Deriv/man/Deriv.Rd0000644000176200001440000003370314671050542013450 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Deriv.R \name{Deriv} \alias{Deriv} \alias{drule} \title{Symbolic differentiation of an expression or function} \usage{ Deriv( f, x = if (is.function(f)) NULL else all.vars(if (is.character(f)) parse(text = f) else f), env = if (is.function(f)) environment(f) else parent.frame(), use.D = FALSE, cache.exp = TRUE, nderiv = NULL, combine = "c", drule = Deriv::drule ) } \arguments{ \item{f}{An expression or function to be differentiated. f can be \itemize{ \item a user defined function: \code{function(x) x**n} \item a string: \code{"x**n"} \item an expression: \code{expression(x**n)} \item a call: \code{call("^", quote(x), quote(n))} \item a language: \code{quote(x**n)} \item a right hand side of a formula: \code{~ x**n} or \code{y ~ x**n} }} \item{x}{An optional character vector with variable name(s) with respect to which \code{f} must be differentiated. If not provided (i.e. x=NULL), x is guessed either from \code{names(formals(f))} (if \code{f} is a function) or from all variables in f in other cases. To differentiate expressions including components of lists or vectors, i.e. by expressions like \code{p[1]}, \code{theta[["alpha"]]} or \code{theta$beta}, the vector of variables \code{x} must be a named vector. For the cited examples, the argument \code{x} must be given as follows \code{c(p="1", theta="alpha", theta="beta")}. Note the repeated name \code{theta} which must be provided for every component of the list \code{theta} by which a differentiation is required.} \item{env}{An environment where the symbols and functions are searched for. Defaults to \code{parent.frame()} for \code{f} expression and to \code{environment(f)} if \code{f} is a function. For primitive function, it is set by default to .GlobalEnv} \item{use.D}{An optional logical (default FALSE), indicates if base::D() must be used for differentiation of basic expressions.} \item{cache.exp}{An optional logical (default TRUE), indicates if final expression must be optimized with cached sub-expressions. If enabled, repeated calculations are made only once and their results stored in cache variables which are then reused.} \item{nderiv}{An optional integer vector of derivative orders to calculate. Default NULL value correspond to one differentiation. If length(nderiv)>1, the resulting expression is a list where each component corresponds to derivative order given in nderiv. Value 0 corresponds to the original function or expression non differentiated. All values must be non negative. If the entries in nderiv are named, their names are used as names in the returned list. Otherwise the value of nderiv component is used as a name in the resulting list.} \item{combine}{An optional character scalar, it names a function to combine partial derivatives. Default value is "c" but other functions can be used, e.g. "cbind" (cf. Details, NB3), "list" or user defined ones. It must accept any number of arguments or at least the same number of arguments as there are items in \code{x}.} \item{drule}{An optional environment-like containing derivative rules (cf. Details for syntax rules).} } \value{ \itemize{ \item a function if \code{f} is a function \item an expression if \code{f} is an expression \item a character string if \code{f} is a character string \item a language (usually a so called 'call' but may be also a symbol or just a numeric) for other types of \code{f} } } \description{ Symbolic differentiation of an expression or function } \details{ R already contains two differentiation functions: \code{stats::D} and \code{stats:deriv}. \code{D} does simple univariate differentiation while \code{deriv} uses \code{D} to do multivariate differentiation. The output of \code{D} is an expression, whereas the output of \code{deriv} can be an executable function. R's existing functions have several limitations. They can probably be fixed, but since they are written in C, this would probably require a lot of work. Limitations include: \itemize{ \item The derivatives table can't be modified at runtime, and is only available in C. \item Function cannot substitute function calls. e.g.: f <- function(x, y) x + y; deriv(~f(x, x^2), "x") is not working. } So, here are the advantages of this implementation: \itemize{ \item It is entirely written in R, so would be easier to maintain. \item Can do multi-variate differentiation. \item Can differentiate function calls: \itemize{ \item if the function is in the derivative table, then the chain rule is applied. For example, if you declared that the derivative of \code{sin} is \code{cos}, then it would figure out how to call \code{cos} correctly in case of complex argument. \item if the function is not in the derivative table (or it is anonymous), then the function body is substituted in. \item these two methods can be mixed. An entry in the derivative table need not be self-contained -- you don't need to provide an infinite chain of derivatives. } \item It's easy to add custom entries to the derivatives table, e.g. \code{drule[["cos"]] <- alist(x=-sin(x))} The chain rule will be automatically applied if needed. In their custom rules, users should avoid using variable names like \code{.e1}, \code{.e2} etc. which can be confounded with those automatically created by \code{Deriv} for code caching purposes. \item The output is an executable function, which makes it suitable for use in optimization problems. \item Compound functions (i.e. piece-wise functions based on if-else operator) can be differentiated (cf. examples section). \item in case of multiple derivatives (e.g. gradient and hessian calculation), caching can make calculation economies for both \item Starting from v4.0, some matrix calculus operations are possible (contribution of Andreas Rappold). See an example hereafter for differentiation of the inverse of 2x2 matrix and whose elements depend on variable of differentiation \code{x}. } Two environments \code{drule} and \code{simplifications} are exported in the package's NAMESPACE. As their names indicate, they contain tables of derivative and simplification rules. To see the list of defined rules do \code{ls(drule)}. To add your own derivative rule for a function called say \code{sinpi(x)} calculating sin(pi*x), do \code{drule[["sinpi"]] <- alist(x=pi*cospi(x))}. Here, "x" stands for the first and unique argument in \code{sinpi()} definition. For a function that might have more than one argument, e.g. \code{log(x, base=exp(1))}, the drule entry must be a list with a named rule per argument. See \code{drule$log} for an example to follow. After adding \code{sinpi} you can differentiate expressions like \code{Deriv(~ sinpi(x^2), "x")}. The chain rule will automatically apply. Starting from v4.0, user can benefit from a syntax \code{.d_X} in the rule writing. Here \code{X} must be replaced by an argument name (cf. \code{drule[["solve"]]} for an example). A use of this syntax leads to a replacement of this place-holder by a derivative of the function (chain rule is automatically integrated) by the named argument. \cr Another v4.0 novelty in rule's syntax is a possible use of optional parameter \code{`_missing`} which can be set to TRUE or FALSE (default) to indicate how to treat missing arguments. By default, i.e. in absence of this parameter or set to FALSE, missing arguments were replaced by their default values. Now, if \code{`_missing`=TRUE} is specified in a rule, the missing arguments will be left missed in the derivative. Look \code{drule[["solve"]]} for an example. NB. In \code{abs()} and \code{sign()} function, singularity treatment at point 0 is left to user's care. For example, if you need NA at singular points, you can define the following: \code{drule[["abs"]] <- alist(x=ifelse(x==0, NA, sign(x)))} \code{drule[["sign"]] <- alist(x=ifelse(x==0, NA, 0))} NB2. In Bessel functions, derivatives are calculated only by the first argument, not by the \code{nu} argument which is supposed to be constant. NB3. There is a side effect with vector length. E.g. in \code{Deriv(~a+b*x, c("a", "b"))} the result is \code{c(a = 1, b = x)}. To avoid the difference in lengths of a and b components (when x is a vector), one can use an optional parameter \code{combine} \code{Deriv(~a+b*x, c("a", "b"), combine="cbind")} which gives \code{cbind(a = 1, b = x)} producing a two column matrix which is probably the desired result here. \cr Another example illustrating a side effect is a plain linear regression case and its Hessian: \code{Deriv(~sum((a+b*x - y)**2), c("a", "b"), n=c(hessian=2)} producing just a constant \code{2} for double differentiation by \code{a} instead of expected result \code{2*length(x)}. It comes from a simplification of an expression \code{sum(2)} where the constant is not repeated as many times as length(x) would require it. Here, using the same trick with \code{combine="cbind"} would not help as all 4 derivatives are just scalars. Instead, one should modify the previous call to explicitly use a constant vector of appropriate length: \code{Deriv(~sum((rep(a, length(x))+b*x - y)**2), c("a", "b"), n=2)} NB4. Differentiation of \code{*apply()} family (available starting from v4.1) is done only on the body of the \code{FUN} argument. It implies that this body must use the same variable names as in argument \code{x} and they must not appear in \code{FUN}s arguments (cf. GMM example). NB5. Expressions are differentiated as scalar ones. However in some cases, obtained result remains valid if the variable of differentiation is a vector. This is just a coincidence. If you need to differentiate by vectors, you can try to write your own differentiation rule. For example, derivative of \code{sum(x)} where \code{x} is a vector can be done as: \code{vsum=function(x) sum(x)} \code{drule[["vsum"]] <- alist(x=rep_len(1, length(x)))} # drule is exported from Deriv namespace \code{Deriv(~vsum(a*x), "x", drule=drule)} \code{# a * rep_len(1, length(a * x))} NB6. Since v4.2, it is possible to differentiate by named components of lists and vectors that are used in \code{with(data, expr)} expressions (cf. "with()" example). The names of argument \code{x} ("theta" in an example above) must be used directly, e.g \code{with(theta, ...)} or \code{with(as.list(theta), ...)}. Otherwise, the \code{expr} of \code{with()} will be differentiated as plain code. } \examples{ \dontrun{f <- function(x) x^2} \dontrun{Deriv(f)} # function (x) # 2 * x \dontrun{f <- function(x, y) sin(x) * cos(y)} \dontrun{Deriv(f)} # function (x, y) # c(x = cos(x) * cos(y), y = -(sin(x) * sin(y))) \dontrun{f_ <- Deriv(f)} \dontrun{f_(3, 4)} # x y # [1,] 0.6471023 0.1068000 \dontrun{Deriv(~ f(x, y^2), "y")} # -(2 * (y * sin(x) * sin(y^2))) \dontrun{Deriv(quote(f(x, y^2)), c("x", "y"), cache.exp=FALSE)} # c(x = cos(x) * cos(y^2), y = -(2 * (y * sin(x) * sin(y^2)))) \dontrun{Deriv(expression(sin(x^2) * y), "x")} # expression(2*(x*y*cos(x^2))) Deriv("sin(x^2) * y", "x") # differentiate only by x "2 * (x * y * cos(x^2))" Deriv("sin(x^2) * y", cache.exp=FALSE) # differentiate by all variables (here by x and y) "c(x = 2 * (x * y * cos(x^2)), y = sin(x^2))" # Compound function example (here abs(x) smoothed near 0) fc <- function(x, h=0.1) if (abs(x) < h) 0.5*h*(x/h)**2 else abs(x)-0.5*h Deriv("fc(x)", "x", cache.exp=FALSE) "if (abs(x) < h) x/h else sign(x)" # Example of a first argument that cannot be evaluated in the current environment: \dontrun{ suppressWarnings(rm("xx", "yy")) Deriv(xx^2+yy^2) } # c(xx = 2 * xx, yy = 2 * yy) # Automatic differentiation (AD), note intermediate variable 'd' assignment \dontrun{Deriv(~{d <- ((x-m)/s)^2; exp(-0.5*d)}, "x", cache.exp=FALSE)} #{ # d <- ((x - m)/s)^2 # .d_x <- 2 * ((x - m)/s^2) # -(0.5 * (.d_x * exp(-(0.5 * d)))) #} # Custom differentiation rule \dontrun{ myfun <- function(x, y=TRUE) NULL # do something useful dmyfun <- function(x, y=TRUE) NULL # myfun derivative by x. drule[["myfun"]] <- alist(x=dmyfun(x, y), y=NULL) # y is just a logical => no derivate Deriv(~myfun(z^2, FALSE), "z", drule=drule) # 2 * (z * dmyfun(z^2, FALSE)) } # Differentiation by list components \dontrun{ theta <- list(m=0.1, sd=2.) x <- names(theta) names(x)=rep("theta", length(theta)) Deriv(~exp(-(x-theta$m)**2/(2*theta$sd)), x, cache.exp=FALSE) # c(theta_m = exp(-((x - theta$m)^2/(2 * theta$sd))) * # (x - theta$m)/theta$sd, theta_sd = 2 * (exp(-((x - theta$m)^2/ # (2 * theta$sd))) * (x - theta$m)^2/(2 * theta$sd)^2)) } # Differentiation by list components used in "with()" expression (since v4.2) # Compare with precedent example. \dontrun{ theta <- list(m=0.1, sd=2.) x <- names(theta) names(x)=rep("theta", length(theta)) Deriv(~with(theta, exp(-(x-m)**2/(2*sd))), x, cache.exp=FALSE) # c(theta_m = with(theta, exp(-((x - m)^2/(2 * sd))) * (x - m)/sd), # theta_sd = with(theta, 2 * (exp(-((x - m)^2/(2 * sd))) * # (x - m)^2/(2 * sd)^2))) } # Differentiation in matrix calculus \dontrun{ Deriv(~solve(matrix(c(1, x, x**2, x**3), nrow=2, ncol=2))) } # Two component Gaussian mixture model (GMM) example \dontrun{ # define GMM probability density function -> p(x, ...) ncomp=2 a=runif(ncomp) a=a/sum(a) # amplitude or weight of each component m=rnorm(ncomp) # mean s=runif(ncomp) # sd # two column matrix of probabilities: one row per x value, one column per component pn=function(x, a, m, s, log=FALSE) { n=length(a) structure(vapply(seq(n), function(i) a[i]*dnorm(x, m[i], s[i], log), double(length(x))), dim=c(length(x), n)) } p=function(x, a, m, s) rowSums(pn(x, a, m, s)) # overall probability dp=Deriv(p, "x") # plot density and its derivative xp=seq(min(m-2*s), max(m+2*s), length.out=200) matplot(xp, cbind(p(xp, a, m, s), dp(xp, a, m, s)), xlab="x", ylab="p, dp/dx", type="l", main="Two component GMM") } } \author{ Andrew Clausen (original version) and Serguei Sokol (actual version and maintainer) } \concept{symbolic differentiation} Deriv/man/Simplify.Rd0000644000176200001440000000332613573730646014203 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Simplify.R \name{Simplify} \alias{Simplify} \alias{simplifications} \alias{Cache} \alias{deCache} \title{Symbollic simplification of an expression or function} \usage{ Simplify(expr, env = parent.frame(), scache = new.env()) Cache(st, env = Leaves(st), prefix = "") deCache(st) } \arguments{ \item{expr}{An expression to be simplified, expr can be \itemize{ \item an expression: \code{expression(x+x)} \item a string: \code{"x+x"} \item a function: \code{function(x) x+x} \item a right hand side of a formula: \code{~x+x} \item a language: \code{quote(x+x)} }} \item{env}{An environment in which a simplified function is created if \code{expr} is a function. This argument is ignored in all other cases.} \item{scache}{An environment where there is a list in which simplified expression are cached} \item{st}{A language expression to be cached} \item{prefix}{A string to start the names of the cache variables} } \value{ A simplified expression. The result is of the same type as \code{expr} except for formula, where a language is returned. } \description{ Symbollic simplification of an expression or function } \details{ An environment \code{simplifications} containing simplification rules, is exported in the namespace accessible by the user. Cache() is used to remove redundunt calculations by storing them in cache variables. Default parameters to Cache() does not have to be provided by user. deCache() makes the inverse job -- a series of assignements are replaced by only one big expression without assignement. Sometimes it is usefull to apply deChache() and only then pass its result to Cache(). } \concept{symbolic simplification} Deriv/DESCRIPTION0000644000176200001440000000210015025276042013025 0ustar liggesusersPackage: Deriv Type: Package Title: Symbolic Differentiation Version: 4.2.0 Date: 2025-06-20 Authors@R: c(person(given="Andrew", family="Clausen", role="aut"), person(given="Serguei", family="Sokol", role=c("aut", "cre"), email="sokol@insa-toulouse.fr", comment = c(ORCID = "0000-0002-5674-3327")), person(given="Andreas", family="Rappold", role="ctb", email="arappold@gmx.at")) Description: R-based solution for symbolic differentiation. It admits user-defined function as well as function substitution in arguments of functions to be differentiated. Some symbolic simplification is part of the work. License: GPL (>= 3) Suggests: testthat (>= 0.11.0) BugReports: https://github.com/sgsokol/Deriv/issues RoxygenNote: 7.3.1 Imports: methods Encoding: UTF-8 NeedsCompilation: no Packaged: 2025-06-20 13:25:20 UTC; sokol Author: Andrew Clausen [aut], Serguei Sokol [aut, cre] (ORCID: ), Andreas Rappold [ctb] Maintainer: Serguei Sokol Repository: CRAN Date/Publication: 2025-06-20 15:20:02 UTC