Nothing
.tol = 1e-4
.tol.opt = 0.001
tol.test <- function (y, yh) {
eps = 0.000001
2 * max(abs(y - yh)) / (max(abs(y + yh)) + eps)
}
dunary.test <- function (x, fn, sclr=T) {
g = graph.open()
x = number(x, scalar=sclr)
y = fn(x)
y$set.dv(y$v**0)
y$bw()
tol.test(dfun(x$v, fn), x$dv)
}
dbinary.test <- function (x1, x2, fn, sclr1=T, sclr2=T) {
g = graph.open()
x1 = number(x1, scalar=sclr1)
x2 = number(x2, scalar=sclr2)
y = do.call(fn, list(x1, x2))
y$set.dv(y$v**0)
y$bw()
dx1 = dfun(x1$v, function(x)do.call(fn, list(x, x2$v)))
dx2 = dfun(x2$v, function(x)do.call(fn, list(x1$v, x)))
tol.test(c(dx1, dx2), c(x1$dv, x2$dv))
}
dbcast.test <- function (x1, x2, fn) {
g = graph.open()
x1 = number(x1)
x2 = number(x2)
y = do.call(fn, list(x1, x2))
y$set.dv(y$v**0)
y$bw()
dx1 = dfun(x1$v, function(x)do.call(fn, list(c(x), c(x2$v))))
dx2 = dfun(x2$v, function(x)do.call(fn, list(c(x1$v), c(x))))
tol.test(c(dx1, dx2), c(x1$dv, x2$dv))
}
dgemm2.test <- function (ta, tb, A, B) {
fn = function (A, B) {
if (ta > 0) A = t(A)
if (tb > 0) B = t(B)
A %*% B
}
g = graph.open()
x1 = number(A)
x2 = number(B)
x3 = gemm(ta=ta, tb=tb, alpha=NULL, A=x1, B=x2, beta=NULL, C=NULL)
x3$set.dv(x3$v**0)
x3$bw()
dA = dfun(A, function(x)fn(x, B))
dB = dfun(B, function(x)fn(A, x))
tol.test(c(x1$dv, x2$dv), c(dA, dB))
}
dgemm15.test <- function (ta, tb, A, B, C) {
fn = function (A, B, C) {
if (ta > 0) A = t(A)
if (tb > 0) B = t(B)
A %*% B + C
}
g = graph.open()
xa = number(A)
xb = number(B)
xc = number(C)
y = gemm(ta=ta, tb=tb, alpha=NULL, A=xa, B=xb, beta=NULL, C=xc)
y$set.dv(y$v**0)
y$bw()
dA = dfun(A, function(x)fn(x, B, C))
dB = dfun(B, function(x)fn(A, x, C))
dC = dfun(B, function(x)fn(A, B, x))
tol.test(c(xa$dv, xb$dv, xc$dv), c(dA, dB, dC))
}
dgemm1.test <- function (ta, tb, alpha, A, B) {
fn = function (alpha, A, B) {
if (ta > 0) A = t(A)
if (tb > 0) B = t(B)
alpha * A %*% B
}
g = graph.open()
xalpha = number(alpha, scalar=T)
xa = number(A)
xb = number(B)
y = gemm(ta=ta, tb=tb, alpha=xalpha, A=xa, B=xb, beta=NULL, C=NULL)
y$set.dv(y$v**0)
y$bw()
dalpha = dfun(alpha, function(x)fn(x, A, B))
dA = dfun(A, function(x)fn(alpha, x, B))
dB = dfun(B, function(x)fn(alpha, A, x))
tol.test(c(xalpha$dv, xa$dv, xb$dv), c(dalpha, dA, dB))
}
dgemm0.test <- function (ta, tb, alpha, A, B, beta, C) {
fn = function (alpha, A, B, beta, C) {
if (ta > 0) A = t(A)
if (tb > 0) B = t(B)
alpha * A %*% B + beta * C
}
g = graph.open()
xalpha = number(alpha, scalar=T)
xa = number(A)
xb = number(B)
xbeta = number(beta, scalar=T)
xc = number(C)
y = gemm(ta=ta, tb=tb, alpha=xalpha, A=xa, B=xb, beta=xbeta, C=xc)
y$set.dv(y$v**0)
y$bw()
dalpha = dfun(alpha, function(x)fn(x, A, B, beta, C))
dA = dfun(A, function(x)fn(alpha, x, B, beta, C))
dB = dfun(B, function(x)fn(alpha, A, x, beta, C))
dbeta = dfun(beta, function(x)fn(alpha, A, B, x, C))
dC = dfun(C, function(x)fn(alpha, A, B, beta, x))
tol.test(c(xalpha$dv, xa$dv, xb$dv, xbeta$dv, xc$dv), c(dalpha, dA, dB, dbeta, dC))
}
dgemv1.test <- function (ta, alpha, A, B, beta, C) {
fn = function (alpha, A, B, beta, C) {
if (ta > 0) A = t(A)
alpha * A %*% B + beta * C
}
g = graph.open()
xalpha = number(alpha, scalar=T)
xa = number(A)
xb = number(B)
xbeta = number(beta, scalar=T)
xc = number(C)
y = gemv(ta=ta, alpha=xalpha, A=xa, B=xb, beta=xbeta, C=xc)
y$set.dv(y$v**0)
y$bw()
dalpha = dfun(alpha, function(x)fn(x, A, B, beta, C))
dA = dfun(A, function(x)fn(alpha, x, B, beta, C))
dB = dfun(as.array(B), function(x)fn(alpha, A, x, beta, C))
dbeta = dfun(beta, function(x)fn(alpha, A, B, x, C))
dC = dfun(C, function(x)fn(alpha, A, B, beta, x))
tol.test(c(xalpha$dv, xa$dv, xb$dv, xbeta$dv, xc$dv), c(dalpha, dA, dB, dbeta, dC))
}
dgemv2.test <- function (ta, alpha, A, B) {
fn = function (alpha, A, B) {
if (ta > 0) A = t(A)
alpha * A %*% B
}
g = graph.open()
xalpha = number(alpha, scalar=T)
xa = number(A)
xb = number(B)
y = gemv(ta=ta, alpha=xalpha, A=xa, B=xb)
y$set.dv(y$v**0)
y$bw()
dalpha = dfun(alpha, function(x)fn(x, A, B))
dA = dfun(A, function(x)fn(alpha, x, B))
dB = dfun(as.array(B), function(x)fn(alpha, A, x))
tol.test(c(xalpha$dv, xa$dv, xb$dv), c(dalpha, dA, dB))
}
dgemv3.test <- function (ta, A, B, C) {
fn = function (A, B, C) {
if (ta > 0) A = t(A)
A %*% B + C
}
g = graph.open()
xa = number(A)
xb = number(B)
xc = number(C)
y = gemv(ta=ta, A=xa, B=xb, C=xc)
y$set.dv(y$v**0)
y$bw()
dA = dfun(A, function(x)fn(x, B, C))
dB = dfun(as.array(B), function(x)fn(A, x, C))
dC = dfun(C, function(x)fn(A, B, x))
tol.test(c(xa$dv, xb$dv, xc$dv), c(dA, dB, dC))
}
dgemv4.test <- function (ta, A, B) {
fn = function (A, B) {
if (ta > 0) A = t(A)
A %*% B
}
g = graph.open()
xa = number(A)
xb = number(B)
y = gemv(ta=ta, A=xa, B=xb)
y$set.dv(y$v**0)
y$bw()
dA = dfun(A, function(x)fn(x, B))
dB = dfun(as.array(B), function(x)fn(A, x))
tol.test(c(xa$dv, xb$dv), c(dA, dB))
}
dger1.test <- function (alpha, A, B, C) {
fn = function (alpha, A, B, C) {
alpha * A %*% t(B) + C
}
g = graph.open()
xalpha = number(alpha, scalar=T)
xa = number(A)
xb = number(B)
xc = number(C)
y = ger(alpha=xalpha, A=xa, B=xb, C=xc)
y$set.dv(y$v**0)
y$bw()
dalpha = dfun(alpha, function(x)fn(x, A, B, C))
dA = dfun(as.matrix(A), function(x)fn(alpha, x, B, C))
dB = dfun(as.matrix(B), function(x)fn(alpha, A, x, C))
dC = dfun(C, function(x)fn(alpha, A, B, x))
tol.test(c(xalpha$dv, xa$dv, xb$dv, xc$dv), c(dalpha, dA, dB, dC))
}
dger2.test <- function (A, B, C) {
fn = function (A, B, C) {
A %*% t(B) + C
}
g = graph.open()
xa = number(A)
xb = number(B)
xc = number(C)
y = ger(A=xa, B=xb, C=xc)
y$set.dv(y$v**0)
y$bw()
dA = dfun(as.matrix(A), function(x)fn(x, B, C))
dB = dfun(as.matrix(B), function(x)fn(A, x, C))
dC = dfun(C, function(x)fn(A, B, x))
tol.test(c(xa$dv, xb$dv, xc$dv), c(dA, dB, dC))
}
dger3.test <- function (A, B) {
fn = function (A, B) {
A %*% t(B)
}
g = graph.open()
xa = number(A)
xb = number(B)
y = ger(A=xa, B=xb)
y$set.dv(y$v**0)
y$bw()
dA = dfun(as.matrix(A), function(x)fn(x, B))
dB = dfun(as.matrix(B), function(x)fn(A, x))
tol.test(c(xa$dv, xb$dv), c(dA, dB))
}
ddot.test <- function (A, B) {
fn = function (A, B) {
t(A) %*% B
}
g = graph.open()
xa = number(A)
xb = number(B)
y = xa %T.% xb
y$set.dv(y$v**0)
y$bw()
dA = dfun(as.matrix(A), function(x)fn(x, B))
dB = dfun(as.matrix(B), function(x)fn(A, x))
tol.test(c(xa$dv, xb$dv), c(dA, dB))
}
dinvMat.test <- function (A) {
fn = function (A) {
invMat(A)
}
g = graph.open()
xa = number(A)
y = invMat(xa)
y$set.dv(y$v**0)
y$bw()
dA = dfun(A, fn)
tol.test(c(xa$dv), c(dA))
}
dreduction.test <- function (x, fn) {
g = graph.open()
x = number(x)
r = fn(x)
r$dv = r$v**0
r$bw()
tol.test(dfun(x$v, fn), x$dv)
}
dobj.test <- function (y, x, fn) {
g = graph.open()
y = number(y, dx=F)
x = number(x)
obj = fn(y, x)
obj$set.dv(obj$v**0)
obj$bw()
tol.test(dfun(x$v, function(x)fn(y$v, x)), x$dv)
}
dldexp.test <- function (y, lam, lam.scalar) {
fn <- function (y, lam) {
stats::dexp(y, lam, log=TRUE)
}
xy = number(y, dx=FALSE)
xlam = number(lam, scalar=lam.scalar)
g = graph.open()
ld = ldexp(xy, xlam)
ld$set.dv(ld$v**0)
ld$bw()
dlam = dfun(lam, function(x)fn(y, x))
tol.test(c(dlam), c(xlam$dv))
}
dldbeta.test <- function (y, a1, a2, a1.scalar, a2.scalar) {
fn <- function (y, a1, a2) {
stats::dbeta(y, a1, a2, log=TRUE)
}
xy = number(y, dx=FALSE)
xa1 = number(a1, scalar=a1.scalar)
xa2 = number(a2, scalar=a2.scalar)
g = graph.open()
ld = ldbeta(xy, xa1, xa2)
ld$set.dv(ld$v**0)
ld$bw()
da1 = dfun(a1, function(x)fn(y, x, a2))
da2 = dfun(a2, function(x)fn(y, a1, x))
tol.test(c(da1, da2), c(xa1$dv, xa2$dv))
}
dldgamma.test <- function (y, a, b, a.scalar, b.scalar) {
fn <- function (y, a, b) {
stats::dgamma(y, a, b, log=TRUE)
}
xy = number(y, dx=F)
xa = number(a, scalar=a.scalar)
xb = number(b, scalar=b.scalar)
g = graph.open()
ld = ldgamma(xy, xa, xb)
ld$set.dv(ld$v**0)
ld$bw()
da = dfun(a, function(x)fn(y, x, b))
db = dfun(b, function(x)fn(y, a, x))
tol.test(c(da, db), c(xa$dv, xb$dv))
}
dldnorm.test <- function (y, mu, s, mu.scalar, s.scalar) {
fn <- function (y, mu, s) {
stats::dnorm(y, mu, s, log=TRUE)
}
xy = number(y, dx=F)
xmu = number(mu, scalar=mu.scalar)
xs = number(s, scalar=s.scalar)
g = graph.open()
ld = ldnorm(xy, xmu, xs)
ld$set.dv(ld$v**0)
ld$bw()
dmu = dfun(mu, function(x)fn(y, x, s))
ds = dfun(s, function(x)fn(y, mu, x))
tol.test(c(dmu, ds), c(xmu$dv, xs$dv))
}
dldmvnorm.test <- function (y, mu, E) {
fn <- function (y, mu, E) {
x = y - mu
Q = t(x) %*% solve(E) %*% x
-0.5 * (length(y) * log(2*pi) + log(det(E)) + Q)
}
y = number(y)
mu = number(mu)
E = number(E)
g = graph.open()
ans = ldmvnorm(y, mu, E)
graph.close()
ans$dv = 1
ans$bw()
dy = dfun(y$v, function (x)fn(x, mu$v, E$v))
dmu = dfun(mu$v, function (x)fn(y$v, x, E$v))
dE = dfun(E$v, function (x)fn(y$v, mu$v, x))
tol.test(c(y$dv, mu$dv, E$dv), c(dy, dmu, dE))
}
dmvnorm_posterior.test <- function (a11, e21, e22, y11, mu11, inv) {
a11 = number(a11)
e21 = number(e21)
e22 = number(e22)
y11 = number(y11)
mu11 = number(mu11, scalar=TRUE)
g = graph.open()
ans = mvnorm_posterior(a11, e21, e22, y11, mu11, inv)
graph.close()
ans$mu$dv = 1
ans$E$dv = 1
ans$mu$bw()
da11 = dfun(a11$v, function(x)mvnorm_posterior(x, e21$v, e22$v, y11$v, mu11$v, inv)$mu)
da11 = da11 + dfun(a11$v, function(x)mvnorm_posterior(x, e21$v, e22$v, y11$v, mu11$v, inv)$E)
de21 = dfun(e21$v, function(x)mvnorm_posterior(a11$v, x, e22$v, y11$v, mu11$v, inv)$mu)
de21 = de21 + dfun(e21$v, function(x)mvnorm_posterior(a11$v, x, e22$v, y11$v, mu11$v, inv)$E)
de22 = dfun(e22$v, function(x)mvnorm_posterior(a11$v, e21$v, x, y11$v, mu11$v, inv)$mu)
de22 = de22 + dfun(e22$v, function(x)mvnorm_posterior(a11$v, e21$v, x, y11$v, mu11$v, inv)$E)
dy11 = dfun(y11$v, function(x)mvnorm_posterior(a11$v, e21$v, e22$v, x, mu11$v, inv)$mu)
dy11 = dy11 + dfun(y11$v, function(x)mvnorm_posterior(a11$v, e21$v, e22$v, x, mu11$v, inv)$E)
dmu11 = dfun(mu11$v, function(x)mvnorm_posterior(a11$v, e21$v, e22$v, y11$v, x, inv)$mu)
dmu11 = dmu11 + dfun(mu11$v, function(x)mvnorm_posterior(a11$v, e21$v, e22$v, y11$v, x, inv)$E)
tol.test(c(a11$dv, e21$dv, e22$dv, y11$dv, mu11$dv), c(da11, de21, de22, dy11, dmu11))
}
dlkh.norm.test <- function (y, mu, s, w) {
fn <- function (y, mu, s, w) {
if (is.null(w)) w = 1
base::sum(w * stats::dnorm(y, mu, s, log=T))
}
xy = number(y, dx=F)
xmu = number(mu)
xs = number(s)
if (!is.null(w)) {
xw = number(w, dx=F)
} else {
xw = NULL
}
g = graph.open()
l = lkh.norm(xy, xmu, xs, xw)
l$set.dv(l$v**0)
l$bw()
dmu = dfun(as.array(mu), function(x)fn(y, x, s, w))
ds = dfun(as.array(s), function(x)fn(y, mu, x, w))
tol.test(c(dmu, ds), c(xmu$dv, xs$dv))
}
test.linreg <- function () {
fn = function (w, b) {
mse(c(y$v), c(w %*% t(x$v) + c(b)))
}
mdl = module.lm$new(TRUE, 3, 1)
x = number(matrix(stats::rnorm(21), 7), dx=FALSE)
y = number(stats::rnorm(7), dx=FALSE)
g = graph.open()
obj = mdl$obj(y, x)
obj$dv = obj$v**0
g$bw.zero()
g$bw()
dW = dfun(mdl$pars()$W$v, function(x)fn(x, mdl$pars()$B$v))
dB = dfun(mdl$pars()$B$v, function(x)fn(mdl$pars()$W$v, x))
ANS = tol.test(c(dW, dB), c(mdl$pars()$W$dv, mdl$pars()$B$dv))
modello.reset()
return(ANS)
}
test.logisticreg <- function () {
fn = function (w, b) {
yh = sigmoid(w %*% t(x$v) + c(b))
bin.entropy(c(y$v), c(yh))
}
mdl = module.logistic$new(TRUE, 3)
x = number(matrix(stats::rnorm(21), 7), dx=FALSE)
y = number(base::sample(c(1, 0), 7, replace=T), dx=FALSE)
g = graph.open()
obj = mdl$obj(y, x)
obj$dv = obj$v**0
g$bw.zero()
g$bw()
dW = dfun(mdl$pars()$W$v, function(x)fn(x, mdl$pars()$B$v))
dB = dfun(mdl$pars()$B$v, function(x)fn(mdl$pars()$W$v, x))
ANS = tol.test(c(dW, dB), c(mdl$pars()$W$dv, mdl$pars()$B$dv))
modello.reset()
return(ANS)
}
test.multinomreg <- function () {
fn = function (w, b) {
yh = softmax(w %*% t(x$v) + c(b))
cross.entropy(c(y$v), c(yh))
}
mdl = module.softmax$new(TRUE, 3, 3)
x = number(matrix(stats::rnorm(21), 7), dx=FALSE)
y = number(t(sapply(1:7, function(i)sample(c(1, 0, 0)))), dx=FALSE)
g = graph.open()
obj = mdl$obj(y, x)
obj$dv = obj$v**0
g$bw.zero()
g$bw()
dW = dfun(mdl$pars()$W$v, function(x)fn(x, mdl$pars()$B$v))
dB = dfun(mdl$pars()$B$v, function(x)fn(mdl$pars()$W$v, x))
ANS = tol.test(c(dW, dB), c(mdl$pars()$W$dv, mdl$pars()$B$dv))
modello.reset()
return(ANS)
}
test.opt<- function (opt, ...) {
x = matrix(stats::rnorm(100), nrow=20, ncol=5)
w = matrix(1, nrow = 5, ncol = 1)
y = x %*% w + stats::rnorm(20, 0, 0.001)
mdl = module.lm$new(TRUE, 5, 1, b=FALSE)
xx = number(x, dx=FALSE)
yy = number(y, dx=FALSE)
opt = opt(mdl$pars())
g = graph.open()
j = mdl$obj(yy, xx)
graph.close()
opt$step(g, j, ...)
tol.test(c(w), c(mdl$pars()$W$v))
}
test.dksqexp <-function (x1, x2, a, b) {
x1 = number(x1)
x2 = number(x2)
a = number(a, scalar=TRUE)
b = number(b, scalar=length(b)==1)
graph.open()
k = ksqexp(x1, x2, a, b)
k$dv = 1
k$bw()
graph.close()
dx1 = t(dfun(t(x1$v), function(x)ksqexp(x, t(x2$v), a$v, b$v)))
dx2 = t(dfun(t(x2$v), function(x)ksqexp(t(x1$v), x, a$v, b$v)))
da = dfun(a$v, function(x)ksqexp(t(x1$v), t(x2$v), x, b$v))
db = dfun(b$v, function(x)ksqexp(t(x1$v), t(x2$v), a$v, x))
tol.test(c(x1$dv, x1$dv, a$dv, b$dv), c(dx1, dx2, da, db))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.