/**
* Density is the fraction of present connections to possible connections.
*
* Input: W, undirected (weighted/binary) connection matrix
* Output: kden, density
* N, number of vertices
* K, number of edges
* Notes: Assumes CIJ is undirected and has no self-connections.
* Weight information is discarded.
*/
double Connectome::density(const mat &W)
{
uint N = W.n_rows;
uvec t = find(trimatu(W)!= 0);
double K = t.n_elem;
return K/((N*N-N)/2.0);
}
/**
*
* The assortativity coefficient is a correlation coefficient between the
* strengths (weighted degrees) of all nodes on two opposite ends of a link.
* A positive assortativity coefficient indicates that nodes tend to link to
* other nodes with the same or similar strength.
* Inputs: CIJ, weighted directed/undirected connection matrix
* Outputs: r, assortativity coefficient
* Notes: The function accepts weighted networks, but all connection
* weights are ignored. The main diagonal should be empty. For flag 1
* the function computes the directed assortativity described in Rubinov
* and Sporns (2010) NeuroImage.
* Reference: Newman (2002) Phys Rev Lett 89:208701
* Foster et al. (2010) PNAS 107:10815–10820
*/
double Connectome::assortativity(const mat &W)
{
rowvec str = strength(W);
mat Wt = trimatu(W); Wt.diag().fill(0);
umat idx = getIndex(find(Wt>0),W.n_rows,W.n_cols,0);
uint K = idx.n_rows;
vec stri = str(idx.col(0));
vec strj = str(idx.col(1));
double a = accu(stri%strj)/K,
b = accu(0.5*(stri+strj))/K,
c = accu(0.5*(pow(stri,2)+pow(strj,2)))/K;
return (a-b*b)/(c-b*b);
}
inline
bool
glue_solve_tri::apply(Mat<eT>& out, const Base<eT,T1>& A_expr, const Base<eT,T2>& B_expr, const uword flags)
{
arma_extra_debug_sigprint();
const bool fast = bool(flags & solve_opts::flag_fast );
const bool equilibrate = bool(flags & solve_opts::flag_equilibrate);
const bool no_approx = bool(flags & solve_opts::flag_no_approx );
const bool triu = bool(flags & solve_opts::flag_triu );
const bool tril = bool(flags & solve_opts::flag_tril );
arma_extra_debug_print("glue_solve_tri::apply(): enabled flags:");
if(fast ) { arma_extra_debug_print("fast"); }
if(equilibrate) { arma_extra_debug_print("equilibrate"); }
if(no_approx ) { arma_extra_debug_print("no_approx"); }
if(triu ) { arma_extra_debug_print("triu"); }
if(tril ) { arma_extra_debug_print("tril"); }
bool status = false;
if(equilibrate) { arma_debug_warn("solve(): option 'equilibrate' ignored for triangular matrices"); }
const unwrap_check<T1> U(A_expr.get_ref(), out);
const Mat<eT>& A = U.M;
arma_debug_check( (A.is_square() == false), "solve(): matrix marked as triangular must be square sized" );
const uword layout = (triu) ? uword(0) : uword(1);
status = auxlib::solve_tri(out, A, B_expr.get_ref(), layout); // A is not modified
if( (status == false) && (no_approx == false) )
{
arma_extra_debug_print("glue_solve_tri::apply(): solving rank deficient system");
arma_debug_warn("solve(): system seems singular; attempting approx solution");
Mat<eT> triA = (triu) ? trimatu( A_expr.get_ref() ) : trimatl( A_expr.get_ref() );
status = auxlib::solve_approx_svd(out, triA, B_expr.get_ref()); // triA is overwritten
}
if(status == false) { out.reset(); }
return status;
}
inline
bool
op_logmat_cx::helper(Mat<eT>& A, const uword m)
{
arma_extra_debug_sigprint();
if(A.is_finite() == false) { return false; }
const vec indices = regspace<vec>(1,m-1);
mat tmp(m,m,fill::zeros);
tmp.diag(-1) = indices / sqrt(square(2.0*indices) - 1.0);
tmp.diag(+1) = indices / sqrt(square(2.0*indices) - 1.0);
vec eigval;
mat eigvec;
const bool eig_ok = eig_sym_helper(eigval, eigvec, tmp, 'd', "logmat()");
if(eig_ok == false) { arma_extra_debug_print("logmat(): eig_sym() failed"); return false; }
const vec nodes = (eigval + 1.0) / 2.0;
const vec weights = square(eigvec.row(0).t());
const uword N = A.n_rows;
Mat<eT> B(N,N,fill::zeros);
Mat<eT> X;
for(uword i=0; i < m; ++i)
{
// B += weights(i) * solve( (nodes(i)*A + eye< Mat<eT> >(N,N)), A );
//const bool solve_ok = solve( X, (nodes(i)*A + eye< Mat<eT> >(N,N)), A, solve_opts::fast );
const bool solve_ok = solve( X, trimatu(nodes(i)*A + eye< Mat<eT> >(N,N)), A );
if(solve_ok == false) { arma_extra_debug_print("logmat(): solve() failed"); return false; }
B += weights(i) * X;
}
A = B;
return true;
}
Rcpp::List el_sem_euclid_weights(SEXP b_weights_r, SEXP y_r, SEXP omega_r, SEXP b_r)
{
//matrix which holds the observed data
mat y = as<arma::mat>(y_r);
int n = y.n_cols; //number of observations
int v = y.n_rows; //number of variables
//find appropriate spots to put in b_weights_r
uvec b_spots = find(as<arma::mat>(b_r)); //non-structural zeros in B
mat b_weights(v, v, fill::zeros); // matrix with edge weights
b_weights.elem(b_spots) = as<arma::vec>(b_weights_r);
uvec gamma_indices = arma::find(trimatu(as<arma::mat>(omega_r) == 0 )); //structural 0's in Omega
mat constraints(v + gamma_indices.n_elem, n); //constraints containing mean and covariance restrictions
constraints.rows(0, v - 1) = (eye(v, v) - b_weights) * y ; //mean restrictions
//covariance restrictions
int i,j,k;
for(k = 0; k < gamma_indices.n_elem; k++) {
j = (int) gamma_indices(k) / v;
i = (int) gamma_indices(k) % v;
constraints.row(k + v) = constraints.row(i) % constraints.row(j);
}
vec avg_constraints = mean(constraints, 1);
mat S(v + gamma_indices.n_elem, v + gamma_indices.n_elem, fill::zeros);
for(i = 0; i < n; i++){
S += constraints.col(i) * (avg_constraints.t() - constraints.col(i).t() );
}
S = S / n;
vec dual = solve(S, avg_constraints);
constraints.each_col() -= avg_constraints;
vec p_star = (1.0/ n) * (1 + (dual.t() * constraints).t());
double objective = - 1.0/2 * sum(pow(n * p_star - 1.0 ,2));
return Rcpp::List::create(Rcpp::Named("p_star", p_star),
Rcpp::Named("objective", objective));
}
//[[Rcpp::export]]
vec breg(vec const& y, mat const& X, vec const& betabar, mat const& A) {
// Keunwoo Kim 06/20/2014
// Purpose: draw from posterior for linear regression, sigmasq=1.0
// Output: draw from posterior
// Model: y = Xbeta + e e ~ N(0,I)
// Prior: beta ~ N(betabar,A^-1)
int k = betabar.size();
mat RA = chol(A);
mat W = join_cols(X, RA); //same as rbind(X,RA)
vec z = join_cols(y, RA*betabar);
mat IR = solve(trimatu(chol(trans(W)*W)), eye(k,k)); //trimatu interprets the matrix as upper triangular and makes solve more efficient
return ((IR*trans(IR))*(trans(W)*z) + IR*vec(rnorm(k)));
}
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]]
List rwishart(double nu, mat const& V){
// Wayne Taylor 4/7/2015
// Function to draw from Wishart (nu,V) and IW
// W ~ W(nu,V)
// E[W]=nuV
// WI=W^-1
// E[WI]=V^-1/(nu-m-1)
// T has sqrt chisqs on diagonal and normals below diagonal
int m = V.n_rows;
mat T = zeros(m,m);
for(int i = 0; i < m; i++) {
T(i,i) = sqrt(rchisq(1,nu-i)[0]); //rchisq returns a vectorized object, so using [0] allows for the conversion to double
}
for(int j = 0; j < m; j++) {
for(int i = j+1; i < m; i++) {
T(i,j) = rnorm(1)[0]; //rnorm returns a NumericVector, so using [0] allows for conversion to double
}}
mat C = trans(T)*chol(V);
mat CI = solve(trimatu(C),eye(m,m)); //trimatu interprets the matrix as upper triangular and makes solve more efficient
// C is the upper triangular root of Wishart therefore, W=C'C
// this is the LU decomposition Inv(W) = CICI' Note: this is
// the UL decomp not LU!
// W is Wishart draw, IW is W^-1
return List::create(
Named("W") = trans(C) * C,
Named("IW") = CI * trans(CI),
Named("C") = C,
Named("CI") = CI);
}
// [[Rcpp::export]]
List rhierLinearModel_rcpp_loop(List const& regdata, mat const& Z, mat const& Deltabar, mat const& A, double nu,
mat const& V, double nu_e, vec const& ssq, vec tau, mat Delta, mat Vbeta, int R, int keep, int nprint){
// Keunwoo Kim 09/16/2014
// Purpose: run hiearchical regression model
// Arguments:
// Data list of regdata,Z
// regdata is a list of lists each list with members y, X
// e.g. regdata[[i]]=list(y=y,X=X)
// X has nvar columns
// Z is nreg=length(regdata) x nz
// Prior list of prior hyperparameters
// Deltabar,A, nu.e,ssq,nu,V
// note: ssq is a nreg x 1 vector!
// Mcmc
// list of Mcmc parameters
// R is number of draws
// keep is thining parameter -- keep every keepth draw
// nprint - print estimated time remaining on every nprint'th draw
// Output:
// list of
// betadraw -- nreg x nvar x R/keep array of individual regression betas
// taudraw -- R/keep x nreg array of error variances for each regression
// Deltadraw -- R/keep x nz x nvar array of Delta draws
// Vbetadraw -- R/keep x nvar*nvar array of Vbeta draws
// Model:
// nreg regression equations
// y_i = X_ibeta_i + epsilon_i
// epsilon_i ~ N(0,tau_i)
// nvar X vars in each equation
// Prior:
// tau_i ~ nu.e*ssq_i/chisq(nu.e) tau_i is the variance of epsilon_i
// beta_i ~ N(ZDelta[i,],V_beta)
// Note: ZDelta is the matrix Z * Delta; [i,] refers to ith row of this product!
// vec(Delta) | V_beta ~ N(vec(Deltabar),Vbeta (x) A^-1)
// V_beta ~ IW(nu,V) or V_beta^-1 ~ W(nu,V^-1)
// Delta, Deltabar are nz x nvar
// A is nz x nz
// Vbeta is nvar x nvar
// NOTE: if you don't have any z vars, set Z=iota (nreg x 1)
// Update Note:
// (Keunwoo Kim 04/07/2015)
// Changed "rmultireg" to return List object, which is the original function.
// Efficiency is almost same as when the output is a struct object.
// Nothing different from "rmultireg1" in the previous R version.
int reg, mkeep;
mat Abeta, betabar, ucholinv, Abetabar;
List regdatai, rmregout;
unireg regout_struct;
int nreg = regdata.size();
int nvar = V.n_cols;
int nz = Z.n_cols;
// convert List to std::vector of struct
std::vector<moments> regdata_vector;
moments regdatai_struct;
// store vector with struct
for (reg=0; reg<nreg; reg++){
regdatai = regdata[reg];
regdatai_struct.y = as<vec>(regdatai["y"]);
regdatai_struct.X = as<mat>(regdatai["X"]);
regdatai_struct.XpX = as<mat>(regdatai["XpX"]);
regdatai_struct.Xpy = as<vec>(regdatai["Xpy"]);
regdata_vector.push_back(regdatai_struct);
}
mat betas(nreg, nvar);
mat Vbetadraw(R/keep, nvar*nvar);
mat Deltadraw(R/keep, nz*nvar);
mat taudraw(R/keep, nreg);
cube betadraw(nreg, nvar, R/keep);
if (nprint>0) startMcmcTimer();
//start main iteration loop
for (int rep=0; rep<R; rep++){
// compute the inverse of Vbeta
ucholinv = solve(trimatu(chol(Vbeta)), eye(nvar,nvar)); //trimatu interprets the matrix as upper triangular and makes solve more efficient
Abeta = ucholinv*trans(ucholinv);
betabar = Z*Delta;
Abetabar = Abeta*trans(betabar);
//loop over all regressions
for (reg=0; reg<nreg; reg++){
regout_struct = runiregG(regdata_vector[reg].y, regdata_vector[reg].X,
regdata_vector[reg].XpX, regdata_vector[reg].Xpy,
tau[reg], Abeta, Abetabar(span::all,reg),
nu_e, ssq[reg]);
betas(reg,span::all) = trans(regout_struct.beta);
tau[reg] = regout_struct.sigmasq;
}
//draw Vbeta, Delta | {beta_i}
rmregout = rmultireg(betas,Z,Deltabar,A,nu,V);
Vbeta = as<mat>(rmregout["Sigma"]); //conversion from Rcpp to Armadillo requires explict declaration of variable type using as<>
Delta = as<mat>(rmregout["B"]);
//print time to completion and draw # every nprint'th draw
if (nprint>0) if ((rep+1)%nprint==0) infoMcmcTimer(rep, R);
if((rep+1)%keep==0){
mkeep = (rep+1)/keep;
Vbetadraw(mkeep-1, span::all) = trans(vectorise(Vbeta));
Deltadraw(mkeep-1, span::all) = trans(vectorise(Delta));
taudraw(mkeep-1, span::all) = trans(tau);
betadraw.slice(mkeep-1) = betas;
}
}
if (nprint>0) endMcmcTimer();
return List::create(
Named("Vbetadraw") = Vbetadraw,
Named("Deltadraw") = Deltadraw,
Named("betadraw") = betadraw,
Named("taudraw") = taudraw);
}
int MCMCPkPg::sampleZ( PkPgModel& model, PkPgResult& Result ){
//zeros<mat>( model.N, model.Q ); // temporaly sample Z_ig - mu_ig
mat RO = Result.Rho * Result.Otheta;
mat RORt = RO * Result.Rho.t();
mat SZi = Result.Osnp + RORt;
mat cZU = chol( SZi );
//std::cout <<"g0"<<std::endl;
uvec aidx( 1 );
umat bidx_temp( model.Q, 1 );
for( size_t g = 0; g < model.Q; g++ ){
bidx_temp( g, 0 ) = g;
}
mat clogt = ( Result.logTheta- Result.XBetaPk );
mat tempMz0 = Result.Osnp * Result.XBetaPg.t() + RO *clogt.t();
mat v0 = solve( trimatl( trans( cZU ) ), tempMz0 );
mat mz0 = trans(solve( trimatu( cZU ), v0 ) );
//std::cout <<"g"<<std::endl;
for( size_t i = 0; i < model.N; i++ ){
vec z = Result.Z.row(i).t();
for( size_t j = 0; j < model.Q; j++ ){
//std::cout <<"g2"<<std::endl;
// mat tempMz = Result.Osnp * Result.XBetaPg.row(i).t() + RO *clogt.row(i).t() ;
// mat v = solve( trimatl( trans( cZU ) ), tempMz );
// vec mz = solve( trimatu( cZU ), v ) ;
vec mz = mz0.row(i).t();
aidx( 0 ) = j;
//mz.print("mz");
//std::cout <<"g1"<<std::endl;
umat bidxt = bidx_temp;
//std::cout <<"g2"<<std::endl;
bidxt.shed_row( j );
//std::cout <<"g3"<<std::endl;
uvec bidx = bidxt.col( 0 );//conv_to< uvec >::from( bidxt);
//std::cout <<"g4"<<std::endl;
double sdz1 =pow( SZi( j, j ), - 0.5 );
// std::cout <<"g5"<<std::endl;
double mzc1 = as_scalar( SZi.submat(aidx,bidx)*(z.elem(bidx)-mz.elem(bidx)));
double mzc = mzc1/SZi( j, j );
/// std::cout <<"g6"<<std::endl;
z( j ) = ZgivenW( model.W( i, j ),mzc, sdz1 );
// std::cout <<"mz( i, j )"<<mz( j )<<std::endl;
// std::cout <<"z( i, j )"<<z( i, j )<<std::endl;
// std::cout <<"g3"<<std::endl;
Result.Z( i, j ) = z( j ) ;
// std::cout <<"g10"<<std::endl;
}
}
// for( size_t i = 0; i < model.N; i++ ){
// int Qidx = model.Q - 1;
// double sdz1 = cZU( Qidx, Qidx );//1.0 / cZU( Qidx, Qidx );
// double mzc1 = mz( i, Qidx);//double mzc1 = mz( i, Qidx );
// z( i, Qidx ) = ZgivenW(model.W( i, Qidx ),mzc1, sdz1 );
// for( int g = ( model.Q - 1 ); g >= 0 ; g-- ){
// double mzc = 0;//double mzc = mz( i, g );
// for( size_t j = g + 1; j < model.Q ; j++ ){
// //mzc -= ( z( i, j ) - mz( i, j ) ) * cZU( g, j )/cZU( g, g );
// mzc -= ( z( i, j ) - mz( i, j ) ) * cZU( g, j );//cZU( g, g )
// } // j
// double sdz = cZU( g, g ) ;//1.0 / cZU( g, g ) ;
// z( i, g ) = ZgivenW( model.W( i, g ), mzc, sdz ) + mz( i, g );
// Result.Z( i, g ) = z( i, g ) ;
// }//g
// }//i
Result.ZtZ = Result.Z.t() * Result.Z; // update ZtZ also
Result.ZRho= Result.Z * Result.Rho;
return 0;
}
//[[Rcpp::export]]
List rhierMnlRwMixture_rcpp_loop(List const& lgtdata, mat const& Z,
vec const& deltabar, mat const& Ad, mat const& mubar, mat const& Amu,
double nu, mat const& V, double s,
int R, int keep, int nprint, bool drawdelta,
mat olddelta, vec const& a, vec oldprob, mat oldbetas, vec ind, vec const& SignRes){
// Wayne Taylor 10/01/2014
int nlgt = lgtdata.size();
int nvar = V.n_cols;
int nz = Z.n_cols;
mat rootpi, betabar, ucholinv, incroot;
int mkeep;
mnlMetropOnceOut metropout_struct;
List lgtdatai, nmix;
// convert List to std::vector of struct
std::vector<moments> lgtdata_vector;
moments lgtdatai_struct;
for (int lgt = 0; lgt<nlgt; lgt++){
lgtdatai = lgtdata[lgt];
lgtdatai_struct.y = as<vec>(lgtdatai["y"]);
lgtdatai_struct.X = as<mat>(lgtdatai["X"]);
lgtdatai_struct.hess = as<mat>(lgtdatai["hess"]);
lgtdata_vector.push_back(lgtdatai_struct);
}
// allocate space for draws
vec oldll = zeros<vec>(nlgt);
cube betadraw(nlgt, nvar, R/keep);
mat probdraw(R/keep, oldprob.size());
vec loglike(R/keep);
mat Deltadraw(1,1); if(drawdelta) Deltadraw.zeros(R/keep, nz*nvar);//enlarge Deltadraw only if the space is required
List compdraw(R/keep);
if (nprint>0) startMcmcTimer();
for (int rep = 0; rep<R; rep++){
//first draw comps,ind,p | {beta_i}, delta
// ind,p need initialization comps is drawn first in sub-Gibbs
List mgout;
if(drawdelta) {
olddelta.reshape(nvar,nz);
mgout = rmixGibbs (oldbetas-Z*trans(olddelta),mubar,Amu,nu,V,a,oldprob,ind);
} else {
mgout = rmixGibbs(oldbetas,mubar,Amu,nu,V,a,oldprob,ind);
}
List oldcomp = mgout["comps"];
oldprob = as<vec>(mgout["p"]); //conversion from Rcpp to Armadillo requires explict declaration of variable type using as<>
ind = as<vec>(mgout["z"]);
//now draw delta | {beta_i}, ind, comps
if(drawdelta) olddelta = drawDelta(Z,oldbetas,ind,oldcomp,deltabar,Ad);
//loop over all LGT equations drawing beta_i | ind[i],z[i,],mu[ind[i]],rooti[ind[i]]
for(int lgt = 0; lgt<nlgt; lgt++){
List oldcomplgt = oldcomp[ind[lgt]-1];
rootpi = as<mat>(oldcomplgt[1]);
//note: beta_i = Delta*z_i + u_i Delta is nvar x nz
if(drawdelta){
olddelta.reshape(nvar,nz);
betabar = as<vec>(oldcomplgt[0])+olddelta*vectorise(Z(lgt,span::all));
} else {
betabar = as<vec>(oldcomplgt[0]);
}
if (rep == 0) oldll[lgt] = llmnl_con(vectorise(oldbetas(lgt,span::all)),lgtdata_vector[lgt].y,lgtdata_vector[lgt].X,SignRes);
//compute inc.root
ucholinv = solve(trimatu(chol(lgtdata_vector[lgt].hess+rootpi*trans(rootpi))), eye(nvar,nvar)); //trimatu interprets the matrix as upper triangular and makes solve more efficient
incroot = chol(ucholinv*trans(ucholinv));
metropout_struct = mnlMetropOnce_con(lgtdata_vector[lgt].y,lgtdata_vector[lgt].X,vectorise(oldbetas(lgt,span::all)),
oldll[lgt],s,incroot,betabar,rootpi,SignRes);
oldbetas(lgt,span::all) = trans(metropout_struct.betadraw);
oldll[lgt] = metropout_struct.oldll;
}
//print time to completion and draw # every nprint'th draw
if (nprint>0) if ((rep+1)%nprint==0) infoMcmcTimer(rep, R);
if((rep+1)%keep==0){
mkeep = (rep+1)/keep;
betadraw.slice(mkeep-1) = oldbetas;
probdraw(mkeep-1, span::all) = trans(oldprob);
loglike[mkeep-1] = sum(oldll);
if(drawdelta) Deltadraw(mkeep-1, span::all) = trans(vectorise(olddelta));
compdraw[mkeep-1] = oldcomp;
}
}
if (nprint>0) endMcmcTimer();
nmix = List::create(Named("probdraw") = probdraw,
Named("zdraw") = R_NilValue, //sets the value to NULL in R
Named("compdraw") = compdraw);
//ADDED FOR CONSTRAINTS
//If there are sign constraints, return f(betadraws) as "betadraws"
//conStatus will be set to true if SignRes has any non-zero elements
bool conStatus = any(SignRes);
if(conStatus){
int SignResSize = SignRes.size();
//loop through each sign constraint
for(int i = 0;i < SignResSize; i++){
//if there is a constraint loop through each slice of betadraw
if(SignRes[i] != 0){
for(int s = 0;s < R/keep; s++){
betadraw(span(),span(i),span(s)) = SignRes[i] * exp(betadraw(span(),span(i),span(s)));
}
}
}//end loop through SignRes
}
if(drawdelta){
return(List::create(
Named("Deltadraw") = Deltadraw,
Named("betadraw") = betadraw,
Named("nmix") = nmix,
Named("loglike") = loglike,
Named("SignRes") = SignRes));
} else {
return(List::create(
Named("betadraw") = betadraw,
Named("nmix") = nmix,
Named("loglike") = loglike,
Named("SignRes") = SignRes));
}
}
