When there's exactly 1 ADREPORT number, then sdreport() gives the error
Error in Dphi %% Vtheta %% t(Dphi) : non-conformable arguments
It looks like it's because in this case, Dphi is a vector instead of a matrix.
I'm pasting code for a reproducible example with 3 parameters. Dphi is a vector of length 3 in the case with 1 ADREPORT number or a 2-by-3 matrix in the case with 2 ADREPORT numbers.
I also made a new version of sdreport that catches this case. Do you want me to fork and offer this solution? I'm open to trying it for the learning experience.
library(TMB)
seed.set(111)
Set Parameter Values
mu=.5
sigma_proc=2
sigma_obs=3
nt=50
x0=1
Simulate Random Walk
x=cumsum(c(x0, rnorm(nt-1, mu, sd= sigma_proc)))
obs=x+rnorm(nt, sd= sigma_obs)
Write Model for TMB with 1 ADREPORT object
cat(file="rand_walk_1sd.cpp","
include <TMB.hpp>
template
Type objective_function::operator() ()
{
DATA_VECTOR(obs);
PARAMETER(mu);
PARAMETER(log_sigma_proc);
PARAMETER(log_sigma_obs);
PARAMETER_VECTOR(x);
Type nll;
Type sigma_proc = exp(log_sigma_proc);
Type sigma_obs = exp(log_sigma_obs);
ADREPORT(sigma_proc);
//ADREPORT(sigma_obs);
int nt=obs.size()-1;
nll=0;
for(int t=0; t<=nt-1; t++)
{
nll+= -dnorm(x(t+1)-x(t), mu, sigma_proc, 1);
}
for(int t=0; t<=nt; t++)
{
nll+= -dnorm(obs(t), x(t), sigma_obs, 1);
}
return nll;
}
")
compile("rand_walk_1sd.cpp")
dyn.load("rand_walk_1sd.so")
Write Model for TMB with 2 ADREPORT objects
cat(file="rand_walk_2sd.cpp","
include <TMB.hpp>
template
Type objective_function::operator() ()
{
DATA_VECTOR(obs);
PARAMETER(mu);
PARAMETER(log_sigma_proc);
PARAMETER(log_sigma_obs);
PARAMETER_VECTOR(x);
Type nll;
Type sigma_proc = exp(log_sigma_proc);
Type sigma_obs = exp(log_sigma_obs);
ADREPORT(sigma_proc);
ADREPORT(sigma_obs);
int nt=obs.size()-1;
nll=0;
for(int t=0; t<=nt-1; t++)
{
nll+= -dnorm(x(t+1)-x(t), mu, sigma_proc, 1);
}
for(int t=0; t<=nt; t++)
{
nll+= -dnorm(obs(t), x(t), sigma_obs, 1);
}
return nll;
}
")
compile("rand_walk_2sd.cpp")
dyn.load("rand_walk_2sd.so")
Get Data and Initial Parameter Values into TMB Format
data=list(obs=obs)
pars=list(mu=0, log_sigma_proc=0, log_sigma_obs=0, x=obs)
Run the model
mod1=MakeADFun(data,pars,random=c("x"), DLL="rand_walk_1sd")
opt1= nlminb(mod1$par, mod1$fn, mod1$gr)
mod2=MakeADFun(data,pars,random=c("x"), DLL="rand_walk_2sd")
opt2= nlminb(mod2$par, mod2$fn, mod2$gr)
View Estimates
sdreport(mod1)#This breaks
sdreport(mod2)
sdreport2=
function (obj, par.fixed = NULL, hessian.fixed = NULL, getJointPrecision = FALSE)
{ # obj=mod1; par.fixed = NULL; hessian.fixed = NULL; getJointPrecision = FALSE
if (is.null(obj$env$ADGrad) & (!is.null(obj$env$random)))
stop("Cannot calculate sd's without type ADGrad available in object for random effect models.")
obj2 <- MakeADFun(obj$env$data, obj$env$parameters, type = "ADFun",
ADreport = TRUE, DLL = obj$env$DLL)
r <- obj$env$random
if (is.null(par.fixed)) {
par <- obj$env$last.par.best
if (!is.null(r))
par.fixed <- par[-r]
else par.fixed <- par
gradient.fixed <- obj$gr(par.fixed)
}else {
gradient.fixed <- obj$gr(par.fixed)
par <- obj$env$last.par
}
if (is.null(hessian.fixed)) {
hessian.fixed <- optimHess(par.fixed, obj$fn, obj$gr)
}
pdHess <- !is.character(try(chol(hessian.fixed), silent = TRUE))
Vtheta <- solve(hessian.fixed)
if (!is.null(r)) {
hessian.random <- obj$env$spHess(par, random = TRUE)
L <- obj$env$L.created.by.newton
if (!is.null(L)) {
updateCholesky(L, hessian.random)
hessian.random@factors <- list(SPdCholesky = L)
}
}
simpleCase <- is.null(r)
phi <- try(obj2$fn(par), silent = TRUE)
if (is.character(phi) | length(phi) == 0) {
simpleCase <- TRUE
phi <- numeric(0)
}else {
Dphi <- obj2$gr(par)
if (!is.null(r)) {
Dphi.random <- Dphi[, r]
Dphi.fixed <- Dphi[, -r]
if (all(Dphi.random == 0)) {
simpleCase <- TRUE
Dphi <- Dphi.fixed
}
}
}
if (simpleCase) {
if (length(phi) > 0) {
if(length(phi)==1){
cov <- t(Dphi) %% Vtheta %% Dphi
}else{
cov <- Dphi %% Vtheta %% t(Dphi)
}
}else cov <- matrix(, 0, 0)
}else {
tmp <- solve(hessian.random, t(Dphi.random))
tmp <- as.matrix(tmp)
term1 <- Dphi.random %% tmp
f <- obj$env$f
w <- rep(0, length(par))
reverse.sweep <- function(i) {
w[r] <- tmp[, i]
-f(par, order = 1, type = "ADGrad", rangeweight = w)[-r]
}
A <- t(sapply(seq(length = length(phi)), reverse.sweep)) +
Dphi.fixed
term2 <- A %% (Vtheta %% t(A))
cov <- term1 + term2
}
sd <- sqrt(diag(cov))
ans <- list(value = phi, sd = sd, cov = cov, par.fixed = par.fixed,
cov.fixed = Vtheta, pdHess = pdHess, gradient.fixed = gradient.fixed)
if (!is.null(r)) {
if (is(L, "dCHMsuper") | is(L, "dCHMsimpl")) {
ihessian.random <- .Call("tmb_invQ", L, PACKAGE = "TMB")
iperm <- Matrix::invPerm(L@perm + 1L)
diag.term1 <- diag(ihessian.random)[iperm]
f <- obj$env$f
w <- rep(0, length(par))
reverse.sweep <- function(i) {
w[i] <- 1
f(par, order = 1, type = "ADGrad", rangeweight = w)[r]
}
nonr <- setdiff(seq(length = length(par)), r)
tmp <- sapply(nonr, reverse.sweep)
A <- solve(hessian.random, tmp)
diag.term2 <- rowSums((A %% Vtheta) * A)
ans$par.random <- par[r]
ans$diag.cov.random <- diag.term1 + diag.term2
if (getJointPrecision) {
G <- hessian.random %% A
M1 <- cbind2(hessian.random, G)
M2 <- cbind2(t(G), as.matrix(t(A) %% G) + hessian.fixed)
M <- rbind2(M1, M2)
M <- forceSymmetric(M, uplo = "L")
dn <- c(names(par)[r], names(par[-r]))
dimnames(M) <- list(dn, dn)
p <- Matrix::invPerm(c(r, (1:length(par))[-r]))
ans$jointPrecision <- M[p, p]
}
}else {
warning("Could not report sd's of full randomeffect vector.")
}
}
class(ans) <- "sdreport"
ans
}
sdreport2(mod1)
sdreport2(mod2)
React
Typescript
Django
Laravel
Facebook
Microsoft
Google
Alibaba
D3
Tencent