double
HMM::forwardProcedureCached() {
//initialisation
alpha_.col(0) = arma::trans(pi_ % B_.row(0));
c_(0) = arma::accu(alpha_.col(0));
alpha_.col(0) /= arma::as_scalar(c_(0));
//alpha_.print("alpha");
//c_.print("scale");
//iteration
for(unsigned int t = 1; t < T_; ++t) {
alpha_.col(t) = (A_.t() * alpha_.col(t-1)) % arma::trans(B_.row(t));
c_(t) = arma::accu(alpha_.col(t));
alpha_.col(t) /= arma::as_scalar(c_(t));
}
pprob_ = arma::accu(arma::log(c_));
return pprob_;
}
arma::vec dmvn_arma(arma::mat x,
arma::mat mean,
arma::mat sigma,
bool logd = false) {
int n = x.n_rows;
int xdim = x.n_cols;
arma::vec out(n);
arma::mat rooti = arma::trans(arma::inv(trimatu(arma::chol(sigma))));
double rootisum = arma::sum(log(rooti.diag()));
double constants = -(static_cast<double>(xdim)/2.0) * log2pi;
for (int i=0; i < n; i++) {
arma::vec z = rooti * arma::trans( x.row(i) - mean.row(i)) ;
out(i) = constants - 0.5 * arma::sum(z%z) + rootisum;
}
if (logd == false) {
out = exp(out);
}
return(out);
}
// [[Rcpp::export]]
arma::vec MCMCloglikelihoodNegBinomCpp_t(const arma::vec& beta, const arma::mat& sigma, double alpha, const arma::vec& sigmaType, const arma::mat& u,
const arma::vec& df, const arma::vec& kKi, const arma::vec& kLh, const arma::vec& kLhi, const arma::vec& kY, const arma::mat& kX, const arma::mat& kZ) {
int kM = u.n_rows; /** Number of MCMC samples */
arma::vec loglike(kM);
loglike.fill(0);
for (int i = 0; i < kM; i++) {
loglike(i) = loglikelihoodNegBinomCpp_t(beta, sigma, alpha, sigmaType, u.row(i).t(), df, kKi, kLh, kLhi, kY, kX, kZ);
}
return loglike;
}
// [[Rcpp::export]]
arma::vec MCMCloglikelihoodGammaCpp_n(const arma::vec& beta, const arma::mat& sigma, double alpha,
const arma::mat& u, const arma::vec& kY, const arma::mat& kX, const arma::mat& kZ) {
int kM = u.n_rows;
arma::vec loglike(kM);
loglike.fill(0);
for (int i = 0; i < kM; i++) {
loglike(i) = loglikelihoodGammaCpp_n(beta, sigma, alpha, u.row(i).t(), kY, kX, kZ);
}
return loglike;
}
// [[Rcpp::export]]
Rcpp::List CTCRWNLL(const arma::mat& y, const arma::mat& Hmat,
const arma::vec& beta, const arma::vec& sig2, const arma::vec& delta,
const arma::vec& noObs,const arma::vec& active, const arma::colvec& a,
const arma::mat& P)
{
// Define fixed matrices
int N = y.n_rows;
double detF;
arma::mat Z(2,4, fill::zeros);
Z(0,0) = 1; Z(1,2) = 1;
arma::mat T(4,4);
arma::mat Q(4,4);
arma::mat F(2,2, fill::zeros);
arma::mat H(2,2, fill::zeros);
arma::mat K(4,2, fill::zeros);
arma::mat L(4,4, fill::zeros);
arma::colvec v(2, fill::zeros);
arma::colvec aest(4);
aest=a;
arma::mat Pest(4,4);
Pest=P;
double ll=0;
//Begin Kalman filter
for(int i=0; i<N; i++){
T = makeT(beta(i), delta(i), active(i));
Q = makeQ(beta(i), sig2(i), delta(i), active(i));
// prediction
if(noObs(i)==1){
aest = T*aest;
Pest = T*Pest*T.t() + Q;
} else {
H(0,0) = Hmat(i,0);
H(1,1) = Hmat(i,1);
H(0,1) = Hmat(i,2);
H(1,0) = Hmat(i,2);
v = y.row(i).t()-Z*aest;
F = Z*Pest*Z.t() + H;
detF = F(0,0)*F(1,1) - F(1,0)*F(0,1);
if(detF<=0){
aest = T*aest;
Pest = T*Pest*T.t() + Q;
} else{
ll += - (log(detF) + dot(v,solve(F,v)))/2;
// K = T*Pest*Z.t()*inv_sympd(F);
K = T*Pest*Z.t()*F.i();
L = T - K*Z;
aest = T*aest + K*v;
Pest = T*Pest*L.t() + Q;
}
}
}
return Rcpp::List::create(Rcpp::Named("ll") = ll);
}
void GMM::sample(arma::mat& X){
std::size_t k;
arma::vec tmp;
dist = boost::random::discrete_distribution<>(pi);
for(std::size_t i = 0; i < X.n_rows;i++){
k = dist(generator);
A[k]*arma::randn<arma::vec>(D);
tmp = Means[k] + A[k]*arma::randn<arma::vec>(D);
X.row(i) = tmp.st();
}
}
List FFBS(const arma::mat& allprobs, const arma::vec& delta,
const arma::mat& mGamma, const int& K, const int& T) {
arma::mat lalpha = zeros(K, T);
arma::mat lbeta = zeros(K, T);
arma::vec foo(K);
double sumfoo, lscale;
int i;
foo = delta % allprobs.row(0).t();
sumfoo = sum(foo);
lscale = log(sumfoo);
foo = foo / sumfoo;
lalpha.col(0) = log(foo) + lscale;
for (i = 1; i < T; i++) {
foo = (foo.t() * mGamma).t() % allprobs.row(i).t();
sumfoo = sum(foo);
lscale = lscale + log(sumfoo);
foo = foo / sumfoo;
lalpha.col(i) = log(foo) + lscale;
}
for (i = 0; i < K; i++) {
foo(i) = 1.0 / K;
}
lscale = log((double)K);
for (i = T - 2; i >= 0; i--) {
foo = mGamma * (allprobs.row(i + 1).t() % foo);
lbeta.col(i) = log(foo) + lscale;
sumfoo = sum(foo);
foo = foo / sumfoo;
lscale = lscale + log(sumfoo);
}
List FS;
FS["lalpha"] = lalpha;
FS["lbeta"] = lbeta;
return FS;
}
// [[Rcpp::export]]
arma::mat gillespie_next(arma::vec theta, arma::vec init_state, arma::mat trans, LogicalMatrix depend, int t_end, bool info = false){
int n_event = trans.n_rows;
int j_event;
Progress p(0, false); //progress to check for user interrupt
//initialize trace of Monte Carlo simulation
arma::mat trace = arma::zeros(1,init_state.n_elem);
trace.row(0) = init_state.t();
arma::vec current_state;
arma::vec current_rates;
//main simulation loop
double time = 0.0;
int i = 1;
while(time <= t_end){
//check for user abort
if(Progress::check_abort()){
Rcout << "User abort detected at time: " << time << ", i: " << i << std::endl;
return(arma::zeros(2,2));
}
if(info){ //print simulation details
Rcout << "time: " << time << ", i: " << i << std::endl;
}
current_state = trace.row(i-1).t(); //extract state at beginning of time jump
if(i == 1){
current_rates = rate_wrapper(theta,current_state,seirs_demography_rate); //calculate initial rates
} else {
current_rates = update_rates_seirs_demography(theta,current_rates,current_state,depend,j_event); //update rates based on dependency graph
}
arma::vec tau(n_event); //calculate vector of times to next event
for(int j=0; j<n_event; j++){
tau(j) = (-1 / current_rates(j)) * log(R::runif(0,1));
}
j_event = tau.index_min(); //fire j_event
current_state = current_state + trans.row(j_event).t(); //update the current state
trace.insert_rows(i,current_state.t());
time = time + tau(j_event); //update time
i++; //update iterator
}
return(trace);
}
inline void SVDIncompleteIncrementalLearning::
HUpdate<arma::sp_mat>(const arma::sp_mat& V,
const arma::mat& W,
arma::mat& H)
{
arma::mat deltaH(H.n_rows, 1);
deltaH.zeros();
for(arma::sp_mat::const_iterator it = V.begin_col(currentUserIndex);
it != V.end_col(currentUserIndex);it++)
{
double val = *it;
size_t i = it.row();
if((val = V(i, currentUserIndex)) != 0)
deltaH += (val - arma::dot(W.row(i), H.col(currentUserIndex))) *
arma::trans(W.row(i));
}
if(kh != 0) deltaH -= kh * H.col(currentUserIndex);
H.col(currentUserIndex++) += u * deltaH;
currentUserIndex = currentUserIndex % m;
}
arma::mat hCoef(const arma::mat& weights, const arma::mat& X) {
int p = X.n_cols;
arma::mat hess(p * (weights.n_rows - 1), p * (weights.n_rows - 1), arma::fill::zeros);
for (unsigned int i = 0; i < X.n_rows; i++) {
arma::mat XX = X.row(i).t() * X.row(i);
for (unsigned int j = 0; j < (weights.n_rows - 1); j++) {
for (unsigned int k = 0; k < (weights.n_rows - 1); k++) {
if (j != k) {
hess.submat(j * p, k * p, (j + 1) * p - 1, (k + 1) * p - 1) += XX * weights(j + 1, i)
* weights(k + 1, i);
} else {
hess.submat(j * p, j * p, (j + 1) * p - 1, (j + 1) * p - 1) -= XX * weights(j + 1, i)
* (1.0 - weights(j + 1, i));
}
}
}
}
return hess;
}
//--------------------------------------------------------------------------------------------------
List variogram( const arma::mat& Z,
const arma::mat& X,
Function d ) {
int i, j, k;
int n = X.n_rows;
int N = n * ( n + 1 ) / 2;
std::vector< int > I( N );
arma::rowvec x, y;
arma::colvec V( N );
arma::colvec D( N );
arma::colvec S( N );
List Varg;
for ( i = 0; i < N; i++ ) {
I[i] = i;
}
k = 0;
for ( i = 0; i < n; i++ ) {
for ( j = i; j < n; j++ ) {
x = X.row( i );
y = X.row( j );
D(k) = as<double>( d( x, y ) );
S(k) = ( Z(i,0) - Z(j,0) ) * ( Z(i,0) - Z(j,0) );
k++;
}
}
sort( I.begin(), I.end(),
[&]( const int& k, const int& l ) {
return ( D(k) < D(l) );
}
);
V( 0 ) = S( I[0] );
for ( k = 1; k < N; k++ ) {
V( k ) = ( V( k - 1 ) * k + S( I[ k ] ) ) / ( k + 1.0 );
}
V = 0.5 * V;
Varg[ "variogram" ] = V;
Varg[ "distance" ] = D;
Varg[ "sort" ] = I;
return Varg;
}
RegularizedSVDFunction::RegularizedSVDFunction(const arma::mat& data,
const size_t rank,
const double lambda) :
data(data),
rank(rank),
lambda(lambda)
{
// Number of users and items in the data.
numUsers = max(data.row(0)) + 1;
numItems = max(data.row(1)) + 1;
// Initialize the parameters.
initialPoint.randu(rank, numUsers + numItems);
}
// [[Rcpp::export]]
arma::mat gillespie_direct(arma::vec theta, arma::vec init_state, arma::mat trans, int t_end, bool info = false){
Progress p(0, false); //progress to check for user interrupt
//initialize trace of Monte Carlo simulation
arma::mat trace = arma::zeros(1,init_state.n_elem);
trace.row(0) = init_state.t();
arma::vec current_state;
//main simulation loop
double time = 0.0;
int i = 1;
while(time <= t_end){
//check for user abort
if(Progress::check_abort()){
Rcout << "User abort detected at time: " << time << ", i: " << i << std::endl;
return(arma::zeros(2,2));
}
if(info){ //print simulation details
Rcout << "time: " << time << ", i: " << i << std::endl;
}
current_state = trace.row(i-1).t(); //extract state at beginning of time jump
arma::vec current_rates = rate_wrapper(theta,current_state,sir_rate); //calculate current rates
double w0 = sum(current_rates); //sum of rate (propensity) functions
double tau = 1/w0 * log(1/R::runif(0,1)); //calculate time to next reaction
double r_num = R::runif(0,1);
double w0_rxn = r_num * w0; //instantaneous event probabilities
//decide which event j occured
int j = 0;
while(sum(current_rates.subvec(0,j)) < w0_rxn){
j++;
}
current_state = current_state + trans.row(j).t(); //update the current state
trace.insert_rows(i,current_state.t());
time = time + tau; //update time
i++; //update iterator
}
return(trace);
}
arma::uvec generate_categoricals(arma::uvec zlabels, arma::mat probs) {
int ndata = zlabels.n_elem;
int nclusters = probs.n_rows;
std::vector<boost::random::discrete_distribution<> > cat_dists;
for (int k=0; k<nclusters; k++) {
std::vector<double> probs_k = arma::conv_to<std::vector<double> >::from(probs.row(k));
cat_dists.push_back(boost::random::discrete_distribution<> (probs_k.begin(), probs_k.end()));
}
arma::uvec categories(ndata);
for (int i=0; i<ndata; i++) {
categories(i) = cat_dists[zlabels(i)](rng);
}
return categories;
}
// [[Rcpp::export]]
arma::mat gillespie_first(arma::vec theta, arma::vec init_state, arma::mat trans, int t_end, bool info = false){
int n_event = trans.n_rows;
Progress p(0, false); //progress to check for user interrupt
//initialize trace of Monte Carlo simulation
arma::mat trace = arma::zeros(1,init_state.n_elem);
trace.row(0) = init_state.t();
arma::vec current_state;
//main simulation loop
double time = 0.0;
int i = 1;
while(time <= t_end){
//check for user abort
if(Progress::check_abort()){
Rcout << "User abort detected at time: " << time << ", i: " << i << std::endl;
return(arma::zeros(2,2));
}
if(info){ //print simulation details
Rcout << "time: " << time << ", i: " << i << std::endl;
}
current_state = trace.row(i-1).t(); //extract state at beginning of time jump
arma::vec current_rates = rate_wrapper(theta,current_state,sir_rate); //calculate current rates
arma::vec rand; //create vector of U[0,1]
rand = as<arma::vec>(runif(n_event));
arma::vec tau(n_event); //calculate vector of times to next event
for(int j=0; j<n_event; j++){
tau(j) = (-1 / current_rates(j)) * log(rand(j));
}
int first_rxn = tau.index_min(); //which even occurs first
current_state = current_state + trans.row(first_rxn).t(); //update the current state
trace.insert_rows(i,current_state.t());
time = time + tau(first_rxn); //update time
i++; //update iterator
}
return(trace);
}
void
HMM::backwardProcedureCached() {
beta_.col(T_-1).fill(1./c_(T_-1));
//temporary probabilities
arma::vec b(N_);
//iteration
for(unsigned int t = T_-1; t > 0; --t) {
beta_.col(t-1) = A_ * (arma::trans(B_.row(t)) % beta_.col(t));
beta_.col(t-1) /= arma::as_scalar(c_(t-1));
}
}
void sampleSparseLoadingsJ(arma::mat& Z, arma::mat& A, arma::mat& F, Rcpp::NumericVector& tauinv,
Rcpp::NumericVector& sigma2inv, Rcpp::NumericVector& error_var_i,
Rcpp::NumericVector& rho, arma::mat& A_restrict, Rcpp::NumericMatrix& pnz,
int n, int p, int k, int px, double A_prior_var ){
arma::mat t, uvector, Ap_var, Ap_means, FFt;
arma::vec sumf2 = arma::sum(arma::pow(F, 2), 1);
double r = 1.0, samp = 0.0;
if (px>0) {
FFt = F*arma::trans(F);
/*Ap_var = arma::inv(FFt + (1/A_prior_var)*arma::eye(k,k));
Ap_means = Ap_var*F*trans(Z);*/
}
double u=0.0, uu=0.0, v=0.0, loglog=0.0, logc=0.0;
for (int i=0; i<p; i++) {
//PX step
if (px>0 && error_var_i(i)<1.0) {
Ap_var = inv(FFt*sigma2inv(i) + (1/A_prior_var)*eye(k,k));
Ap_means = Ap_var*F*trans(Z.row(i))*sigma2inv(i);
double ssq = accu(square(trans(Z.row(i)) - trans(F)*Ap_means));
double prior_ssq = as_scalar(trans(Ap_means) * Ap_means)/A_prior_var;
double scale = 2.0/(ssq + prior_ssq);
r = Rf_rgamma(0.5*n, scale);
} else {
r = 1.0;
}
for (int j=0; j<k; j++){
if (A_restrict(i,j) > 0) { //nonzero
t = Z.row(i) - A.row(i)*F + A(i,j)*F.row(j);
u = arma::accu(F.row(j)%t)*sqrt(r)*sigma2inv(j);
v = sumf2(j)*sigma2inv(j) + tauinv[i];
if (A_restrict(i,j) > 1) { //strictly positive
double lo = Rcpp::stats::pnorm_1( -u/sqrt(v), 0.0, true, false);
double un = std::min(Rf_runif(lo, 1.0), 1.0-6.7e-16);
double samp = u/v + Rcpp::stats::qnorm_1(un, 0.0, true, false)/sqrt(v);
A(i,j) = samp;
} else {
loglog = log(u*u) - log(2.0*v);
logc = log(rho[j]) - log(1-rho[j]) - 0.5*log(v) + 0.5*log(tauinv[i]) + exp(loglog);
pnz(i,j) = 1/(1+exp(logc));
uu = Rf_runif(0.0, 1.0);
log(1/uu-1) > logc ? A(i,j) = 0.0 : A(i,j) = Rf_rnorm(u/v, 1/sqrt(v));
}
} else {
A(i,j) = 0.0;
pnz(i,j) = 1.0;
}
}
}
}
void Clustering::multiple_components(GMM& gmm, const arma::mat& data){
/* data.print("data");
std::cout<< "K: " << K << std::endl;
std::cout<< "centroids: " << centroids.n_rows << " x " << centroids.n_cols << std::endl;
*/
covariances.resize(K);
means.resize(K);
pi.resize(K);
arma::vec x;
std::size_t k;
// set to zero
for(k = 0; k < K;k++){
means[k] = centroids.col(k);
covariances[k].zeros(3,3);
pi(k) = 0;//std::numeric_limits<double>::min();
}
for(std::size_t r = 0; r < data.n_rows;r++){
k = assignments(r);
x = data.row(r).st();
covariances[k] = covariances[k] + (x - means[k]) * (x - means[k]).st() ;
pi(k) = pi(k) + 1;
}
for(k = 0; k < K;k++){
covariances[k] = (covariances[k])/pi(k);
covariances[k] = covariances[k] + I;
covariances[k] = 0.5*(covariances[k] + covariances[k].st());
pi(k) = pi(k) + std::numeric_limits<double>::min();
}
pi = pi / arma::sum(pi);
/* pi.print("pi");
for(std::size_t i = 0; i < covariances.size();i++){
covariances[i].print("cov(" + boost::lexical_cast<std::string>(i) + ")");
}
*/
//gmm.setParam(pi,means,covariances);
}
void Box_sensor_likelihood::update(double* L, const arma::colvec& Y,const arma::colvec3& F, const arma::mat& points,const arma::mat33& Rot)
{
tf::Matrix3x3 R_tmp;
tf::Vector3 T_tmp;
opti_rviz::type_conv::mat2tf(Rot,R_tmp);
for(std::size_t p = 0; p < points.n_rows;p++){
opti_rviz::type_conv::vec2tf(points.row(p).st(),T_tmp);
peg_sensor_model.update_model(T_tmp,R_tmp);
const std::vector<tf::Vector3>& model = peg_sensor_model.get_model();
std::size_t i = 0;
// iterate over the three pegs (in frame of reference of peg_link)
for(; i < model.size();i++)
{
tmp_vec3f(0) = model[i][0];
tmp_vec3f(1) = model[i][1];
tmp_vec3f(2) = model[i][2];
// check if is in a box
}
}
}
void Clustering::compute_mixture_model(GMM& gmm, const arma::mat& data, const arma::vec& w){
covariances.resize(K);
means.resize(K);
pi.resize(K);
std::size_t k;
// set to zero
for(k = 0; k < K;k++){
means[k].zeros(3);
covariances[k].zeros(3,3);
}
for(std::size_t r = 0; r < data.n_rows;r++){
k = assignments(r);
means[k] = means[k] + data.row(r).st();
N(k) = N(k) + 1;
pi[k] = pi[k] + w(r);
}
}
void RegularizedSVD<OptimizerType>::Apply(const arma::mat& data,
const size_t rank,
arma::mat& u,
arma::mat& v)
{
// Make the optimizer object using a RegularizedSVDFunction object.
RegularizedSVDFunction<arma::mat> rSVDFunc(data, rank, lambda);
mlpack::optimization::StandardSGD optimizer(alpha, iterations * data.n_cols);
// Get optimized parameters.
arma::mat parameters = rSVDFunc.GetInitialPoint();
optimizer.Optimize(rSVDFunc, parameters);
// Constants for extracting user and item matrices.
const size_t numUsers = max(data.row(0)) + 1;
const size_t numItems = max(data.row(1)) + 1;
// Extract user and item matrices from the optimized parameters.
u = parameters.submat(0, numUsers, rank - 1, numUsers + numItems - 1).t();
v = parameters.submat(0, 0, rank - 1, numUsers - 1);
}
void
HMM::backwardProcedure(const arma::mat & data) {
beta_.col(T_-1).fill(1./c_(T_-1));
//temporary probabilities
arma::vec b(N_);
//iteration
for(unsigned int t = T_-1; t > 0; --t) {
for (unsigned int j = 0; j < N_; ++j) {
b(j) = BModels_[j].getProb(data.col(t));
}
for (unsigned int i = 0; i < N_; ++i) {
beta_(i,t-1) = arma::as_scalar(A_.row(i) * (b % beta_.col(t)));
}
beta_.col(t-1) /= arma::as_scalar(c_(t-1));
}
}
// // [[Rcpp::export()]]
arma::mat getEystar(const arma::mat &alpha,
const arma::mat &beta,
const arma::mat &x,
const arma::mat &y,
const int D,
const int N,
const int J
) {
arma::mat ystars(N, J, arma::fill::zeros) ;
// Main Calculation
#pragma omp parallel for
for (int n = 0; n < N; n++) {
arma::mat thisx = x.row(n) ;
arma::mat theseystars = arma::mat(1, J, arma::fill::zeros) ;
for (int j = 0; j < J; j++) {
double q1 = 0.0 ;
q1 += alpha(j, 0) ;
for (int d = 0; d < D; d++) {
q1 += thisx(0, d) * beta(j, d) ;
}
// defaults to untruncated
double low = y(n,j) == 1 ? 0.0 : R_NegInf ;
double high = y(n,j) == -1 ? 0.0 : R_PosInf ;
// Rcout << n << ':' << j << std::endl ;
// Rcout << q1 << " " << low << " " << high << std::endl ;
// theseystars(0, j) = RcppTN::etn1(q1, 1.0, low, high) ;
theseystars(0, j) = etn1(q1, 1.0, low, high) ;
}
ystars.row(n) = theseystars ;
}
return(ystars) ;
}
// [[Rcpp::export]]
arma::rowvec HnCpp(arma::mat Qs){
//Compute the Hn tests statistics
int n = Qs.n_rows, i=0;
arma::mat T = Qs.t()*Qs;
arma::mat eigvec, eigvecJ;
arma::vec eigval, eigvalJ;
arma::eig_sym(eigval,eigvec,T);
arma::rowvec Hn(n);
arma::rowvec Qj;
arma::mat Tj;
for(i = 0;i<n; i++){
Qj = Qs.row(i);
Tj = T-Qj.t()*Qj;
arma::eig_sym(eigvalJ,eigvecJ,Tj);
Hn(i)=(n-2)*(1+eigvalJ(3)-eigval(3))/(n-1-eigvalJ(3));
}
return Hn;
}
arma::mat MinimizerBase::runTracks(const arma::mat& params, const arma::mat& expPos, const arma::vec& expHits) const
{
arma::mat chis (params.n_rows, 3);
#pragma omp parallel for schedule(static) shared(chis)
for (unsigned j = 0; j < params.n_rows; j++) {
arma::vec p = arma::conv_to<arma::colvec>::from(params.row(j));
try {
auto chiset = runTrack(p, expPos, expHits);
chis(j, 0) = chiset.posChi2;
chis(j, 1) = chiset.enChi2;
chis(j, 2) = chiset.vertChi2;
}
catch (...) {
chis(j, 0) = arma::datum::nan;
chis(j, 1) = arma::datum::nan;
chis(j, 2) = arma::datum::nan;
}
}
return chis;
}
// [[Rcpp::export]]
arma::mat GENEapply(const arma::mat& geno, List Y, const arma::vec Eps, const arma::vec Tau, const arma::vec k, const arma::mat& R, bool display_progress=true){
int ngenes = Y.size();
int nsnps = geno.n_rows;
arma::mat GENEout_pval(ngenes,nsnps);
arma::vec SNPout_pval(nsnps);
arma::rowvec snp(R.n_rows);
Progress p(ngenes, display_progress);
for(int i =0; i<ngenes; i++){
Rcpp::checkUserInterrupt();
p.increment();
arma::mat Ymat = Y(i);
double est_eps = Eps(i);
double est_tau = Tau(i);
for(int j=0; j<nsnps; j++){
Rcpp::checkUserInterrupt();
SNPout_pval(j) = jag_fun(est_eps,est_tau,k,Ymat,vectorise(geno.row(j)),R);
}
GENEout_pval.row(i) = vectorise(SNPout_pval,1);
}
return GENEout_pval;
}
// [[Rcpp::export]]
List real_cont(
arma::mat coeffs_cont, arma::mat X, int n_exog, int n_endog,
int n_cont, arma::rowvec rho, arma::rowvec sig_eps, int N,
arma::rowvec upper, arma::rowvec lower, bool cheby, int seed=222 ){
// Computes a matrix of realized next-period controls from a simulation
int n_pts = X.n_rows ;
// The number of points at which the error is assessed
mat exog = zeros<rowvec>( n_exog ) ;
mat endog = zeros<rowvec>( n_endog ) ;
mat cont_sim = zeros( n_pts, n_cont ) ;
// Temporary containers used in the loop. Make cont bigger than size 0
// here - just passing a useless empty container
arma_rng::set_seed(seed) ;
// Set the seed
mat exog_sim = ( ones( n_pts ) * rho ) % X.cols( 0, n_exog - 1 ) +
( ones( n_pts ) * sig_eps ) % randn<mat>( n_pts, n_exog ) ;
// The random draws
/** Now compute the model errors **/
for( int i = 0 ; i < n_pts ; i++ ){
// Loop over the evaluation points
exog = exog_sim.row(i) ;
// The updated exogenous variable in the next period
endog = X.row(i).subvec( n_exog, n_exog + n_endog - 1 ) ;
// Select the current-period endogenous states
cont_sim.row(i) = endog_update( exog, endog, coeffs_cont, n_exog, n_endog, N,
upper, lower, cheby ) ;
// The integral over realizations of the shock
}
List out ;
out["r.exog"] = exog_sim ;
out["r.cont"] = cont_sim ;
// Create the output list
return out ;
}
arma::mat rcd(arma::mat design, int v, int model) {
if (model==8) { // "Second-order carry-over effects"
mat rcDesign = design;
for (unsigned i=1; i<rcDesign.n_rows; i++) {
if (i!=1) {
rcDesign.row(i) = design.row(i)+design.row(i-1)*v+design.row(i-2)*v*v;
} else {
rcDesign.row(i) = design.row(i)+design.row(i-1)*v;
}
}
return rcDesign;
} else if (model>0 && model<8) {
mat rcDesign = design;
for (unsigned i=1; i<rcDesign.n_rows; i++) {
rcDesign.row(i) = design.row(i)+design.row(i-1)*v;
}
return rcDesign;
} else if (model==9) {
return design;
}
throw std::range_error("Model not found. Has to be between 1 and 9.");
return NULL;
}
// Dictionary step for optimization.
double SparseCoding::OptimizeDictionary(const arma::mat& data,
const arma::mat& codes,
const arma::uvec& adjacencies)
{
// Count the number of atomic neighbors for each point x^i.
arma::uvec neighborCounts = arma::zeros<arma::uvec>(data.n_cols, 1);
if (adjacencies.n_elem > 0)
{
// This gets the column index. Intentional integer division.
size_t curPointInd = (size_t) (adjacencies(0) / atoms);
size_t nextColIndex = (curPointInd + 1) * atoms;
for (size_t l = 1; l < adjacencies.n_elem; ++l)
{
// If l no longer refers to an element in this column, advance the column
// number accordingly.
if (adjacencies(l) >= nextColIndex)
{
curPointInd = (size_t) (adjacencies(l) / atoms);
nextColIndex = (curPointInd + 1) * atoms;
}
++neighborCounts(curPointInd);
}
}
// Handle the case of inactive atoms (atoms not used in the given coding).
std::vector<size_t> inactiveAtoms;
for (size_t j = 0; j < atoms; ++j)
{
if (arma::accu(codes.row(j) != 0) == 0)
inactiveAtoms.push_back(j);
}
const size_t nInactiveAtoms = inactiveAtoms.size();
const size_t nActiveAtoms = atoms - nInactiveAtoms;
// Efficient construction of Z restricted to active atoms.
arma::mat matActiveZ;
if (nInactiveAtoms > 0)
{
math::RemoveRows(codes, inactiveAtoms, matActiveZ);
}
if (nInactiveAtoms > 0)
{
Log::Warn << "There are " << nInactiveAtoms
<< " inactive atoms. They will be re-initialized randomly.\n";
}
Log::Debug << "Solving Dual via Newton's Method.\n";
// Solve using Newton's method in the dual - note that the final dot
// multiplication with inv(A) seems to be unavoidable. Although more
// expensive, the code written this way (we use solve()) should be more
// numerically stable than just using inv(A) for everything.
arma::vec dualVars = arma::zeros<arma::vec>(nActiveAtoms);
//vec dualVars = 1e-14 * ones<vec>(nActiveAtoms);
// Method used by feature sign code - fails miserably here. Perhaps the
// MATLAB optimizer fmincon does something clever?
//vec dualVars = 10.0 * randu(nActiveAtoms, 1);
//vec dualVars = diagvec(solve(dictionary, data * trans(codes))
// - codes * trans(codes));
//for (size_t i = 0; i < dualVars.n_elem; i++)
// if (dualVars(i) < 0)
// dualVars(i) = 0;
bool converged = false;
// If we have any inactive atoms, we must construct these differently.
arma::mat codesXT;
arma::mat codesZT;
if (inactiveAtoms.empty())
{
codesXT = codes * trans(data);
codesZT = codes * trans(codes);
}
else
{
codesXT = matActiveZ * trans(data);
codesZT = matActiveZ * trans(matActiveZ);
}
double normGradient = 0;
double improvement = 0;
for (size_t t = 1; (t != maxIterations) && !converged; ++t)
{
arma::mat A = codesZT + diagmat(dualVars);
arma::mat matAInvZXT = solve(A, codesXT);
arma::vec gradient = -arma::sum(arma::square(matAInvZXT), 1);
gradient += 1;
arma::mat hessian = -(-2 * (matAInvZXT * trans(matAInvZXT)) % inv(A));
arma::vec searchDirection = -solve(hessian, gradient);
//printf("%e\n", norm(searchDirection, 2));
// Armijo line search.
const double c = 1e-4;
double alpha = 1.0;
const double rho = 0.9;
double sufficientDecrease = c * dot(gradient, searchDirection);
// A maxIterations parameter for the Armijo line search may be a good idea,
// but it doesn't seem to be causing any problems for now.
while (true)
{
// Calculate objective.
double sumDualVars = arma::sum(dualVars);
double fOld = -(-trace(trans(codesXT) * matAInvZXT) - sumDualVars);
double fNew = -(-trace(trans(codesXT) * solve(codesZT +
diagmat(dualVars + alpha * searchDirection), codesXT)) -
(sumDualVars + alpha * arma::sum(searchDirection)));
if (fNew <= fOld + alpha * sufficientDecrease)
{
searchDirection = alpha * searchDirection;
improvement = fOld - fNew;
break;
}
alpha *= rho;
}
// Take step and print useful information.
dualVars += searchDirection;
normGradient = arma::norm(gradient, 2);
Log::Debug << "Newton Method iteration " << t << ":" << std::endl;
Log::Debug << " Gradient norm: " << std::scientific << normGradient
<< "." << std::endl;
Log::Debug << " Improvement: " << std::scientific << improvement << ".\n";
if (normGradient < newtonTolerance)
converged = true;
}
if (inactiveAtoms.empty())
{
// Directly update dictionary.
dictionary = trans(solve(codesZT + diagmat(dualVars), codesXT));
}
else
{
arma::mat activeDictionary = trans(solve(codesZT +
diagmat(dualVars), codesXT));
// Update all atoms.
size_t currentInactiveIndex = 0;
for (size_t i = 0; i < atoms; ++i)
{
if (inactiveAtoms[currentInactiveIndex] == i)
{
// This atom is inactive. Reinitialize it randomly.
dictionary.col(i) = (data.col(math::RandInt(data.n_cols)) +
data.col(math::RandInt(data.n_cols)) +
data.col(math::RandInt(data.n_cols)));
dictionary.col(i) /= arma::norm(dictionary.col(i), 2);
// Increment inactive index counter.
++currentInactiveIndex;
}
else
{
// Update estimate.
dictionary.col(i) = activeDictionary.col(i - currentInactiveIndex);
}
}
}
return normGradient;
}
//' @title Approximation of the tpd of the MWN-OU process in 2D
//'
//' @description Computation of the transition probability density (tpd) for a MWN-OU diffusion (with diagonal diffusion matrix)
//'
//' @param x a matrix of dimension \code{c(n, 2)} containing angles. They all must be in \eqn{[\pi,\pi)} so that the truncated wrapping by \code{maxK} windings is able to capture periodicity.
//' @param x0 a matrix of of dimension \code{c(n, 2)} containing the starting angles. They all must be in \eqn{[\pi,\pi)}.
//' @param t either a scalar or a vector of length \code{n} containing the times separating \code{x} and \code{x0}. If \code{t} is a scalar, a common time is assumed.
//' @param alpha vector of length \code{3} parametrizing the \code{A} matrix of the drift of the MWN-OU process in the following codification:
//'
//' \code{A = rbind(c(alpha[1], alpha[3] * sqrt(sigma[1] / sigma[2])),
//' c(alpha[3] * sqrt(sigma[2] / sigma[1]), alpha[2]))}.
//'
//' This enforces that \code{solve(A) \%*\% diag(sigma)} is symmetric. Positive definiteness is guaranteed if \code{alpha[1] * alpha[2] > alpha[3]^2}.
//' The function checks for it and, if violated, resets \code{A} such that \code{solve(A) \%*\% diag(sigma)} is positive definite.
//' @param mu a vector of length \code{2} with the mean parameter of the MWN-OU process.
//' @param sigma vector of length \code{2} containing the \strong{square root} of the diagonal of \eqn{\Sigma}, the diffusion matrix.
//' @param maxK maximum number of winding number considered in the computation of the approximated transition probability density.
//' @inheritParams safeSoftMax
//' @return A vector of size \code{n} containing the tpd evaluated at \code{x}.
//' @author Eduardo Garcia-Portugues (\email{egarcia@@math.ku.dk})
//' @examples
//' set.seed(345567)
//' alpha <- c(2, 1, -1)
//' sigma <- c(1.5, 2)
//' Sigma <- diag(sigma^2)
//' A <- alphaToA(alpha = alpha, sigma = sigma)
//' mu <- c(pi, pi)
//' x <- t(eulerWn2D(x0 = matrix(c(0, 0), nrow = 1), A = A, mu = mu,
//' sigma = sigma, N = 500, delta = 0.1)[1, , ])
//' sum(sapply(1:49, function(i) log(dTpdMwou(x = matrix(x[i + 1, ], ncol = 2),
//' x0 = x[i, ], t = 1.5, A = A,
//' Sigma = Sigma, mu = mu, K = 2,
//' N.int = 2000))))
//' sum(log(dTpdWnOu2D(x = matrix(x[2:50, ], ncol = 2),
//' x0 = matrix(x[1:49, ], ncol = 2), t = 1.5, alpha = alpha,
//' mu = mu, sigma = sigma)))
//' \dontrun{
//' lgrid <- 56
//' grid <- seq(-pi, pi, l = lgrid + 1)[-(lgrid + 1)]
//' image(grid, grid, matrix(dTpdMwou(x = as.matrix(expand.grid(grid, grid)),
//' x0 = c(0, 0), t = 0.5, A = A, Sigma = Sigma,
//' mu = mu, K = 2, N.int = 2000),
//' nrow = 56, ncol = 56), zlim = c(0, 0.25),
//' main = "dTpdMwou")
//' image(grid, grid, matrix(dTpdWnOu2D(x = as.matrix(expand.grid(grid, grid)),
//' x0 = matrix(0, nrow = 56^2, ncol = 2),
//' t = 0.5, alpha = alpha, sigma = sigma,
//' mu = mu),
//' nrow = 56, ncol = 56), zlim = c(0, 0.25),
//' main = "dTpdWnOu2D")
//'
//' dr <- driftWn2D(x = as.matrix(expand.grid(grid, grid)), A = A, mu = mu,
//' sigma = sigma, maxK = 2, etrunc = 30)
//' b1 <- matrix(dr[, 1], nrow = lgrid, ncol = lgrid)
//' b2 <- matrix(dr[, 2], nrow = lgrid, ncol = lgrid)
//' parms <- list(b1 = b1, b2 = b2, sigma2.1 = Sigma[1, 1], sigma2.2 = Sigma[2, 2],
//' len.grid = lgrid, delx = grid[2] - grid[1])
//' image(grid, grid, matrix(tpd.2D(x0i = which.min(2 - 2 * cos(grid - 0)),
//' y0i = which.min(2 - 2 * cos(grid - 0)),
//' times = seq(0, .5, l = 100), parms = parms,
//' method = "lsodes", atol = 1e-10,
//' lrw = 7e+07)[100, ], nrow = lgrid,
//' ncol = lgrid),
//' zlim = c(0, 0.25), main = "tpd.2D")
//'
//' x <- seq(-pi, pi, l = 100)
//' t <- 1
//' image(x, x, matrix(dTpdWnOu2D(x = as.matrix(expand.grid(x, x)),
//' x0 = matrix(rep(0, 100 * 2), nrow = 100 * 100,
//' ncol = 2),
//' t = t, alpha = alpha, mu = mu, sigma = sigma,
//' maxK = 2, etrunc = 30), 100, 100),
//' zlim = c(0, 0.25))
//' points(stepAheadWn2D(x0 = c(0, 0), delta = t / 500,
//' A = alphaToA(alpha = alpha, sigma = sigma), mu = mu,
//' sigma = sigma, N = 500, M = 1000, maxK = 2,
//' etrunc = 30))
//' }
//' @export
// [[Rcpp::export]]
arma::vec dTpdWnOu2D(arma::mat x, arma::mat x0, arma::vec t, arma::vec alpha, arma::vec mu, arma::vec sigma, int maxK = 2, double etrunc = 30) {
/*
* Create basic objects
*/
// Number of pairs
int N = x.n_rows;
// Create and initialize A
double quo = sigma(0) / sigma(1);
arma::mat A(2, 2);
A(0, 0) = alpha(0);
A(1, 1) = alpha(1);
A(0, 1) = alpha(2) * quo;
A(1, 0) = alpha(2) / quo;
// Create and initialize Sigma
arma::mat Sigma = diagmat(square(sigma));
// Sequence of winding numbers
const int lk = 2 * maxK + 1;
arma::vec twokpi = arma::linspace<arma::vec>(-maxK * 2 * M_PI, maxK * 2 * M_PI, lk);
// Bivariate vector (2 * K1 * M_PI, 2 * K2 * M_PI) for weighting
arma::vec twokepivec(2);
// Bivariate vector (2 * K1 * M_PI, 2 * K2 * M_PI) for wrapping
arma::vec twokapivec(2);
/*
* Check if the t is common
*/
int commonTime;
if(t.n_elem == 1){
commonTime = 0;
}else if(t.n_elem == N) {
commonTime = 1;
} else {
//stop("Length of t is neither 1 nor N");
std::exit(EXIT_FAILURE);
}
/*
* Check for symmetry and positive definiteness of A^(-1) * Sigma
*/
// Only positive definiteness can be violated with the parametrization of A
double testalpha = alpha(0) * alpha(1) - alpha(2) * alpha(2);
// Check positive definiteness
if(testalpha <= 0) {
// Update alpha(2) such that testalpha > 0
alpha(2) = std::signbit(alpha(2)) * sqrt(alpha(0) * alpha(1)) * 0.9999;
// Reset A to a matrix with positive determinant and continue
A(0, 1) = alpha(2) * quo;
A(1, 0) = alpha(2) / quo;
}
// A^(-1) * Sigma
arma::mat AInvSigma(2, 2);
AInvSigma(0, 0) = alpha(1) * Sigma(0, 0);
AInvSigma(0, 1) = -alpha(2) * sigma(0) * sigma(1);
AInvSigma(1, 0) = AInvSigma(0, 1);
AInvSigma(1, 1) = alpha(0) * Sigma(1, 1);
AInvSigma = AInvSigma / (alpha(0) * alpha(1) - alpha(2) * alpha(2));
// Inverse of (1/2 * A^(-1) * Sigma): 2 * Sigma^(-1) * A
arma::mat invSigmaA(2, 2);
invSigmaA(0, 0) = 2 * alpha(0) / Sigma(0, 0);
invSigmaA(0, 1) = 2 * alpha(2) / (sigma(0) * sigma(1));
invSigmaA(1, 0) = invSigmaA(0, 1);
invSigmaA(1, 1) = 2 * alpha(1) / Sigma(1, 1);
// For normalizing constants
double l2pi = log(2 * M_PI);
// Log-determinant of invSigmaA (assumed to be positive)
double logDetInvSigmaA, sign;
arma::log_det(logDetInvSigmaA, sign, invSigmaA);
// Log-normalizing constant for the Gaussian with covariance SigmaA
double lognormconstSigmaA = -l2pi + logDetInvSigmaA / 2;
/*
* Computation of Gammat and exp(-t * A) analytically
*/
// Quantities for computing exp(-t * A)
double s = sum(alpha.head(2)) / 2;
double q = sqrt(fabs((alpha(0) - s) * (alpha(1) - s) - alpha(2) * alpha(2)));
// Avoid indetermination in sinh(q * t) / q when q == 0
if(q == 0){
q = 1e-6;
}
// s1(-t) and s2(-t)
arma::vec est = exp(-s * t);
arma::vec eqt = exp(q * t);
arma::vec eqtinv = 1 / eqt;
arma::vec cqt = (eqt + eqtinv) / 2;
arma::vec sqt = (eqt - eqtinv) / (2 * q);
arma::vec s1t = est % (cqt + s * sqt);
arma::vec s2t = -est % sqt;
// s1(-2t) and s2(-2t)
est = est % est;
eqt = eqt % eqt;
eqtinv = eqtinv % eqtinv;
cqt = (eqt + eqtinv) / 2;
sqt = (eqt - eqtinv) / (2 * q);
arma::vec s12t = est % (cqt + s * sqt);
arma::vec s22t = -est % sqt;
/*
* Weights of the winding numbers for each data point
*/
// We store the weights in a matrix to skip the null later in the computation of the tpd
arma::mat weightswindsinitial(N, lk * lk);
weightswindsinitial.fill(lognormconstSigmaA);
// Loop in the data
for(int i = 0; i < N; i++){
// Compute the factors in the exponent that do not depend on the windings
arma::vec xmu = x0.row(i).t() - mu;
arma::vec xmuinvSigmaA = invSigmaA * xmu;
double xmuinvSigmaAxmudivtwo = -dot(xmuinvSigmaA, xmu) / 2;
// Loop in the winding weight K1
for(int wek1 = 0; wek1 < lk; wek1++){
// 2 * K1 * M_PI
twokepivec(0) = twokpi(wek1);
// Compute once the index
int wekl1 = wek1 * lk;
// Loop in the winding weight K2
for(int wek2 = 0; wek2 < lk; wek2++){
// 2 * K2 * M_PI
twokepivec(1) = twokpi(wek2);
// Negative exponent
weightswindsinitial(i, wekl1 + wek2) += xmuinvSigmaAxmudivtwo - dot(xmuinvSigmaA, twokepivec) - dot(invSigmaA * twokepivec, twokepivec) / 2;
}
}
}
// Standardize weights for the tpd
weightswindsinitial = safeSoftMax(weightswindsinitial, etrunc);
/*
* Computation of the tpd: wrapping + weighting
*/
// The evaluations of the tpd are stored in a vector, no need to keep track of wrappings
arma::vec tpdfinal(N); tpdfinal.zeros();
// Variables inside the commonTime if-block
arma::mat ExptiA(2, 2), invGammati(2, 2);
double logDetInvGammati, lognormconstGammati;
// If t is common, compute once
if(commonTime == 0){
// Exp(-ti * A)
ExptiA = s2t(0) * A;
ExptiA.diag() += s1t(0);
// Inverse and log-normalizing constant for the Gammat
invGammati = 2 * inv_sympd((1 - s12t(0)) * AInvSigma - s22t(0) * Sigma);
// Log-determinant of invGammati (assumed to be positive)
arma::log_det(logDetInvGammati, sign, invGammati);
// Log-normalizing constant for the Gaussian with covariance Gammati
lognormconstGammati = -l2pi + logDetInvGammati / 2;
}
// Loop in the data
for(int i = 0; i < N; i++){
// Initial point x0 varying with i
arma::vec x00 = x0.row(i).t();
// Evaluation point x varying with i
arma::vec xx = x.row(i).t();
// If t is not common
if(commonTime != 0){
// Exp(-ti * A)
ExptiA = s2t(i) * A;
ExptiA.diag() += s1t(i);
// Inverse and log-normalizing constant for the Gammati
invGammati = 2 * inv_sympd((1 - s12t(i)) * AInvSigma - s22t(i) * Sigma);
// Log-determinant of invGammati (assumed to be positive)
arma::log_det(logDetInvGammati, sign, invGammati);
// Log-normalizing constant for the Gaussian with covariance Gammati
lognormconstGammati = -l2pi + logDetInvGammati / 2;
}
// Common muti
arma::vec muti = mu + ExptiA * (x00 - mu);
// Loop on the winding weight K1
for(int wek1 = 0; wek1 < lk; wek1++){
// 2 * K1 * M_PI
twokepivec(0) = twokpi(wek1);
// Compute once the index
int wekl1 = wek1 * lk;
// Loop on the winding weight K2
for(int wek2 = 0; wek2 < lk; wek2++){
// Skip zero weights
if(weightswindsinitial(i, wekl1 + wek2) > 0){
// 2 * K1 * M_PI
twokepivec(1) = twokpi(wek2);
// Compute the factors in the exponent that do not depend on the windings
arma::vec xmuti = xx - muti - ExptiA * twokepivec;
arma::vec xmutiInvGammati = invGammati * xmuti;
double xmutiInvGammatixmutidiv2 = -dot(xmutiInvGammati, xmuti) / 2;
// Loop in the winding wrapping K1
for(int wak1 = 0; wak1 < lk; wak1++){
// 2 * K1 * M_PI
twokapivec(0) = twokpi(wak1);
// Loop in the winding wrapping K2
for(int wak2 = 0; wak2 < lk; wak2++){
// 2 * K2 * M_PI
twokapivec(1) = twokpi(wak2);
// Decomposition of the negative exponent
double exponent = xmutiInvGammatixmutidiv2 - dot(xmutiInvGammati, twokapivec) - dot(invGammati * twokapivec, twokapivec) / 2 + lognormconstGammati;
// Tpd
tpdfinal(i) += exp(exponent) * weightswindsinitial(i, wekl1 + wek2);
}
}
}
}
}
}
return tpdfinal;
}