Commit 6276ea11 authored by Radford Neal's avatar Radford Neal

implement derivative for dbinom

parent 36d02b34
......@@ -153,6 +153,7 @@ dunif, punif, qunif, runif \cr
dexp, pexp, qexp, rexp \cr
dgeom, pgeom \cr
dpois \cr
dbinom \cr
pcauchy, qcauchy, rcauchy \cr
dnorm, pnorm, qnorm, rnorm \cr
rlnorm \cr
......
......@@ -2841,6 +2841,21 @@ SEXP do_Math2(SEXP call, SEXP op, SEXP args, SEXP env, int variant)
/* Derivatives of math3 functions. */
static void Ddbinom (double x, double n, double p,
double *dx /*ignored*/, double *dn /*ignored*/, double *dp,
int give_log, double v)
{
if (!dp) return;
if (p <= 0 || p >= 1) {
*dp = 0;
}
else {
double lp = x/p - (n-x)/(1-p);
*dp = give_log ? lp : lp*v;
}
}
static void Dpcauchy (double q, double location, double scale,
double *dq, double *dlocation, double *dscale,
int lower_tail, int log_p, double v)
......@@ -3140,7 +3155,7 @@ static struct { double (*fncall)(); void (*Dcall)(); } math3_table[48] = {
{ dbeta, 0 },
{ pbeta, 0 },
{ qbeta, 0 },
{ dbinom, 0 },
{ dbinom, Ddbinom },
{ pbinom, 0 },
{ qbinom, 0 /* discrete */ },
{ dcauchy, 0 },
......@@ -3666,8 +3681,8 @@ attribute_hidden FUNTAB R_FunTab_arithmetic[] =
{"pbeta", do_math3, 2, 31000011, 3+2, {PP_FUNCALL, PREC_FN, 0}},
{"qbeta", do_math3, 3, 31000011, 3+2, {PP_FUNCALL, PREC_FN, 0}},
{"dbinom", do_math3, 4, 1000011, 3+1, {PP_FUNCALL, PREC_FN, 0}},
{"pbinom", do_math3, 5, 1000011, 3+2, {PP_FUNCALL, PREC_FN, 0}},
{"dbinom", do_math3, 4, 61000011, 3+1, {PP_FUNCALL, PREC_FN, 0}},
{"pbinom", do_math3, 5, 61000011, 3+2, {PP_FUNCALL, PREC_FN, 0}},
{"qbinom", do_math3, 6, 1000011, 3+2, {PP_FUNCALL, PREC_FN, 0}},
{"dcauchy", do_math3, 7, 31000011, 3+1, {PP_FUNCALL, PREC_FN, 0}},
......
......@@ -179,6 +179,7 @@ x1 <- 0.47718; x2 <- 0.89472; x3 <- 0.67325
y1 <- -0.3721; y2 <- -0.8131; y3 <- 1.22213
z1 <- 11.4319; z2 <- 13.1133; z3 <- 6.68901
w1 <- 0.8389; w2 <- 0.1123; w3 <- 4.68701
v1 <- 3; v2 <- 7; v3 <- 0.6513
i1 <- 3
bindgrads <- function (r1,r2)
......@@ -300,6 +301,16 @@ test3w <- function (fun,...) {
with_gradient (w1,w2,w3) fun(w1,w2,w3,...)))
}
test3u <- function (fun,...) {
print (bindgrads (numericDeriv(quote(fun(u1,u2,u3,...)),"u3"),
with_gradient (u3) fun(u1,u2,u3,...)))
}
test3v <- function (fun,...) {
print (bindgrads (numericDeriv(quote(fun(v1,v2,v3,...)),"v3"),
with_gradient (v3) fun(v1,v2,v3,...)))
}
test1(abs)
test1(sqrt)
......@@ -368,6 +379,9 @@ test2i(pgeom,log=TRUE,lower=FALSE)
test2i(dpois)
test2i(dpois,log=TRUE)
test3v(dbinom)
test3v(dbinom,log=TRUE)
test3(pcauchy)
test3(pcauchy,log=TRUE)
test3(pcauchy,lower=FALSE)
......
......@@ -324,6 +324,7 @@ attr(,"gradient")
> y1 <- -0.3721; y2 <- -0.8131; y3 <- 1.22213
> z1 <- 11.4319; z2 <- 13.1133; z3 <- 6.68901
> w1 <- 0.8389; w2 <- 0.1123; w3 <- 4.68701
> v1 <- 3; v2 <- 7; v3 <- 0.6513
> i1 <- 3
>
> bindgrads <- function (r1,r2)
......@@ -445,6 +446,16 @@ attr(,"gradient")
+ with_gradient (w1,w2,w3) fun(w1,w2,w3,...)))
+ }
>
> test3u <- function (fun,...) {
+ print (bindgrads (numericDeriv(quote(fun(u1,u2,u3,...)),"u3"),
+ with_gradient (u3) fun(u1,u2,u3,...)))
+ }
>
> test3v <- function (fun,...) {
+ print (bindgrads (numericDeriv(quote(fun(v1,v2,v3,...)),"v3"),
+ with_gradient (v3) fun(v1,v2,v3,...)))
+ }
>
> test1(abs)
[,1] [,2]
r1 0.32739 1
......@@ -804,6 +815,15 @@ r2 0.04879083 0.114805
r1 -3.020213 2.353004
r2 -3.020213 2.353004
>
> test3v(dbinom)
[,1] [,2]
r1 0.1429615 -0.9814315
r2 0.1429615 -0.9814315
> test3v(dbinom,log=TRUE)
[,1] [,2]
r1 -1.94518 -6.865007
r2 -1.94518 -6.865006
>
> test3(pcauchy)
[,1] [,2]
r1 0.3232967 0.3414601
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment