// // [[Rcpp::export()]]
void getVgamma_hierIRT(arma::cube &Vgamma,
arma::mat &gammasigma,
arma::mat &Ebb,
const arma::mat &g,
const arma::mat &i,
const arma::mat &j,
const arma::mat &z,
const int NL,
const int NG
) {
signed int m, l;
#pragma omp parallel for private(m,l)
for(m=0; m < NG; m++){
Vgamma.slice(m) = inv_sympd(gammasigma);
for(l=0; l < NL; l++){
if( g(i(l,0),0)==m ) Vgamma.slice(m) += Ebb(j(l,0),0) * trans(z.row(i(l,0))) * z.row(i(l,0));
}
// Note this yield C_inv, not C_m
Vgamma.slice(m) = inv_sympd(Vgamma.slice(m));
} // for(k=0; n < NJ; k++){
return;
}
// compute the gradients of f and g at all data points
int dtq::gradFGdata(arma::cube &gfd, arma::cube &ggd)
{
for (int j=0; j<(ltvec-1); j++)
{
for (int l=0; l<numts; l++)
{
double xi = (*odata)(j,l);
gfd.slice(l).col(j) = (*gradf)(xi,curtheta);
ggd.slice(l).col(j) = (*gradg)(xi,curtheta);
}
}
return 0;
}
//' @title
//' mStep
//' @description
//' Return the parameters' posterior.
//'
//' @param DP
//' @param DataStorage
//' @param xi
//' @param zeta
//' @export
// [[Rcpp::export]]
arma::cube mStep(NumericVector prior, arma::cube posterior, NumericVector data, IntegerVector xi, IntegerVector zeta){
//NumericVector data = DataStorage.slot("simulation");
const int N = data.length();
//arma::cube prior = DP.slot("prior");
arma::mat mu = posterior.slice(0);
arma::mat Nmat = posterior.slice(1);
arma::mat v = posterior.slice(2);
arma::mat vs2 = posterior.slice(3);
std::fill(mu.begin(), mu.end(), prior[0]);
std::fill(Nmat.begin(), Nmat.end(), prior[1]);
std::fill(v.begin(), v.end(), prior[2]);
std::fill(vs2.begin(), vs2.end(), prior[3]);
int temp;
double update_mu;
double update_vs2;
double update_n;
double update_v;
for(int n=0; n < N; n++){
// if n is not NA
if(data(n) == data(n)){
temp = xi[n];
const int l = temp - 1;
temp = zeta[n];
const int k = temp - 1;
update_mu = (Nmat(l,k)*mu(l,k)+data(n))/(1+Nmat(l,k));
update_vs2 = vs2(l,k) + (Nmat(l,k)*std::pow((mu(l,k)-data(n)),2)/(1+Nmat(l,k)));
update_n = Nmat(l,k) + 1.0;
update_v = v(l,k) + 1.0;
mu(l,k) = update_mu;
Nmat(l,k) = update_n;
v(l,k) = update_v;
vs2(l,k) = update_vs2;
}
}
arma::cube toRet = posterior;
toRet.slice(0) = mu;
toRet.slice(1) = Nmat;
toRet.slice(2) = v;
toRet.slice(3) = vs2;
//DP.slot("prior") = posterior;
return toRet;
}
// build the big matrix of initial conditions
// and the gradients of those initial conditions!
int dtq::phatinitgrad(arma::mat &phatI, arma::cube &phatG, const arma::cube &gfd, const arma::cube &ggd)
{
double myh12 = sqrt(myh);
for (int j=0; j<(ltvec-1); j++)
{
// go through each particular initial condition at this time
// and make a Gaussian
for (int l=0; l<numts; l++)
{
double xi = (*odata)(j,l);
double mu = xi + ((*f)(xi,curtheta))*myh;
double gval = (*g)(xi,curtheta);
double sig = gval*myh12;
arma::vec thisphat = gausspdf(yvec,mu,sig);
phatI.col(j) += thisphat;
for (int i=0; i<curtheta.n_elem; i++)
{
arma::vec pgtemp = (yvec - mu)*gfd(i,j,l)/(gval*gval);
pgtemp -= ggd(i,j,l)/gval;
pgtemp += arma::pow(yvec - mu,2)*ggd(i,j,l)/(myh*gval*gval*gval);
phatG.slice(i).col(j) += pgtemp % thisphat;
}
}
}
phatI = phatI / numts;
phatG = phatG / numts;
return 0;
}
arma::cube get_Si(int n_states, arma::cube S, arma::mat m) {
arma::cube Si(n_states, n_states, n_states);
for (int i=0; i<n_states; i++) {
Si.slice(i) = S.slice(i) * m;
}
return Si;
}
void internalBackward(const arma::mat& transition, const arma::cube& emission,
const arma::ucube& obs, arma::cube& beta, const arma::mat& scales, unsigned int threads) {
#pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \
default(none) shared(beta, scales, obs, emission,transition)
for (unsigned int k = 0; k < obs.n_slices; k++) {
beta.slice(k).col(obs.n_cols - 1).fill(scales(obs.n_cols - 1, k));
for (int t = obs.n_cols - 2; t >= 0; t--) {
arma::vec tmpbeta = beta.slice(k).col(t + 1);
for (unsigned int r = 0; r < obs.n_rows; r++) {
tmpbeta %= emission.slice(r).col(obs(r, t + 1, k));
}
beta.slice(k).col(t) = transition * tmpbeta * scales(t, k);
}
}
}
// Bellman recursion using row rearrangement
//[[Rcpp::export]]
Rcpp::List Bellman(const arma::mat& grid,
Rcpp::NumericVector reward_,
const arma::cube& scrap,
Rcpp::NumericVector control_,
const arma::cube& disturb,
const arma::vec& weight) {
// Passing R objects to C++
const std::size_t n_grid = grid.n_rows;
const std::size_t n_dim = grid.n_cols;
const arma::ivec r_dims = reward_.attr("dim");
const std::size_t n_pos = r_dims(3);
const std::size_t n_action = r_dims(2);
const std::size_t n_dec = r_dims(4) + 1;
const arma::cube
reward(reward_.begin(), n_grid, n_dim * n_action * n_pos, n_dec - 1, false);
const arma::ivec c_dims = control_.attr("dim");
arma::cube control2;
arma::imat control;
bool full_control;
if (c_dims.n_elem == 3) {
full_control = false;
arma::cube temp_control2(control_.begin(), n_pos, n_action, n_pos, false);
control2 = temp_control2;
} else {
full_control = true;
arma::mat temp_control(control_.begin(), n_pos, n_action, false);
control = arma::conv_to<arma::imat>::from(temp_control);
}
const std::size_t n_disturb = disturb.n_slices;
// Bellman recursion
arma::cube value(n_grid, n_dim * n_pos, n_dec);
arma::cube cont(n_grid, n_dim * n_pos, n_dec - 1, arma::fill::zeros);
arma::mat d_value(n_grid, n_dim);
Rcpp::Rcout << "At dec: " << n_dec - 1 << "...";
for (std::size_t pp = 0; pp < n_pos; pp++) {
value.slice(n_dec - 1).cols(n_dim * pp, n_dim * (pp + 1) - 1) =
scrap.slice(pp);
}
for (int tt = (n_dec - 2); tt >= 0; tt--) {
Rcpp::Rcout << tt;
// Approximating the continuation value
for (std::size_t pp = 0; pp < n_pos; pp++) {
cont.slice(tt).cols(n_dim * pp, n_dim * (pp + 1) - 1) =
Expected(grid,
value.slice(tt + 1).cols(pp * n_dim, n_dim * (pp + 1) - 1),
disturb, weight);
}
Rcpp::Rcout << "..";
// Optimise value function
if (full_control) {
BellmanOptimal(grid, control, value, reward, cont, tt);
} else {
BellmanOptimal2(grid, control2, value, reward, cont, tt);
}
Rcpp::Rcout << ".";
}
return Rcpp::List::create(Rcpp::Named("value") = value,
Rcpp::Named("expected") = cont);
}
arma::mat cvt_rgb2gray(const arma::cube &image) {
arma::vec scale = { 0.3, 0.6, 0.1 };
arma::mat new_image = arma::zeros<arma::mat>(image.n_rows, image.n_cols);
for (arma::uword i = 0; i < image.n_slices; i++) {
new_image += scale(i) * image.slice(i); // weighted construction
}
return new_image;
}
void
HMM::computeXiCached() {
arma::mat temp = B_.rows(1,T_-1) % beta_.cols(1,T_-1).t();
for(unsigned int i = 0; i < N_; ++i) {
xi_.slice(i) = temp %
(alpha_(i,arma::span(0, T_-2)).t() * A_.row(i));
}
}
// // [[Rcpp::export()]]
void getVb2_dynIRT(arma::cube &Vb2,
const arma::cube &Ex2x2,
const arma::mat &sigma,
const int T
) {
int t;
#pragma omp parallel for
for(t=0; t<T; t++){
Vb2.slice(t) = inv_sympd(inv_sympd(sigma) + Ex2x2.slice(t)) ;
}
return;
}
// how to subset outer dimension of arma cube by IntegerVector
// [[Rcpp::export]]
arma::cube subsetCube(arma::cube data, IntegerVector index){
if(data.n_slices != index.size()){ //informative error message
Rcout << "subsetCube requires an array and index of the same outer dimension!" << std::endl;
}
arma::cube out = arma::zeros(data.n_rows,data.n_cols,data.n_slices);
for(int i=0; i<data.n_slices; i++){
out.slice(i) = data.slice(index(i));
}
return(out);
}
/*
* approx_model: Gaussian approximation of the original model
* t: Time point where the weights are computed
* alpha: Simulated particles
*/
arma::vec ung_ssm::log_weights(const ugg_ssm& approx_model,
const unsigned int t, const arma::cube& alpha) const {
arma::vec weights(alpha.n_slices, arma::fill::zeros);
if (arma::is_finite(y(t))) {
switch(distribution) {
case 0 :
for (unsigned int i = 0; i < alpha.n_slices; i++) {
double simsignal = alpha(0, t, i);
weights(i) = -0.5 * (simsignal + std::pow(y(t) / phi, 2.0) * std::exp(-simsignal)) +
0.5 * std::pow((approx_model.y(t) - simsignal) / approx_model.H(t), 2.0);
}
break;
case 1 :
for (unsigned int i = 0; i < alpha.n_slices; i++) {
double simsignal = arma::as_scalar(Z.col(t * Ztv).t() *
alpha.slice(i).col(t) + xbeta(t));
weights(i) = y(t) * simsignal - u(t) * std::exp(simsignal) +
0.5 * std::pow((approx_model.y(t) - simsignal) / approx_model.H(t), 2.0);
}
break;
case 2 :
for (unsigned int i = 0; i < alpha.n_slices; i++) {
double simsignal = arma::as_scalar(Z.col(t * Ztv).t() *
alpha.slice(i).col(t) + xbeta(t));
weights(i) = y(t) * simsignal - u(t) * std::log1p(std::exp(simsignal)) +
0.5 * std::pow((approx_model.y(t) - simsignal) / approx_model.H(t), 2.0);
}
break;
case 3 :
for (unsigned int i = 0; i < alpha.n_slices; i++) {
double simsignal = arma::as_scalar(Z.col(t * Ztv).t() *
alpha.slice(i).col(t) + xbeta(t));
weights(i) = y(t) * simsignal - (y(t) + phi) *
std::log(phi + u(t) * std::exp(simsignal)) +
0.5 * std::pow((approx_model.y(t) - simsignal) / approx_model.H(t), 2.0);
}
break;
}
}
return weights;
}
// @title Gradient step for regression coefficient
// @param X The ratings matrix. Unobserved entries must be marked NA. Users
// must be along rows, and tracks must be along columns.
// @param P The learned user latent factors.
// @param Q The learned track latent factors.
// @param beta The learned regression coefficients.
// @param lambda The regularization parameter for beta.
// @param gamma The step-size in the gradient descent.
// @return The update regression coefficients.
arma::vec update_beta(arma::mat X, arma::cube Z, arma::mat P, arma::mat Q,
arma::vec beta, double lambda, double gamma) {
arma::uvec obs_ix = arma::conv_to<arma::uvec>::from(arma::find_finite(X));
arma::mat resid = X - P * Q.t() - cube_multiply(Z, beta);
arma::vec beta_grad = arma::zeros(beta.size());
for(int l = 0; l < beta.size(); l++) {
beta_grad[l] = accu(resid(obs_ix) % Z.slice(l)(obs_ix));
}
beta_grad = 2 * (lambda * beta - beta_grad);
return beta - gamma * beta_grad;
}
NumericVector logLikMixHMM(const arma::mat& transition, const arma::cube& emission,
const arma::vec& init, const arma::ucube& obs, const arma::mat& coef, const arma::mat& X,
const arma::uvec& numberOfStates, unsigned int threads) {
arma::mat weights = exp(X * coef).t();
if (!weights.is_finite()) {
return wrap(-arma::datum::inf);
}
weights.each_row() /= sum(weights, 0);
arma::vec ll(obs.n_slices);
arma::sp_mat transition_t(transition.t());
#pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \
default(none) shared(ll, obs, weights, init, emission, transition_t, numberOfStates)
for (unsigned int k = 0; k < obs.n_slices; k++) {
arma::vec alpha = init % reparma(weights.col(k), numberOfStates);
for (unsigned int r = 0; r < obs.n_rows; r++) {
alpha %= emission.slice(r).col(obs(r, 0, k));
}
double tmp = sum(alpha);
ll(k) = log(tmp);
alpha /= tmp;
for (unsigned int t = 1; t < obs.n_cols; t++) {
alpha = transition_t * alpha;
for (unsigned int r = 0; r < obs.n_rows; r++) {
alpha %= emission.slice(r).col(obs(r, t, k));
}
tmp = sum(alpha);
ll(k) += log(tmp);
alpha /= tmp;
}
}
return wrap(ll);
}
arma::mat exact_trans2(arma::cube joint_means_trans, Rcpp::List eigen_decomp, double time_int, arma::ivec absorb_states, int start_state, int end_state, int exact_time_index){
arma::mat rate_matrix=Rcpp::as<arma::mat>(eigen_decomp["rate"]);
arma::mat out=arma::zeros<arma::mat>(rate_matrix.n_rows,rate_matrix.n_rows);
arma::mat temp=arma::zeros<arma::mat>(rate_matrix.n_rows,rate_matrix.n_rows);
int i=start_state-1;
int j=end_state-1;
int k=0;
bool i_in_A=0;
bool j_in_A=0;
//std::cout<<absorb_states;
while(i_in_A==0 && k<absorb_states.size()){
int test=absorb_states[k]-1;
if(test==i){
i_in_A=1;
}
k++;
}
k=0;
while(j_in_A==0 && k<absorb_states.size()){
int test=absorb_states[k]-1;
if(test==j){
j_in_A=1;
}
k++;
}
int in_either=i_in_A+j_in_A;
if(in_either==0){
for(int l=0;l<absorb_states.size();l++){
int absorb_state=absorb_states[l]-1;
temp.col(absorb_state)=rate_matrix.col(absorb_state);
}
out=joint_means_trans.slice(exact_time_index)*temp;
}
if(i_in_A==0 && j_in_A==1){
arma::mat prob_mat=mat_exp_eigen_cpp(eigen_decomp,time_int);
out.col(j)=prob_mat.col(i)*rate_matrix(i,j);
}
return(out);
}
// Expected value using row rearrangement
//[[Rcpp::export]]
arma::mat Expected(const arma::mat& grid,
const arma::mat& value,
const arma::cube& disturb,
const arma::vec& weight) {
// Passing R objects to C++
const std::size_t n_grid = grid.n_rows;
const std::size_t n_dim = grid.n_cols;
const std::size_t n_disturb = disturb.n_slices;
// Computing the continuation value function
arma::mat continuation(n_grid, n_dim, arma::fill::zeros);
arma::mat d_value(n_grid, n_dim);
for (std::size_t dd = 0; dd < n_disturb; dd++) {
d_value = value * disturb.slice(dd);
continuation += weight(dd) * Optimal(grid, d_value);
}
return continuation;
}
//--------------------------------------------------------------------------------------------------
double Krigvar( const arma::colvec& KF,
const arma::cube& Gamma ) {
int i;
int n = Gamma.n_rows;
int m = Gamma.n_slices;
double Var;
arma::mat V = arma::ones( n, n );
for( i = 0; i < m; i++ ) {
V = V % ( arma::ones( n, n ) + Gamma.slice( i ) );
}
V = V - arma::ones( n, n );
Var = as_scalar( KF.t() * V * KF );
return Var;
}
//--------------------------------------------------------------------------------------------------
double Krigidx( const arma::colvec& KF,
const arma::colvec& comb,
const arma::mat& X,
const arma::cube& Gamma ) {
int k;
int n = X.n_rows;
int c = comb.size();
double S;
arma::mat W = arma::ones( n, n );
for ( k = 0; k < c; k++ ) {
W = W % Gamma.slice( comb( k ) - 1 );
}
S = as_scalar( KF.t() * W * KF );
return S;
}
NumericVector log_logLikMixHMM(arma::mat transition, arma::cube emission, arma::vec init,
const arma::ucube& obs, const arma::mat& coef, const arma::mat& X,
const arma::uvec& numberOfStates, unsigned int threads) {
arma::mat weights = exp(X * coef).t();
if (!weights.is_finite()) {
return wrap(-arma::datum::inf);
}
weights.each_row() /= sum(weights, 0);
weights = log(weights);
transition = log(transition);
emission = log(emission);
init = log(init);
arma::vec ll(obs.n_slices);
#pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \
default(none) shared(ll, obs, weights, init, emission, transition, numberOfStates)
for (unsigned int k = 0; k < obs.n_slices; k++) {
arma::vec alpha = init + reparma(weights.col(k), numberOfStates);
for (unsigned int r = 0; r < obs.n_rows; r++) {
alpha += emission.slice(r).col(obs(r, 0, k));
}
arma::vec alphatmp(emission.n_rows);
for (unsigned int t = 1; t < obs.n_cols; t++) {
for (unsigned int i = 0; i < emission.n_rows; i++) {
alphatmp(i) = logSumExp(alpha + transition.col(i));
for (unsigned int r = 0; r < obs.n_rows; r++) {
alphatmp(i) += emission(i, obs(r, t, k), r);
}
}
alpha = alphatmp;
}
ll(k) = logSumExp(alpha);
}
return wrap(ll);
}
// // [[Rcpp::export()]]
arma::mat getEb2_ordIRT(const arma::mat &Ezstar,
const arma::mat &Ex,
const arma::cube &Vb2,
const arma::mat &mubeta,
const arma::mat &sigmabeta,
const arma::mat &Edd,
const int J
) {
arma::mat ones(Ex.n_rows, 1) ;
ones.ones() ;
arma::mat Ex2 = Ex ;
Ex2.insert_cols(0, ones) ;
arma::mat Eb2(J, 2) ;
#pragma omp parallel for
for (int j = 0; j < J; j++) {
Eb2.row(j) = trans(Vb2.slice(j) * (inv_sympd(sigmabeta) * mubeta + Edd(j,0) * trans(Ex2) * Ezstar.col(j))) ;
}
return(Eb2) ;
}
//[[Rcpp::export]]
arma::cube PathDisturb(const arma::vec& start,
Rcpp::NumericVector disturb_) {
// R objects to C++
const arma::ivec d_dims = disturb_.attr("dim");
const std::size_t n_dim = d_dims(0);
const std::size_t n_dec = d_dims(3) + 1;
const std::size_t n_path = d_dims(2);
const arma::cube disturb(disturb_.begin(), n_dim, n_dim * n_path, n_dec - 1,
false);
// Simulating the sample paths
arma::cube path(n_path, n_dim, n_dec);
// Assign starting values
for (std::size_t ii = 0; ii < n_dim; ii++) {
path.slice(0).col(ii).fill(start(ii));
}
// Disturb the paths
for (std::size_t pp = 0; pp < n_path; pp++) {
for (std::size_t tt = 1; tt < n_dec; tt++) {
path.slice(tt).row(pp) = path.slice(tt - 1).row(pp) *
arma::trans(disturb.slice(tt - 1).cols(n_dim * pp, n_dim * (pp + 1) - 1));
}
}
return path;
}
// Calculate the martingale increments using the row rearrangement
//[[Rcpp::export]]
arma::cube AddDual(const arma::cube& path,
Rcpp::NumericVector subsim_,
const arma::vec& weight,
Rcpp::NumericVector value_,
Rcpp::Function Scrap_) {
// R objects to C++
const std::size_t n_path = path.n_rows;
const arma::ivec v_dims = value_.attr("dim");
const std::size_t n_grid = v_dims(0);
const std::size_t n_dim = v_dims(1);
const std::size_t n_pos = v_dims(2);
const std::size_t n_dec = v_dims(3);
const arma::cube value(value_.begin(), n_grid, n_dim * n_pos, n_dec, false);
const arma::ivec s_dims = subsim_.attr("dim");
const std::size_t n_subsim = s_dims(2);
const arma::cube subsim(subsim_.begin(), n_dim, n_dim * n_subsim * n_path, n_dec - 1, false);
// Duals
arma::cube mart(n_path, n_pos, n_dec - 1);
arma::mat temp_state(n_subsim * n_path, n_dim);
arma::mat fitted(n_grid, n_dim);
std::size_t ll;
Rcpp::Rcout << "Additive duals at dec: ";
// Find averaged value
for (std::size_t tt = 0; tt < (n_dec - 2); tt++) {
Rcpp::Rcout << tt << "...";
// 1 step subsimulation
#pragma omp parallel for private(ll)
for (std::size_t ii = 0; ii < n_path; ii++) {
for (std::size_t ss = 0; ss < n_subsim; ss++) {
ll = n_subsim * ii + ss;
temp_state.row(ll) = weight(ss) * path.slice(tt).row(ii) *
arma::trans(subsim.slice(tt).cols(n_dim * ll, n_dim * (ll + 1) - 1));
}
}
// Averaging
for (std::size_t pp = 0; pp < n_pos; pp++) {
fitted = value.slice(tt + 1).cols(n_dim * pp, n_dim * (pp + 1) - 1);
mart.slice(tt).col(pp) = arma::conv_to<arma::vec>::from(arma::sum(arma::reshape(
OptimalValue(temp_state, fitted), n_subsim, n_path)));
// Subtract the path realisation
mart.slice(tt).col(pp) -= OptimalValue(path.slice(tt + 1), fitted);
}
}
// Scrap value
Rcpp::Rcout << n_dec - 1 << "...";
// 1 step subsimulation
#pragma omp parallel for private(ll)
for (std::size_t ii = 0; ii < n_path; ii++) {
for (std::size_t ss = 0; ss < n_subsim; ss++) {
ll = n_subsim * ii + ss;
temp_state.row(n_path * ss + ii) = path.slice(n_dec - 2).row(ii) *
arma::trans(subsim.slice(n_dec - 2).cols(n_dim * ll, n_dim * (ll + 1) - 1));
}
}
// Averaging
arma::mat subsim_scrap(n_subsim * n_path, n_pos);
subsim_scrap = Rcpp::as<arma::mat>(Scrap_(
Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(temp_state))));
arma::mat scrap(n_path, n_pos);
scrap = Rcpp::as<arma::mat>(Scrap_(
Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(path.slice(n_dec - 1)))));
for (std::size_t pp = 0; pp < n_pos; pp++) {
mart.slice(n_dec - 2).col(pp) =
arma::reshape(subsim_scrap.col(pp), n_path, n_subsim) * weight;
// Subtract the path realisation
mart.slice(n_dec - 2).col(pp) -= scrap.col(pp);
}
Rcpp::Rcout << "done\n";
return mart;
}
inline double MuOrAlphaProduct(const int chromophore, const int corr_start,
const int i_corr) {
return arma::dot(mu_01_.slice(chromophore).col(corr_start),
mu_01_.slice(chromophore).col(corr_start+i_corr));
}
double
HMM::baumWelchCached(const arma::mat & data, const std::vector<GMM> & B, unsigned int seed = 0) {
init(B, seed);
allocateMemory(data.n_cols);
cacheProbabilities(data);
double logprobc = forwardProcedureCached();
double logprobprev = 0.0;
double delta;
do {
backwardProcedureCached();
computeXiCached();
computeGamma();
logprobprev = logprobc;
//update state probabilities pi
pi_ = gamma_.col(0).t();
for (unsigned int i = 0; i < N_; ++i) {
arma::rowvec xi_i = arma::sum(xi_.slice(i));
double shortscale = 1./arma::accu(gamma_.submat(arma::span(i),arma::span(0,T_-2)));
for (unsigned int j = 0; j < N_; ++j) {
A_(i,j) = xi_i(j) * shortscale;
}
// and update distributions
unsigned int numComponents = (unsigned int) BModels_[i].getNumComponents();
arma::mat gamma_lt = arma::mat(T_, numComponents);
gamma_lt = (gamma_.row(i).t()* arma::ones(1, numComponents))% gammaLts_[i];
for(unsigned int t = 0; t < T_ ; ++t) {
double sumProb = B_(t,i);
if (sumProb != 0.) {
gamma_lt.row(t) /= sumProb;
}
}
double scale = 1./arma::accu(gamma_.row(i));
for (unsigned int l = 0; l < numComponents; ++l) {
double sumGammaLt = arma::accu(gamma_lt.col(l));
double newWeight = scale * sumGammaLt;
arma::vec newMu = data * gamma_lt.col(l) / sumGammaLt;
arma::mat tempMat = data- newMu * arma::ones(1,T_);
unsigned int d = data.n_rows;
arma::mat newSigma = arma::zeros(d, d);
for (unsigned int t = 0; t < T_ ; ++t) {
arma::vec diff = data.col(t) - newMu;
newSigma += diff * diff.t() * gamma_lt(t, l)/ sumGammaLt;
}
try{
BModels_[i].updateGM(l, newWeight, newMu, newSigma);
}
catch( const std::runtime_error & e) {
tempMat.print("tempMat");
gamma_lt.col(l).print("gamma_lt");
throw e;
}
}
arma::uvec indices = BModels_[i].cleanupGMs();
gammaLts_[i] = gammaLts_[i].cols(indices);
}
cacheProbabilities(data);
logprobc = forwardProcedureCached();
std::cout << logprobc << " " << logprobprev << std::endl;
delta = logprobc - logprobprev;
}
while (delta >= eps_ * std::abs(logprobprev));
return logprobc;
}
//[[Rcpp::export]]
Rcpp::List AddDualBounds(const arma::cube& path,
Rcpp::NumericVector control_,
Rcpp::Function Reward_,
Rcpp::Function Scrap_,
const arma::cube& mart,
const arma::ucube& path_action) {
// Extract parameters
const std::size_t n_dec = path.n_slices;
const std::size_t n_path = path.n_rows;
const std::size_t n_dim = path.n_cols;
const arma::ivec c_dims = control_.attr("dim");
const std::size_t n_pos = c_dims(0);
const std::size_t n_action = c_dims(1);
arma::imat control; // full control
arma::cube control2; // partial control
bool full_control;
if (c_dims.n_elem == 3) {
full_control = false;
arma::cube temp_control2(control_.begin(), n_pos, n_action, n_pos, false);
control2 = temp_control2;
} else {
full_control = true;
arma::mat temp_control(control_.begin(), n_pos, n_action, false);
control = arma::conv_to<arma::imat>::from(temp_control);
}
// Initialise with scrap value
arma::cube primals(n_path, n_pos, n_dec);
primals.slice(n_dec - 1) = Rcpp::as<arma::mat>(
Scrap_(Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(path.slice(n_dec - 1)))));
arma::cube duals = primals;
// Perform the backward induction
arma::uword policy;
arma::cube reward(n_path, n_action, n_pos);
if (full_control) { // For the full control case
arma::uword next;
for (int tt = (n_dec - 2); tt >= 0; tt--) {
reward = Rcpp::as<arma::cube>(Reward_(
Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(path.slice(tt))), tt + 1));
#pragma omp parallel for private(policy, next)
for (std::size_t ii = 0; ii < n_path; ii++) {
for (std::size_t pp = 0; pp < n_pos; pp++) {
// Primal values
policy = path_action(ii, pp, tt) - 1; // R to C indexing
next = control(pp, policy) - 1;
primals(ii, pp, tt) = reward(ii, policy, pp) + mart(ii, next, tt)
+ primals(ii, next, tt + 1);
// Dual values
next = control(pp, 0) - 1;
duals(ii, pp, tt) = reward(ii, 0, pp) + mart(ii, next, tt)
+ duals(ii, next, tt + 1);
for (std::size_t aa = 1; aa < n_action; aa++) {
next = control(pp, aa) - 1;
duals(ii, pp, tt) = std::max(reward(ii, aa, pp) + mart(ii, next, tt)
+ duals(ii, next, tt + 1), duals(ii, pp, tt));
}
}
}
}
} else { // Positions evolve randomly
arma::rowvec mod(n_pos);
arma::rowvec prob_weight(n_pos);
for (int tt = (n_dec - 2); tt >= 0; tt--) {
reward = Rcpp::as<arma::cube>(Reward_(
Rcpp::as<Rcpp::NumericMatrix>(Rcpp::wrap(path.slice(tt))), tt + 1));
#pragma omp parallel for private(policy, prob_weight, mod)
for (std::size_t ii = 0; ii < n_path; ii++) {
for (std::size_t pp = 0; pp < n_pos; pp++) {
// Primal values
mod = primals.slice(tt + 1).row(ii) + mart.slice(tt).row(ii);
policy = path_action(ii, pp, tt) - 1;
prob_weight = control2.tube(pp, policy);
primals(ii, pp, tt) =
reward(ii, policy, pp) + arma::sum(prob_weight % mod);
// Dual values
mod = duals.slice(tt + 1).row(ii) + mart.slice(tt).row(ii);
prob_weight = control2.tube(pp, 0);
duals(ii, pp, tt) = reward(ii, 0, pp) + arma::sum(prob_weight % mod);
for (std::size_t aa = 1; aa < n_action; aa++) {
prob_weight = control2.tube(pp, aa);
duals(ii, pp, tt) =
std::max(reward(ii, aa, pp) + arma::sum(prob_weight % mod),
duals(ii, pp, tt));
}
}
}
}
}
return Rcpp::List::create(Rcpp::Named("primal") = primals,
Rcpp::Named("dual") = duals);
}
List objectivex(const arma::mat& transition, const arma::cube& emission,
const arma::vec& init, const arma::ucube& obs, const arma::umat& ANZ,
const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols,
const arma::mat& coef, const arma::mat& X, arma::uvec& numberOfStates,
unsigned int threads) {
unsigned int q = coef.n_rows;
arma::vec grad(
arma::accu(ANZ) + arma::accu(BNZ) + arma::accu(INZ) + (numberOfStates.n_elem- 1) * q,
arma::fill::zeros);
arma::mat weights = exp(X * coef).t();
if (!weights.is_finite()) {
grad.fill(-arma::datum::inf);
return List::create(Named("objective") = arma::datum::inf, Named("gradient") = wrap(grad));
}
weights.each_row() /= sum(weights, 0);
arma::mat initk(emission.n_rows, obs.n_slices);
for (unsigned int k = 0; k < obs.n_slices; k++) {
initk.col(k) = init % reparma(weights.col(k), numberOfStates);
}
arma::uvec cumsumstate = arma::cumsum(numberOfStates);
unsigned int error = 0;
double ll = 0;
#pragma omp parallel for if(obs.n_slices >= threads) schedule(static) reduction(+:ll) num_threads(threads) \
default(none) shared(q, grad, nSymbols, ANZ, BNZ, INZ, \
numberOfStates, cumsumstate, obs, init, initk, X, weights, transition, emission, error)
for (unsigned int k = 0; k < obs.n_slices; k++) {
if (error == 0) {
arma::mat alpha(emission.n_rows, obs.n_cols); //m,n
arma::vec scales(obs.n_cols); //n
arma::sp_mat sp_trans(transition);
uvForward(sp_trans.t(), emission, initk.col(k), obs.slice(k), alpha, scales);
arma::mat beta(emission.n_rows, obs.n_cols); //m,n
uvBackward(sp_trans, emission, obs.slice(k), beta, scales);
int countgrad = 0;
arma::vec grad_k(grad.n_elem, arma::fill::zeros);
// transitionMatrix
if (arma::accu(ANZ) > 0) {
for (unsigned int jj = 0; jj < numberOfStates.n_elem; jj++) {
arma::vec gradArow(numberOfStates(jj));
arma::mat gradA(numberOfStates(jj), numberOfStates(jj));
int ind_jj = cumsumstate(jj) - numberOfStates(jj);
for (unsigned int i = 0; i < numberOfStates(jj); i++) {
arma::uvec ind = arma::find(ANZ.row(ind_jj + i).subvec(ind_jj, cumsumstate(jj) - 1));
if (ind.n_elem > 0) {
gradArow.zeros();
gradA.eye();
gradA.each_row() -= transition.row(ind_jj + i).subvec(ind_jj, cumsumstate(jj) - 1);
gradA.each_col() %= transition.row(ind_jj + i).subvec(ind_jj, cumsumstate(jj) - 1).t();
for (unsigned int j = 0; j < numberOfStates(jj); j++) {
for (unsigned int t = 0; t < (obs.n_cols - 1); t++) {
double tmp = alpha(ind_jj + i, t);
for (unsigned int r = 0; r < obs.n_rows; r++) {
tmp *= emission(ind_jj + j, obs(r, t + 1, k), r);
}
gradArow(j) += tmp * beta(ind_jj + j, t + 1);
}
}
gradArow = gradA * gradArow;
grad_k.subvec(countgrad, countgrad + ind.n_elem - 1) = gradArow.rows(ind);
countgrad += ind.n_elem;
}
}
}
}
if (arma::accu(BNZ) > 0) {
// emissionMatrix
for (unsigned int r = 0; r < obs.n_rows; r++) {
arma::vec gradBrow(nSymbols(r));
arma::mat gradB(nSymbols(r), nSymbols(r));
for (unsigned int i = 0; i < emission.n_rows; i++) {
arma::uvec ind = arma::find(BNZ.slice(r).row(i));
if (ind.n_elem > 0) {
gradBrow.zeros();
gradB.eye();
gradB.each_row() -= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1);
gradB.each_col() %= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1).t();
for (unsigned int j = 0; j < nSymbols(r); j++) {
if (obs(r, 0, k) == j) {
double tmp = initk(i, k);
for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) {
if (r2 != r) {
tmp *= emission(i, obs(r2, 0, k), r2);
}
}
gradBrow(j) += tmp * beta(i, 0);
}
for (unsigned int t = 0; t < (obs.n_cols - 1); t++) {
if (obs(r, t + 1, k) == j) {
double tmp = beta(i, t + 1);
for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) {
if (r2 != r) {
tmp *= emission(i, obs(r2, t + 1, k), r2);
}
}
gradBrow(j) += arma::dot(alpha.col(t), transition.col(i)) * tmp;
}
}
}
gradBrow = gradB * gradBrow;
grad_k.subvec(countgrad, countgrad + ind.n_elem - 1) = gradBrow.rows(ind);
countgrad += ind.n_elem;
}
}
}
}
if (arma::accu(INZ) > 0) {
for (unsigned int i = 0; i < numberOfStates.n_elem; i++) {
int ind_i = cumsumstate(i) - numberOfStates(i);
arma::uvec ind = arma::find(
INZ.subvec(ind_i, cumsumstate(i) - 1));
if (ind.n_elem > 0) {
arma::vec gradIrow(numberOfStates(i), arma::fill::zeros);
for (unsigned int j = 0; j < numberOfStates(i); j++) {
double tmp = weights(i, k);
for (unsigned int r = 0; r < obs.n_rows; r++) {
tmp *= emission(ind_i + j, obs(r, 0, k), r);
}
gradIrow(j) += tmp * beta(ind_i + j, 0);
}
arma::mat gradI(numberOfStates(i), numberOfStates(i), arma::fill::zeros);
gradI.eye();
gradI.each_row() -= init.subvec(ind_i, cumsumstate(i) - 1).t();
gradI.each_col() %= init.subvec(ind_i, cumsumstate(i) - 1);
gradIrow = gradI * gradIrow;
grad_k.subvec(countgrad, countgrad + ind.n_elem - 1) = gradIrow.rows(ind);
countgrad += ind.n_elem;
}
}
}
for (unsigned int jj = 1; jj < numberOfStates.n_elem; jj++) {
unsigned int ind_jj = (cumsumstate(jj) - numberOfStates(jj));
for (unsigned int j = 0; j < emission.n_rows; j++) {
double tmp = 1.0;
for (unsigned int r = 0; r < obs.n_rows; r++) {
tmp *= emission(j, obs(r, 0, k), r);
}
if ((j >= ind_jj) & (j < cumsumstate(jj))) {
grad_k.subvec(countgrad + q * (jj - 1), countgrad + q * jj - 1) += tmp
* beta(j, 0) * initk(j, k) * X.row(k).t() * (1.0 - weights(jj, k));
} else {
grad_k.subvec(countgrad + q * (jj - 1), countgrad + q * jj - 1) -= tmp
* beta(j, 0) * initk(j, k) * X.row(k).t() * weights(jj, k);
}
}
}
if (!scales.is_finite() || !beta.is_finite()) {
#pragma omp atomic
error++;
} else {
ll -= arma::sum(log(scales));
#pragma omp critical
grad += grad_k;
}
}
}
if(error > 0){
ll = -arma::datum::inf;
grad.fill(-arma::datum::inf);
}
return List::create(Named("objective") = -ll, Named("gradient") = wrap(-grad));
}
// [[Rcpp::export]]
Rcpp::List objective(const arma::mat& transition, const arma::cube& emission,
const arma::vec& init, arma::ucube& obs, const arma::umat& ANZ,
const arma::ucube& BNZ, const arma::uvec& INZ, const arma::uvec& nSymbols, unsigned int threads) {
arma::vec grad(arma::accu(ANZ) + arma::accu(BNZ) + arma::accu(INZ), arma::fill::zeros);
unsigned int error = 0;
double ll = 0;
#pragma omp parallel for if(obs.n_slices >= threads) schedule(static) reduction(+:ll) num_threads(threads) \
default(shared) //shared(grad, nSymbols, ANZ, BNZ, INZ, obs, init, transition, emission, error, arma::fill::zeros)
for (unsigned int k = 0; k < obs.n_slices; k++) {
if (error == 0) {
arma::mat alpha(emission.n_rows, obs.n_cols); //m,n
arma::vec scales(obs.n_cols); //n
arma::sp_mat sp_trans(transition);
uvForward(sp_trans.t(), emission, init, obs.slice(k), alpha, scales);
arma::mat beta(emission.n_rows, obs.n_cols); //m,n
uvBackward(sp_trans, emission, obs.slice(k), beta, scales);
int countgrad = 0;
arma::vec grad_k(grad.n_elem, arma::fill::zeros);
// transitionMatrix
arma::vec gradArow(emission.n_rows);
arma::mat gradA(emission.n_rows, emission.n_rows);
for (unsigned int i = 0; i < emission.n_rows; i++) {
arma::uvec ind = arma::find(ANZ.row(i));
if (ind.n_elem > 0) {
gradArow.zeros();
gradA.eye();
gradA.each_row() -= transition.row(i);
gradA.each_col() %= transition.row(i).t();
for (unsigned int t = 0; t < (obs.n_cols - 1); t++) {
for (unsigned int j = 0; j < emission.n_rows; j++) {
double tmp = 1.0;
for (unsigned int r = 0; r < obs.n_rows; r++) {
tmp *= emission(j, obs(r, t + 1, k), r);
}
gradArow(j) += alpha(i, t) * tmp * beta(j, t + 1);
}
}
gradArow = gradA * gradArow;
grad_k.subvec(countgrad, countgrad + ind.n_elem - 1) = gradArow.rows(ind);
countgrad += ind.n_elem;
}
}
// emissionMatrix
for (unsigned int r = 0; r < obs.n_rows; r++) {
arma::vec gradBrow(nSymbols(r));
arma::mat gradB(nSymbols(r), nSymbols(r));
for (unsigned int i = 0; i < emission.n_rows; i++) {
arma::uvec ind = arma::find(BNZ.slice(r).row(i));
if (ind.n_elem > 0) {
gradBrow.zeros();
gradB.eye();
gradB.each_row() -= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1);
gradB.each_col() %= emission.slice(r).row(i).subvec(0, nSymbols(r) - 1).t();
for (unsigned int j = 0; j < nSymbols(r); j++) {
if (obs(r, 0, k) == j) {
double tmp = 1.0;
for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) {
if (r2 != r) {
tmp *= emission(i, obs(r2, 0, k), r2);
}
}
gradBrow(j) += init(i) * tmp * beta(i, 0);
}
for (unsigned int t = 0; t < (obs.n_cols - 1); t++) {
if (obs(r, t + 1, k) == j) {
double tmp = 1.0;
for (unsigned int r2 = 0; r2 < obs.n_rows; r2++) {
if (r2 != r) {
tmp *= emission(i, obs(r2, t + 1, k), r2);
}
}
gradBrow(j) += arma::dot(alpha.col(t), transition.col(i)) * tmp
* beta(i, t + 1);
}
}
}
gradBrow = gradB * gradBrow;
grad_k.subvec(countgrad, countgrad + ind.n_elem - 1) = gradBrow.rows(ind);
countgrad += ind.n_elem;
}
}
}
// InitProbs
arma::uvec ind = arma::find(INZ);
if (ind.n_elem > 0) {
arma::vec gradIrow(emission.n_rows);
arma::mat gradI(emission.n_rows, emission.n_rows);
gradIrow.zeros();
gradI.zeros();
gradI.eye();
gradI.each_row() -= init.t();
gradI.each_col() %= init;
for (unsigned int j = 0; j < emission.n_rows; j++) {
double tmp = 1.0;
for (unsigned int r = 0; r < obs.n_rows; r++) {
tmp *= emission(j, obs(r, 0, k), r);
}
gradIrow(j) += tmp * beta(j, 0);
}
gradIrow = gradI * gradIrow;
grad_k.subvec(countgrad, countgrad + ind.n_elem - 1) = gradIrow.rows(ind);
countgrad += ind.n_elem;
}
if (!scales.is_finite() || !beta.is_finite()) {
#pragma omp atomic
error++;
} else {
ll -= arma::sum(log(scales));
#pragma omp critical
grad += grad_k;
// gradmat.col(k) = grad_k;
}
// for (unsigned int ii = 0; ii < grad_k.n_elem; ii++) {
// #pragma omp atomic
// grad(ii) += grad_k(ii);
// }
}
}
if(error > 0){
ll = -arma::datum::inf;
grad.fill(-arma::datum::inf);
}
// } else {
// grad = sum(gradmat, 1);
// }
return Rcpp::List::create(Rcpp::Named("objective") = -ll, Rcpp::Named("gradient") = Rcpp::wrap(-grad));
}
double ung_ssm::bsf_filter(const unsigned int nsim, arma::cube& alpha,
arma::mat& weights, arma::umat& indices) {
arma::uvec nonzero = arma::find(P1.diag() > 0);
arma::mat L_P1(m, m, arma::fill::zeros);
if (nonzero.n_elem > 0) {
L_P1.submat(nonzero, nonzero) =
arma::chol(P1.submat(nonzero, nonzero), "lower");
}
std::normal_distribution<> normal(0.0, 1.0);
for (unsigned int i = 0; i < nsim; i++) {
arma::vec um(m);
for(unsigned int j = 0; j < m; j++) {
um(j) = normal(engine);
}
alpha.slice(i).col(0) = a1 + L_P1 * um;
}
std::uniform_real_distribution<> unif(0.0, 1.0);
arma::vec normalized_weights(nsim);
double loglik = 0.0;
if(arma::is_finite(y(0))) {
weights.col(0) = log_obs_density(0, alpha);
double max_weight = weights.col(0).max();
weights.col(0) = arma::exp(weights.col(0) - max_weight);
double sum_weights = arma::accu(weights.col(0));
if(sum_weights > 0.0){
normalized_weights = weights.col(0) / sum_weights;
} else {
return -std::numeric_limits<double>::infinity();
}
loglik = max_weight + std::log(sum_weights / nsim);
} else {
weights.col(0).ones();
normalized_weights.fill(1.0 / nsim);
}
for (unsigned int t = 0; t < n; t++) {
arma::vec r(nsim);
for (unsigned int i = 0; i < nsim; i++) {
r(i) = unif(engine);
}
indices.col(t) = stratified_sample(normalized_weights, r, nsim);
arma::mat alphatmp(m, nsim);
for (unsigned int i = 0; i < nsim; i++) {
alphatmp.col(i) = alpha.slice(indices(i, t)).col(t);
}
for (unsigned int i = 0; i < nsim; i++) {
arma::vec uk(k);
for(unsigned int j = 0; j < k; j++) {
uk(j) = normal(engine);
}
alpha.slice(i).col(t + 1) = C.col(t * Ctv) +
T.slice(t * Ttv) * alphatmp.col(i) + R.slice(t * Rtv) * uk;
}
if ((t < (n - 1)) && arma::is_finite(y(t + 1))) {
weights.col(t + 1) = log_obs_density(t + 1, alpha);
double max_weight = weights.col(t + 1).max();
weights.col(t + 1) = arma::exp(weights.col(t + 1) - max_weight);
double sum_weights = arma::accu(weights.col(t + 1));
if(sum_weights > 0.0){
normalized_weights = weights.col(t + 1) / sum_weights;
} else {
return -std::numeric_limits<double>::infinity();
}
loglik += max_weight + std::log(sum_weights / nsim);
} else {
weights.col(t + 1).ones();
normalized_weights.fill(1.0/nsim);
}
}
// constant part of the log-likelihood
switch(distribution) {
case 0 :
loglik += arma::uvec(arma::find_finite(y)).n_elem * norm_log_const(phi);
break;
case 1 : {
arma::uvec finite_y(find_finite(y));
loglik += poisson_log_const(y(finite_y), u(finite_y));
} break;
case 2 : {
arma::uvec finite_y(find_finite(y));
loglik += binomial_log_const(y(finite_y), u(finite_y));
} break;
case 3 : {
arma::uvec finite_y(find_finite(y));
loglik += negbin_log_const(y(finite_y), u(finite_y), phi);
} break;
}
return loglik;
}
//' Simulate an LNA path using a non-centered parameterization for the
//' log-transformed counting process LNA.
//'
//' @param lna_times vector of interval endpoint times
//' @param lna_draws vector of N(0,1) draws to be mapped to the path
//' @param lna_pars numeric matrix of parameters, constants, and time-varying
//' covariates at each of the lna_times
//' @param init_start index in the parameter vector where the initial compartment
//' volumes start
//' @param param_update_inds logical vector indicating at which of the times the
//' LNA parameters need to be updated.
//' @param stoich_matrix stoichiometry matrix giving the changes to compartments
//' from each reaction
//' @param forcing_inds logical vector of indicating at which times in the
//' time-varying covariance matrix a forcing is applied.
//' @param forcing_matrix matrix containing the forcings.
//' @param max_attempts maximum number of tries if the first increment is rejected
//' @param step_size initial step size for the ODE solver (adapted internally,
//' but too large of an initial step can lead to failure in stiff systems).
//' @param lna_pointer external pointer to the compiled LNA integration function.
//' @param set_pars_pointer external pointer to the function for setting LNA pars.
//' @return list containing the stochastic perturbations (i.i.d. N(0,1) draws) and
//' the LNA path on its natural scale which is determined by the perturbations.
//'
//' @export
// [[Rcpp::export]]
Rcpp::List propose_lna(const arma::rowvec& lna_times,
const Rcpp::NumericVector& lna_draws,
const Rcpp::NumericMatrix& lna_pars,
const Rcpp::IntegerVector& lna_param_inds,
const Rcpp::IntegerVector& lna_tcovar_inds,
const int init_start,
const Rcpp::LogicalVector& param_update_inds,
const arma::mat& stoich_matrix,
const Rcpp::LogicalVector& forcing_inds,
const arma::uvec& forcing_tcov_inds,
const arma::mat& forcings_out,
const arma::cube& forcing_transfers,
int max_attempts,
double step_size,
SEXP lna_pointer,
SEXP set_pars_pointer) {
// get the dimensions of various objects
int n_events = stoich_matrix.n_cols; // number of transition events, e.g., S2I, I2R
int n_comps = stoich_matrix.n_rows; // number of model compartments (all strata)
int n_odes = n_events + n_events*n_events; // number of ODEs
int n_times = lna_times.n_elem; // number of times at which the LNA must be evaluated
int n_tcovar = lna_tcovar_inds.size(); // number of time-varying covariates or parameters
int n_forcings = forcing_tcov_inds.n_elem; // number of forcings
// for use with forcings
double forcing_flow = 0;
arma::vec forcing_distvec(n_comps, arma::fill::zeros);
// initialize the objects used in each time interval
double t_L = 0;
double t_R = 0;
Rcpp::NumericVector current_params = lna_pars.row(0); // vector for storing the current parameter values
CALL_SET_ODE_PARAMS(current_params, set_pars_pointer); // set the parameters in the odeintr namespace
// initial state vector - copy elements from the current parameter vector
arma::vec init_volumes(current_params.begin() + init_start, n_comps);
// initialize the LNA objects - the vector for storing the current state
Rcpp::NumericVector lna_state_vec(n_odes); // vector to store the results of the ODEs
arma::vec lna_drift(n_events, arma::fill::zeros); // incidence mean vector (natural scale)
arma::mat lna_diffusion(n_events, n_events, arma::fill::zeros); // diffusion matrix
arma::vec log_lna(n_events, arma::fill::zeros); // LNA increment, log scale
arma::vec nat_lna(n_events, arma::fill::zeros); // LNA increment, natural scale
// Objects for computing the eigen decomposition of the LNA covariance matrices
arma::vec svd_d(n_events, arma::fill::zeros);
arma::mat svd_U(n_events, n_events, arma::fill::zeros);
arma::mat svd_V(n_events, n_events, arma::fill::zeros);
bool good_svd = true;
// matrix in which to store the LNA path
arma::mat lna_path(n_events+1, n_times, arma::fill::zeros); // incidence path
arma::mat prev_path(n_comps+1, n_times, arma::fill::zeros); // prevalence path (compartment volumes)
lna_path.row(0) = lna_times;
prev_path.row(0) = lna_times;
prev_path(arma::span(1,n_comps), 0) = init_volumes;
// apply forcings if called for - applied after censusing at the first time
if(forcing_inds[0]) {
// distribute the forcings proportionally to the compartment counts in the applicable states
for(int j=0; j < n_forcings; ++j) {
forcing_flow = lna_pars(0, forcing_tcov_inds[j]);
forcing_distvec = forcing_flow * normalise(forcings_out.col(j) % init_volumes, 1);
init_volumes += forcing_transfers.slice(j) * forcing_distvec;
}
}
// sample the stochastic perturbations - use Rcpp RNG for safety
Rcpp::NumericVector draws_rcpp(Rcpp::clone(lna_draws));
arma::mat draws(draws_rcpp.begin(), n_events, n_times-1, true);
// iterate over the time sequence, solving the LNA over each interval
for(int j=0; j < (n_times-1); ++j) {
// set the times of the interval endpoints
t_L = lna_times[j];
t_R = lna_times[j+1];
// Reset the LNA state vector and integrate the LNA ODEs over the next interval to 0
std::fill(lna_state_vec.begin(), lna_state_vec.end(), 0.0);
CALL_INTEGRATE_STEM_ODE(lna_state_vec, t_L, t_R, step_size, lna_pointer);
// transfer the elements of the lna_state_vec to the process objects
std::copy(lna_state_vec.begin(), lna_state_vec.begin() + n_events, lna_drift.begin());
std::copy(lna_state_vec.begin() + n_events, lna_state_vec.end(), lna_diffusion.begin());
// map the stochastic perturbation to the LNA path on its natural scale
try{
if(lna_drift.has_nan() || lna_diffusion.has_nan()) {
good_svd = false;
throw std::runtime_error("Integration failed.");
} else {
good_svd = arma::svd(svd_U, svd_d, svd_V, lna_diffusion); // compute the SVD
}
if(!good_svd) {
throw std::runtime_error("SVD failed.");
} else {
svd_d.elem(arma::find(svd_d < 0)).zeros(); // zero out negative sing. vals
svd_V.each_row() %= arma::sqrt(svd_d).t(); // multiply rows of V by sqrt(d)
svd_U *= svd_V.t(); // complete svd_sqrt
svd_U.elem(arma::find(lna_diffusion == 0)).zeros(); // zero out numerical errors
log_lna = lna_drift + svd_U * draws.col(j); // map the LNA draws
}
} catch(std::exception & err) {
// reinstatiate the SVD objects
arma::vec svd_d(n_events, arma::fill::zeros);
arma::mat svd_U(n_events, n_events, arma::fill::zeros);
arma::mat svd_V(n_events, n_events, arma::fill::zeros);
// forward the exception
forward_exception_to_r(err);
} catch(...) {
::Rf_error("c++ exception (unknown reason)");
}
// compute the LNA increment
nat_lna = arma::vec(expm1(Rcpp::NumericVector(log_lna.begin(), log_lna.end())));
// update the compartment volumes
init_volumes += stoich_matrix * nat_lna;
// throw errors for negative increments or negative volumes
try{
if(any(nat_lna < 0)) {
throw std::runtime_error("Negative increment.");
}
if(any(init_volumes < 0)) {
throw std::runtime_error("Negative compartment volumes.");
}
} catch(std::exception &err) {
forward_exception_to_r(err);
} catch(...) {
::Rf_error("c++ exception (unknown reason)");
}
// save the increment and the prevalence
lna_path(arma::span(1,n_events), j+1) = nat_lna;
prev_path(arma::span(1,n_comps), j+1) = init_volumes;
// apply forcings if called for - applied after censusing the path
if(forcing_inds[j+1]) {
// distribute the forcings proportionally to the compartment counts in the applicable states
for(int s=0; s < n_forcings; ++s) {
forcing_flow = lna_pars(j+1, forcing_tcov_inds[s]);
forcing_distvec = forcing_flow * normalise(forcings_out.col(s) % init_volumes, 1);
init_volumes += forcing_transfers.slice(s) * forcing_distvec;
}
// throw errors for negative negative volumes
try{
if(any(init_volumes < 0)) {
throw std::runtime_error("Negative compartment volumes.");
}
} catch(std::exception &err) {
forward_exception_to_r(err);
} catch(...) {
::Rf_error("c++ exception (unknown reason)");
}
}
// update the parameters if they need to be updated
if(param_update_inds[j+1]) {
// time-varying covariates and parameters
std::copy(lna_pars.row(j+1).end() - n_tcovar,
lna_pars.row(j+1).end(),
current_params.end() - n_tcovar);
}
// copy the compartment volumes to the current parameters
std::copy(init_volumes.begin(), init_volumes.end(), current_params.begin() + init_start);
// set the lna parameters and reset the LNA state vector
CALL_SET_ODE_PARAMS(current_params, set_pars_pointer);
}
// return the paths
return Rcpp::List::create(Rcpp::Named("draws") = draws,
Rcpp::Named("lna_path") = lna_path.t(),
Rcpp::Named("prev_path") = prev_path.t());
}
bool
mcmc::de_int(const arma::vec& initial_vals, arma::cube& draws_out, std::function<double (const arma::vec& vals_inp, void* target_data)> target_log_kernel, void* target_data, algo_settings_t* settings_inp)
{
bool success = false;
const size_t n_vals = initial_vals.n_elem;
//
// DE settings
algo_settings_t settings;
if (settings_inp) {
settings = *settings_inp;
}
const size_t n_pop = settings.de_n_pop;
const size_t n_gen = settings.de_n_gen;
const size_t n_burnin = settings.de_n_burnin;
const bool jumps = settings.de_jumps;
const double par_b = settings.de_par_b;
// const double par_gamma = settings.de_par_gamma;
const double par_gamma = 2.38 / std::sqrt(2.0*n_vals);
const double par_gamma_jump = settings.de_par_gamma_jump;
const arma::vec par_initial_lb = (settings.de_initial_lb.n_elem == n_vals) ? settings.de_initial_lb : initial_vals - 0.5;
const arma::vec par_initial_ub = (settings.de_initial_ub.n_elem == n_vals) ? settings.de_initial_ub : initial_vals + 0.5;
const bool vals_bound = settings.vals_bound;
const arma::vec lower_bounds = settings.lower_bounds;
const arma::vec upper_bounds = settings.upper_bounds;
const arma::uvec bounds_type = determine_bounds_type(vals_bound, n_vals, lower_bounds, upper_bounds);
// lambda function for box constraints
std::function<double (const arma::vec& vals_inp, void* box_data)> box_log_kernel \
= [target_log_kernel, vals_bound, bounds_type, lower_bounds, upper_bounds] (const arma::vec& vals_inp, void* target_data) \
-> double
{
if (vals_bound)
{
arma::vec vals_inv_trans = inv_transform(vals_inp, bounds_type, lower_bounds, upper_bounds);
return target_log_kernel(vals_inv_trans, target_data) + log_jacobian(vals_inp, bounds_type, lower_bounds, upper_bounds);
}
else
{
return target_log_kernel(vals_inp, target_data);
}
};
//
arma::vec target_vals(n_pop);
arma::mat X(n_pop,n_vals);
#ifdef MCMC_USE_OPENMP
#pragma omp parallel for
#endif
for (size_t i=0; i < n_pop; i++)
{
X.row(i) = par_initial_lb.t() + (par_initial_ub.t() - par_initial_lb.t())%arma::randu(1,n_vals);
double prop_kernel_val = box_log_kernel(X.row(i).t(),target_data);
if (!std::isfinite(prop_kernel_val)) {
prop_kernel_val = neginf;
}
target_vals(i) = prop_kernel_val;
}
//
// begin MCMC run
draws_out.set_size(n_pop,n_vals,n_gen);
int n_accept = 0;
double par_gamma_run = par_gamma;
for (size_t j=0; j < n_gen + n_burnin; j++)
{
double temperature_j = de_cooling_schedule(j,n_gen);
if (jumps && ((j+1) % 10 == 0)) {
par_gamma_run = par_gamma_jump;
}
#ifdef MCMC_USE_OPENMP
#pragma omp parallel for
#endif
for (size_t i=0; i < n_pop; i++) {
uint_t R_1, R_2;
do {
R_1 = arma::as_scalar(arma::randi(1, arma::distr_param(0, n_pop-1)));
} while(R_1==i);
do {
R_2 = arma::as_scalar(arma::randi(1, arma::distr_param(0, n_pop-1)));
} while(R_2==i || R_2==R_1);
//
arma::vec prop_rand = arma::randu(n_vals,1)*(2*par_b) - par_b; // generate a vector of U[-b,b] RVs
arma::rowvec X_prop = X.row(i) + par_gamma_run * ( X.row(R_1) - X.row(R_2) ) + prop_rand;
double prop_kernel_val = box_log_kernel(X_prop.t(),target_data);
if (!std::isfinite(prop_kernel_val)) {
prop_kernel_val = neginf;
}
//
double comp_val = prop_kernel_val - target_vals(i);
double z = arma::as_scalar(arma::randu(1,1));
if (comp_val > temperature_j * std::log(z)) {
X.row(i) = X_prop;
target_vals(i) = prop_kernel_val;
if (j >= n_burnin) {
n_accept++;
}
}
}
//
if (j >= n_burnin) {
draws_out.slice(j-n_burnin) = X;
}
if (jumps && ((j+1) % 10 == 0)) {
par_gamma_run = par_gamma;
}
}
success = true;
//
if (vals_bound) {
#ifdef MCMC_USE_OPENMP
#pragma omp parallel for
#endif
for (size_t ii = 0; ii < n_gen; ii++) {
for (size_t jj = 0; jj < n_pop; jj++) {
draws_out.slice(ii).row(jj) = arma::trans(inv_transform(draws_out.slice(ii).row(jj).t(), bounds_type, lower_bounds, upper_bounds));
}
}
}
if (settings_inp) {
settings_inp->de_accept_rate = static_cast<double>(n_accept) / static_cast<double>(n_pop*n_gen);
}
//
return success;
}