Luca, what you said makes sense. I just sketched out a very quick sampler, which performs a conjugate update for a dirichlet-distributed node, then adds an arbitrary constant to all elements of the new node value. The constant value is called "eps", and you can specify whatever value you want for eps (see example in the code below), or if you don't provide a value for eps then the default value is 1e-100.
This sampler is fairly simplistic and specialized, in that it only operates on a single node, that node must have a dirichlet prior distribution, and all dependencies of that node must have categorical distributions. Also, a heads up, the sampler is not clever enough to track how the target dirichlet node is actually used in the distributions of the dependent categorical nodes - it assumes that it's used directly as the probability parameter for each dependent categorical node. So you could easily violate this assumption, which would make the results incorrect.
An example of using this sampler (which is called the conjugate_dirch_plus_eps sampler) is given below, on a trivial example model. Please try it out, and let me know what you find. If you specify "eps = 0", then the constant of 0 is added, and you should get identical results as when using the conjugate sampler. And, when eps > 0, this should prevent the numeric underflow problems you were having before.
Cheers,
Daniel
library(nimble)
conjugate_dirch_plus_eps <- nimbleFunction(
contains = sampler_BASE,
setup = function(model, mvSaved, target, control) {
## control list extraction
eps <- extractControlElement(control, 'eps', 1e-100)
## node list generation
target <- model$expandNodeNames(target)
calcNodes <- model$getDependencies(target)
depNodes <- model$getDependencies(target, self = FALSE)
## numeric value generation
d <- length(model[[target]])
Ndeps <- length(depNodes)
## checks
if(length(target) > 1) stop('conjugate_dirch_plus_eps only operates on a single node')
if(model$getDistribution(target) != 'ddirch') stop('conjugate_dirch_plus_eps target node must have ddirch distribution')
depDists <- sapply(depNodes, function(x) model$getDistribution(x))
if(!all(depDists == 'dcat')) stop('conjugate_dirch_plus_eps all dependencies should have dcat distributions')
},
run = function() {
posterior_alpha <- model$getParam(target, 'alpha')
for(i in 1:Ndeps) {
depValue <- model$getParam(depNodes[i], 'value')
posterior_alpha[depValue] <- posterior_alpha[depValue] + 1
}
newTargetValue <- rdirch(1, posterior_alpha)
newTargetValue <- newTargetValue + eps
model[[target]] <<- newTargetValue
model$calculate(calcNodes)
nimCopy(from = model, to = mvSaved, row = 1, nodes = calcNodes, logProb = TRUE)
},
methods = list(
reset = function() {}
)
)
code <- nimbleCode({
x[1:3] ~ ddirch(a[1:3])
y ~ dcat(x[1:3])
y2 ~ dcat(x[1:3])
})
constants <- list(a = c(1, 1, 1))
data <- list(y = 1, y2 = 3)
inits <- list(x = c(1/3, 1/3, 1/3))
Rmodel <- nimbleModel(code, constants, data, inits)
conf <- configureMCMC(Rmodel)
## set value of eps here (default value is 1e-100)
conf$replaceSampler('x', conjugate_dirch_plus_eps, eps = 0.001)
Rmcmc <- buildMCMC(conf)
## compile, run, etc.....