RcppExport SEXP xbrlProcessFacts(SEXP epaDoc) {
xmlDocPtr doc = (xmlDocPtr) R_ExternalPtrAddr(epaDoc);
xmlXPathContextPtr context = xmlXPathNewContext(doc);
xmlXPathObjectPtr fact_res = xmlXPathEvalExpression((xmlChar*) "//*[@*[local-name()='contextRef']]", context);
xmlNodeSetPtr fact_nodeset = fact_res->nodesetval;
xmlXPathFreeContext(context);
int fact_nodeset_ln = fact_nodeset->nodeNr;
CharacterVector elementId(fact_nodeset_ln);
CharacterVector contextId(fact_nodeset_ln);
CharacterVector unitId(fact_nodeset_ln);
CharacterVector fact(fact_nodeset_ln);
CharacterVector decimals(fact_nodeset_ln);
CharacterVector sign(fact_nodeset_ln);
CharacterVector scale(fact_nodeset_ln);
CharacterVector tupleRef(fact_nodeset_ln);
CharacterVector order(fact_nodeset_ln);
CharacterVector factId(fact_nodeset_ln);
CharacterVector ns(fact_nodeset_ln);
for (int i=0; i < fact_nodeset_ln; i++) {
xmlNodePtr fact_node = fact_nodeset->nodeTab[i];
if (fact_node->ns->prefix)
elementId[i] = (char *) ((string) (char *) fact_node->ns->prefix + "_" + (string) (char *) fact_node->name).data();
else
elementId[i] = (char *) fact_node->name;
xmlChar *tmp_str;
if ((tmp_str = xmlGetProp(fact_node, (xmlChar*) "contextRef"))) {
contextId[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
contextId[i] = NA_STRING;
}
if ((tmp_str = xmlGetProp(fact_node, (xmlChar*) "unitRef"))) {
unitId[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
unitId[i] = NA_STRING;
}
if ((tmp_str = xmlNodeListGetString(doc, fact_node->xmlChildrenNode, 1))) {
fact[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
fact[i] = NA_STRING;
}
if ((tmp_str = xmlGetProp(fact_node, (xmlChar*) "decimals"))) {
decimals[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
decimals[i] = NA_STRING;
}
if ((tmp_str = xmlGetProp(fact_node, (xmlChar*) "scale"))) {
scale[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
scale[i] = NA_STRING;
}
if ((tmp_str = xmlGetProp(fact_node, (xmlChar*) "sign"))) {
sign[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
sign[i] = NA_STRING;
}
if ((tmp_str = xmlGetProp(fact_node, (xmlChar*) "tupleRef"))) {
sign[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
sign[i] = NA_STRING;
}
if ((tmp_str = xmlGetProp(fact_node, (xmlChar*) "order"))) {
sign[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
sign[i] = NA_STRING;
}
if ((tmp_str = xmlGetProp(fact_node, (xmlChar*) "id"))) {
factId[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else if ((tmp_str = xmlGetProp(fact_node, (xmlChar*) "name"))) {
factId[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
factId[i] = NA_STRING;
}
ns[i] = (char *) fact_node->ns->href;
}
xmlXPathFreeObject(fact_res);
return DataFrame::create(Named("elementId")=elementId,
Named("contextId")=contextId,
Named("unitId")=unitId,
Named("fact")=fact,
Named("factId")=factId,
Named("decimals")=decimals,
Named("scale")=scale,
Named("sign")=sign,
Named("tupleRef")=tupleRef,
Named("order")=order,
Named("ns")=ns);
}
RcppExport SEXP xbrlProcessUnits(SEXP epaDoc) {
xmlDocPtr doc = (xmlDocPtr) R_ExternalPtrAddr(epaDoc);
xmlXPathContextPtr context = xmlXPathNewContext(doc);
xmlXPathObjectPtr unit_res = xmlXPathEvalExpression((xmlChar*) "//*[local-name()='unit']", context);
xmlNodeSetPtr unit_nodeset = unit_res->nodesetval;
int unit_nodeset_ln = unit_nodeset->nodeNr;
xmlXPathFreeContext(context);
CharacterVector unitId(unit_nodeset_ln);
CharacterVector measure(unit_nodeset_ln);
CharacterVector unitNumerator(unit_nodeset_ln);
CharacterVector unitDenominator(unit_nodeset_ln);
for (int i=0; i < unit_nodeset_ln; i++) {
xmlNodePtr unit_node = unit_nodeset->nodeTab[i];
xmlChar *tmp_str;
if ((tmp_str = xmlGetProp(unit_node, (xmlChar*) "id"))) {
unitId[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
unitId[i] = NA_STRING;
}
measure[i] = unitNumerator[i] = unitDenominator[i] = NA_STRING;
xmlNodePtr child_node = unit_node->xmlChildrenNode;
while (child_node) {
if (!xmlStrcmp(child_node->name, (xmlChar*) "measure")) {
if ((tmp_str = xmlNodeListGetString(doc, child_node->xmlChildrenNode, 1))) {
measure[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
} else if (!xmlStrcmp(child_node->name, (xmlChar*) "divide")) {
xmlNodePtr gchild_node = child_node->xmlChildrenNode;
while (gchild_node) {
if (!xmlStrcmp(gchild_node->name, (xmlChar*) "unitNumerator")) {
xmlNodePtr ggchild_node = gchild_node->xmlChildrenNode;
while (ggchild_node) {
if (!xmlStrcmp(ggchild_node->name, (xmlChar*) "measure")) {
if ((tmp_str = xmlNodeListGetString(doc, ggchild_node->xmlChildrenNode, 1))) {
unitNumerator[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
}
ggchild_node = ggchild_node->next;
}
} else if (!xmlStrcmp(gchild_node->name, (xmlChar*) "unitDenominator")) {
xmlNodePtr ggchild_node = gchild_node->xmlChildrenNode;
while (ggchild_node) {
if (!xmlStrcmp(ggchild_node->name, (xmlChar*) "measure")) {
if ((tmp_str = xmlNodeListGetString(doc, ggchild_node->xmlChildrenNode, 1))) {
unitDenominator[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
}
ggchild_node = ggchild_node->next;
}
}
gchild_node = gchild_node->next;
}
}
child_node = child_node->next;
}
}
xmlXPathFreeObject(unit_res);
return DataFrame::create(Named("unitId")=unitId,
Named("measure")=measure,
Named("unitNumerator")=unitNumerator,
Named("unitDenominator")=unitDenominator);
}
List objective(const arma::mat& transition, NumericVector emissionArray,
const arma::vec& init, IntegerVector obsArray, const arma::imat& ANZ,
IntegerVector emissNZ, const arma::ivec& INZ, const arma::ivec& nSymbols, int threads) {
IntegerVector eDims = emissionArray.attr("dim"); //m,p,r
IntegerVector oDims = obsArray.attr("dim"); //k,n,r
arma::cube emission(emissionArray.begin(), eDims[0], eDims[1], eDims[2], false, true);
arma::icube obs(obsArray.begin(), oDims[0], oDims[1], oDims[2], false, true);
arma::icube BNZ(emissNZ.begin(), emission.n_rows, emission.n_cols - 1, emission.n_slices, false, true);
arma::vec grad(arma::accu(ANZ) + arma::accu(BNZ) + arma::accu(INZ), arma::fill::zeros);
// arma::cube alpha(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k
// arma::cube beta(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k
// arma::mat scales(obs.n_cols, obs.n_slices); //m,n,k
//
// internalForward(transition, emission, init, obs, alpha, scales, threads);
// if (!scales.is_finite()) {
// grad.fill(-arma::math::inf());
// return List::create(Named("objective") = arma::math::inf(), Named("gradient") = wrap(grad));
// }
//
// internalBackward(transition, emission, obs, beta, scales, threads);
// if (!beta.is_finite()) {
// grad.fill(-arma::math::inf());
// return List::create(Named("objective") = arma::math::inf(), Named("gradient") = wrap(grad));
// }
//use this instead of local vectors with grad += grad_k;, uses more memory but gives bit-identical results
//arma::mat gradmat(arma::accu(ANZ) + arma::accu(BNZ) + arma::accu(INZ), obs.n_slices);
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(grad, nSymbols, ANZ, BNZ, INZ, obs, init, transition, emission, error)
for (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) / scales(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 (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) / scales(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) / scales(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) / scales(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::math::inf();
grad.fill(-arma::math::inf());
}
// } else {
// grad = sum(gradmat, 1);
// }
return List::create(Named("objective") = -ll, Named("gradient") = wrap(-grad));
}
RcppExport SEXP particleSwarm(SEXP YList1, SEXP n1, SEXP p1, SEXP r1,
SEXP mtype1,SEXP retraction1,
SEXP f1,
SEXP control1){
BEGIN_RCPP
//Initialization of functions and control parameters
Function obej(f1);
List control(control1);
IntegerVector retraction(retraction1);
int iterMax=as< int>(control["iterMax"]);
double phi1=as< double>(control["phi1"]);
double phi2=as< double>(control["phi2"]);
double omega=as< double>(control["omega"]);
//controlling parameter: number of particles and number of parallel threads
int particle_num=as< int>(control["particleNum"]);
int thread_num=as< int>(control["threadNum"]);
//double alpha=as< double>(control["alpha"]);
// Initialization of Data points
IntegerVector n(n1),p(p1),r(r1);
CharacterVector mtype(mtype1);
int prodK=n.size();// size of product manifold
//global best position
vector< manifold*> manifoldYG;
int k;
List YList(YList1), YList_temp(YList1);
// omp_set_num_threads(thread_num);
// int dim=0;
// for(k=0;k<prodK;k++) dim+=n[k]+p[k];
// const int particle_num=dim; //dimension needs to be changed;
//present and historical best postion of each particle
vector< vector< manifold*> > manifoldYP(particle_num), manifoldYB(particle_num);
int iter=0; // outer loop
double objValue;
//individual current and best value
vector<double> objValue_p(particle_num,0.0), objValue_b(particle_num,0.0);
//initiating particle_num size of particles and velocities;
int outter_num;
// #pragma omp parallel for schedule(static) private(k) shared(manifoldYB, manifoldYG,manifoldYP,prodK)
for(outter_num=0;outter_num<particle_num;outter_num++){
for(k=0;k<prodK;k++){
SEXP yTemp2=YList[k];
NumericMatrix yTemp(yTemp2);
std::string typeTemp=as< std::string>(mtype[k]);
if(typeTemp=="stiefel"){
manifoldYP[outter_num].push_back(new stiefel(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new stiefel(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new stiefel(n[k],p[k],r[k],
yTemp,retraction[k]));
}
else if(typeTemp=="grassmannQ"){
manifoldYP[outter_num].push_back(new grassmannQ(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new grassmannQ(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new grassmannQ(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="grassmannSub"){
manifoldYP[outter_num].push_back(new grassmannSub(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new grassmannSub(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new grassmannSub(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="fixedRank"){
manifoldYP[outter_num].push_back(new fixRank(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new fixRank(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new fixRank(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="fixedRankSym"){
manifoldYP[outter_num].push_back(new fixRankSym(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new fixRankSym(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new fixRankSym(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="fixedRankPSD"){
manifoldYP[outter_num].push_back(new fixRankPSD(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new fixRankPSD(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new fixRankPSD(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="spectahedron"){
manifoldYP[outter_num].push_back(new spectahedron(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new spectahedron(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new spectahedron(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="elliptope"){
manifoldYP[outter_num].push_back(new elliptope(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new elliptope(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new elliptope(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="sphere"){
manifoldYP[outter_num].push_back(new sphere(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new sphere(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new sphere(n[k],p[k],r[k],
yTemp,retraction[k]));
}
else if(typeTemp=="oblique"){
manifoldYP[outter_num].push_back(new oblique(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new oblique(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new oblique(n[k],p[k],r[k],
yTemp,retraction[k]));
}
else if(typeTemp=="specialLinear"){
manifoldYP[outter_num].push_back(new specialLinear(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new specialLinear(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new specialLinear(n[k],p[k],r[k],
yTemp,retraction[k]));
}
else if(typeTemp=="projective"){
manifoldYP[outter_num].push_back(new projective(n[k],p[k],r[k],
yTemp,retraction[k]));
manifoldYB[outter_num].push_back(new projective(n[k],p[k],r[k],
yTemp,retraction[k]));
if(outter_num==0) manifoldYG.push_back(new projective(n[k],p[k],r[k],
yTemp,retraction[k]));
}
manifoldYP[outter_num][k]->set_particle();
*manifoldYB[outter_num][k]=*manifoldYP[outter_num][k];
// if(outter_num==0) *manifoldYG[k]=*manifoldYP[outter_num][k];
}
}
//initialising the global-value position
for(k=0;k<prodK;k++) YList[k]=manifoldYG[k]->get_Y();
if(prodK>1){
objValue=as< double>(obej(YList));
}else{
objValue=as< double>(obej(YList[0]));
}
double best_objValue=objValue;
int best_pos=-1;
for(outter_num=0;outter_num<particle_num;outter_num++){
for(k=0;k<prodK;k++) YList_temp[k]=manifoldYP[outter_num][k]->get_Y();
if(prodK>1){
objValue_b[outter_num]=as< double>(obej(YList_temp));
}else{
objValue_b[outter_num]=as< double>(obej(YList_temp[0]));
}
if(objValue_b[outter_num]<best_objValue) {
best_objValue=objValue_b[outter_num];
best_pos=outter_num;
}
}
if(best_pos>-1){
for(k=0;k<prodK;k++) manifoldYG[k]->set_Y(manifoldYP[best_pos][k]->get_Y());
objValue=best_objValue;
}
//specific arguments of particleSwarm;
//double omega=1.0; //can be added to arguments later;
//double phi1=2,phi2=2; //can be added to arguments later;
arma::mat velocity;
//R01 and R02 are uniform (0,1) distributed numbers;
srand (time(NULL));
double R01=0.5,R02=0.5;
//int thread_num;
//int subthread_num=0,subthread_num_1=0; //to test whether parallelism happens;
//begin iteration
while(iter<iterMax){
iter++;
#pragma omp parallel shared(manifoldYG,objValue,manifoldYB,manifoldYP) \
shared(objValue_p,objValue_b,prodK,obej) \
firstprivate(velocity) \
private(R01,R02,k)
{
// #pragma omp for schedule(static)
for(outter_num=0;outter_num<particle_num;outter_num++){
srand(int(time(NULL)));// ^ omp_get_thread_num());
// List YList_parallel(prodK);
//begin updating each component
for(k=0;k<prodK;k++){
R01=((double) rand() / (RAND_MAX+1));
R02=((double) rand() / (RAND_MAX+1));
//velocity update
velocity=omega*manifoldYP[outter_num][k]->get_descD();
velocity+=phi1*R01*(manifoldYB[outter_num][k]->get_Y()-
manifoldYP[outter_num][k]->get_Y());
velocity+=phi2*R02*(manifoldYG[k]->get_Y()-
manifoldYP[outter_num][k]->get_Y());
// Rcpp::Rcout<<1<<endl;
//project onto tangent space
manifoldYP[outter_num][k]->evalGradient(velocity,"particleSwarm");
//Rcpp::Rcout<<2<<endl;
manifoldYP[outter_num][k]->retract(1,"particleSwarm",true);
//Rcpp::Rcout<<3<<endl;
manifoldYP[outter_num][k]->vectorTrans();
//Rcpp::Rcout<<4<<endl;
manifoldYP[outter_num][k]->acceptY();
//Rcpp::Rcout<<5<<endl;
//YList_parallel[k]=manifoldYP[outter_num][k]->getY();
}//update each component
// #pragma omp critical
// {
// if(prodK>1){
// objValue_p[outter_num]=as< double>(obej(YList_temp));
// }else{
// objValue_p[outter_num]=as< double>(obej(YList_temp[0]));
// }
// }
//
// //if present is better than individual historical best
// if(objValue_p[outter_num]<objValue_b[outter_num]){
// objValue_b[outter_num]=objValue_p[outter_num];
// for(k=0;k<prodK;k++) *manifoldYB[outter_num][k]
// =*manifoldYP[outter_num][k];
// }
}// iteration over particles;
} //out of parallel region;
for(outter_num=0;outter_num<particle_num;outter_num++){
for(k=0;k<prodK;k++) YList_temp[k]=manifoldYP[outter_num][k]->get_Y();
if(prodK>1){
objValue_p[outter_num]=as< double>(obej(YList_temp));
}else{
objValue_p[outter_num]=as< double>(obej(YList_temp[0]));
}
//if present is better than individual historical best
if(objValue_p[outter_num]<objValue_b[outter_num]){
objValue_b[outter_num]=objValue_p[outter_num];
for(k=0;k<prodK;k++) *manifoldYB[outter_num][k]
=*manifoldYP[outter_num][k];
}
}
//check and update global optimal value
best_objValue=objValue;
best_pos=-1;
for(outter_num=0;outter_num<particle_num;outter_num++){
if(objValue_b[outter_num]<best_objValue){
best_pos=outter_num;
best_objValue=objValue_b[outter_num];
}
}
if(best_pos>-1){
for(k=0;k<prodK;k++) manifoldYG[k]->set_Y(manifoldYP[best_pos][k]->get_Y());
objValue=best_objValue;
}
}// outer iteration
for(k=0;k<prodK;k++) YList[k]=manifoldYG[k]->get_Y();
return List::create(Named("optY")=YList,
Named("optValue")=objValue);
// Named("NumIter")=iter);
END_RCPP
}//end of function
DataFrame LNLP::get_stats()
{
PredStats output = make_stats();
PredStats const_output = make_const_stats();
return DataFrame::create( Named("num_pred") = output.num_pred,
Named("rho") = output.rho,
Named("mae") = output.mae,
Named("rmse") = output.rmse,
Named("perc") = output.perc,
Named("p_val") = output.p_val,
Named("const_pred_num_pred") = const_output.num_pred,
Named("const_pred_rho") = const_output.rho,
Named("const_pred_mae") = const_output.mae,
Named("const_pred_rmse") = const_output.rmse,
Named("const_pred_perc") = const_output.perc,
Named("const_p_val") = const_output.p_val);
}
List log_EMx(const arma::mat& transition_, const arma::cube& emission_,
const arma::vec& init_, const arma::ucube& obs, const arma::uvec& nSymbols,
const arma::mat& coef_, const arma::mat& X, const arma::uvec& numberOfStates,
int itermax, double tol, int trace, unsigned int threads) {
// Make sure we don't alter the original vec/mat/cube
// needed for cube, in future maybe in other cases as well
arma::cube emission = log(emission_);
arma::mat transition = log(transition_);
arma::vec init = log(init_);
arma::mat coef(coef_);
coef.col(0).zeros();
arma::mat weights = exp(X * coef).t();
if (!weights.is_finite()) {
return List::create(Named("error") = 3);
}
weights.each_row() /= sum(weights, 0);
weights = log(weights);
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::cube alpha(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k
arma::cube beta(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k
log_internalForwardx(transition, emission, initk, obs, alpha, threads);
log_internalBackward(transition, emission, obs, beta, threads);
arma::vec ll(obs.n_slices);
#pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \
default(none) shared(obs, alpha, ll)
for (unsigned int k = 0; k < obs.n_slices; k++) {
ll(k) = logSumExp(alpha.slice(k).col(obs.n_cols - 1));
}
double sumlogLik = sum(ll);
if (trace > 0) {
Rcout << "Log-likelihood of initial model: " << sumlogLik << std::endl;
}
//
// //EM-algorithm begins
//
double change = tol + 1.0;
int iter = 0;
arma::uvec cumsumstate = cumsum(numberOfStates);
while ((change > tol) & (iter < itermax)) {
iter++;
arma::mat ksii(emission.n_rows, emission.n_rows, arma::fill::zeros);
arma::cube gamma(emission.n_rows, emission.n_cols, emission.n_slices, arma::fill::zeros);
arma::vec delta(emission.n_rows, arma::fill::zeros);
for (unsigned int k = 0; k < obs.n_slices; k++) {
delta += exp(alpha.slice(k).col(0) + beta.slice(k).col(0) - ll(k));
}
#pragma omp parallel for if(obs.n_slices>=threads) schedule(static) num_threads(threads) \
default(none) shared(transition, obs, ll, alpha, beta, emission, ksii, gamma, nSymbols)
for (unsigned int k = 0; k < obs.n_slices; k++) {
if (obs.n_cols > 1) {
for (unsigned int j = 0; j < emission.n_rows; j++) {
for (unsigned int i = 0; i < emission.n_rows; i++) {
if (transition(i, j) > -arma::datum::inf) {
arma::vec tmpnm1(obs.n_cols - 1);
for (unsigned int t = 0; t < (obs.n_cols - 1); t++) {
tmpnm1(t) = alpha(i, t, k) + transition(i, j) + beta(j, t + 1, k);
for (unsigned int r = 0; r < obs.n_rows; r++) {
tmpnm1(t) += emission(j, obs(r, t + 1, k), r);
}
}
#pragma omp atomic
ksii(i, j) += exp(logSumExp(tmpnm1) - ll(k));
}
}
}
}
for (unsigned int r = 0; r < emission.n_slices; r++) {
for (unsigned int l = 0; l < nSymbols[r]; l++) {
for (unsigned int i = 0; i < emission.n_rows; i++) {
if (emission(i, l, r) > -arma::datum::inf) {
arma::vec tmpn(obs.n_cols);
for (unsigned int t = 0; t < obs.n_cols; t++) {
if (l == (obs(r, t, k))) {
tmpn(t) = alpha(i, t, k) + beta(i, t, k);
} else
tmpn(t) = -arma::datum::inf;
}
#pragma omp atomic
gamma(i, l, r) += exp(logSumExp(tmpn) - ll(k));
}
}
}
}
}
unsigned int error = log_optCoef(weights, obs, emission, initk, beta, ll, coef, X, cumsumstate,
numberOfStates, trace);
if (error != 0) {
return List::create(Named("error") = error);
}
if (obs.n_cols > 1) {
ksii.each_col() /= sum(ksii, 1);
transition = log(ksii);
}
for (unsigned int r = 0; r < emission.n_slices; r++) {
gamma.slice(r).cols(0, nSymbols(r) - 1).each_col() /= sum(
gamma.slice(r).cols(0, nSymbols(r) - 1), 1);
emission.slice(r).cols(0, nSymbols(r) - 1) = log(gamma.slice(r).cols(0, nSymbols(r) - 1));
}
for (unsigned int i = 0; i < numberOfStates.n_elem; i++) {
delta.subvec(cumsumstate(i) - numberOfStates(i), cumsumstate(i) - 1) /= arma::as_scalar(
arma::accu(delta.subvec(cumsumstate(i) - numberOfStates(i), cumsumstate(i) - 1)));
}
init = log(delta);
for (unsigned int k = 0; k < obs.n_slices; k++) {
initk.col(k) = init + reparma(weights.col(k), numberOfStates);
}
log_internalForwardx(transition, emission, initk, obs, alpha, threads);
log_internalBackward(transition, emission, obs, beta, threads);
for (unsigned int k = 0; k < obs.n_slices; k++) {
ll(k) = logSumExp(alpha.slice(k).col(obs.n_cols - 1));
}
double tmp = sum(ll);
change = (tmp - sumlogLik) / (std::abs(sumlogLik) + 0.1);
sumlogLik = tmp;
if (!arma::is_finite(sumlogLik)) {
return List::create(Named("error") = 6);
}
if (trace > 1) {
Rcout << "iter: " << iter;
Rcout << " logLik: " << sumlogLik;
Rcout << " relative change: " << change << std::endl;
}
}
if (trace > 0) {
if (iter == itermax) {
Rcpp::Rcout << "EM algorithm stopped after reaching the maximum number of " << iter
<< " iterations." << std::endl;
} else {
Rcpp::Rcout << "EM algorithm stopped after reaching the relative change of " << change;
Rcpp::Rcout << " after " << iter << " iterations." << std::endl;
}
Rcpp::Rcout << "Final log-likelihood: " << sumlogLik << std::endl;
}
return List::create(Named("coefficients") = wrap(coef), Named("initialProbs") = wrap(exp(init)),
Named("transitionMatrix") = wrap(exp(transition)),
Named("emissionArray") = wrap(exp(emission)), Named("logLik") = sumlogLik,
Named("iterations") = iter, Named("change") = change, Named("error") = 0);
}
RcppExport SEXP steepestDescent(SEXP YList1, SEXP n1, SEXP p1, SEXP r1,
SEXP mtype1,SEXP retraction1,
SEXP f1, SEXP f2,
SEXP control1){
BEGIN_RCPP
//Initialization of functions and control parameters
Function obej(f1);
Function grad(f2);
List control(control1);
IntegerVector retraction(retraction1);
int iterMax=as< int>(control["iterMax"]);
int iterSubMax=as< int>(control["iterSubMax"]);
double tol=as< double>(control["tol"]);
double sigma=as< double>(control["sigma"]);
double beta=as< double>(control["beta"]);
double alpha=as< double>(control["alpha"]);
// Initialization of Data points
IntegerVector n(n1),p(p1),r(r1);
CharacterVector mtype(mtype1);
int prodK=n.size();// size of product manifold
vector< manifold*> manifoldY;
int k;
List YList(YList1);
for(k=0;k<prodK;k++){
SEXP yTemp2=YList[k];
NumericMatrix yTemp(yTemp2);
std::string typeTemp=as< std::string>(mtype[k]);
if(typeTemp=="stiefel"){
manifoldY.push_back(new stiefel(n[k],p[k],r[k],
yTemp,retraction[k]));
}
else if(typeTemp=="grassmannQ"){
manifoldY.push_back(new grassmannQ(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="grassmannSub"){
manifoldY.push_back(new grassmannSub(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="fixedRank"){
manifoldY.push_back(new fixRank(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="fixedRankPSD"){
manifoldY.push_back(new fixRankPSD(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="elliptope"){
manifoldY.push_back(new elliptope(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="spectahedron"){
manifoldY.push_back(new spectahedron(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="sphere"){
manifoldY.push_back(new sphere(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="fixedRankSym"){
manifoldY.push_back(new fixRankSym(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="oblique"){
manifoldY.push_back(new oblique(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="specialLinear"){
manifoldY.push_back(new specialLinear(n[k],p[k],r[k],
yTemp,retraction[k]));
}else if(typeTemp=="projective"){
manifoldY.push_back(new projective(n[k],p[k],r[k],
yTemp,retraction[k]));
}
}
//define other varibles
int iter=0,iterInner=0; // outer loop, inner loop control
bool flag=true,first=true;
double objValue,objValue_temp,objValue_outer,eDescent,objDesc,stepsize;
//value of objective function
//eDescent: expected descent amount
//largest obj descent amount
// Function expm(f3);
arma::mat gradF; //gradient in ambient space
if(prodK>1){
objValue=as< double>(obej(YList));
}else{
objValue=as< double>(obej(YList[0]));
}
//begin iteration
while(iter<iterMax && flag){
//gradient of objective funtion
iter++;
objDesc=-1;
objValue_outer=objValue;
for(k=0;k<prodK;k++){
if(prodK>1){
gradF=as< arma::mat>(grad(YList,k+1));
}else{
gradF=as< arma::mat>(grad(YList[0]));
}
//gradient on the stiefel manifold
manifoldY[k]->evalGradient(gradF,"steepest");
stepsize=alpha/beta;
eDescent=sigma/beta*(manifoldY[k]->get_eDescent());
first=true;
iterInner=0;
do{//choose appropirate step size according to Armijo rule
iterInner++;
stepsize=stepsize*beta;
eDescent=eDescent*beta;
YList[k]=manifoldY[k]->retract(stepsize,"steepest",first);
if(prodK>1){
objValue_temp=as< double>(obej(YList));
}else{
objValue_temp=as< double>(obej(YList[0]));
}
first=false;
}while((objValue-objValue_temp)<eDescent && iterInner<iterSubMax);
//step size iteration
//if a stepsize is accepted, update current location
manifoldY[k]->acceptY();
objValue=objValue_temp;
}// iteration over product component
objDesc=objValue_outer-objValue;
if(tol>objDesc) flag=false;
}// outer iteration
return List::create(Named("optY")=YList,
Named("optValue")=objValue,
Named("NumIter")=iter);
END_RCPP
}//end of function
List EM(NumericVector transitionMatrix, NumericVector emissionArray, NumericVector initialProbs,
IntegerVector obsArray, const arma::ivec& nSymbols, int itermax, double tol, int trace, int threads) {
IntegerVector eDims = emissionArray.attr("dim"); //m,p,r
IntegerVector oDims = obsArray.attr("dim"); //k,n,r
arma::cube emission(emissionArray.begin(), eDims[0], eDims[1], eDims[2], true);
arma::icube obs(obsArray.begin(), oDims[0], oDims[1], oDims[2], false, true);
arma::vec init(initialProbs.begin(), emission.n_rows, true);
arma::mat transition(transitionMatrix.begin(), emission.n_rows, emission.n_rows, true);
arma::cube alpha(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k
arma::cube beta(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k
arma::mat scales(obs.n_cols, obs.n_slices);
internalForward(transition, emission, init, obs, alpha, scales, threads);
if(!scales.is_finite()) {
return List::create(Named("error") = 1);
}
double min_sf = scales.min();
if (min_sf < 1e-150) {
Rcpp::warning("Smallest scaling factor was %e, results can be numerically unstable.", min_sf);
}
internalBackward(transition, emission, obs, beta, scales, threads);
if(!beta.is_finite()) {
return List::create(Named("error") = 2);
}
arma::rowvec ll = arma::sum(log(scales));
double sumlogLik = sum(ll);
if (trace > 0) {
Rcout << "Log-likelihood of initial model: " << sumlogLik << std::endl;
}
//
// //EM-algorithm begins
//
double change = tol + 1.0;
int iter = 0;
while ((change > tol) & (iter < itermax)) {
iter++;
arma::mat ksii(emission.n_rows, emission.n_rows, arma::fill::zeros);
arma::cube gamma(emission.n_rows, emission.n_cols, emission.n_slices, arma::fill::zeros);
arma::vec delta(emission.n_rows, arma::fill::zeros);
for (unsigned int k = 0; k < obs.n_slices; k++) {
delta += alpha.slice(k).col(0) % beta.slice(k).col(0);
}
#pragma omp parallel for if(obs.n_slices>=threads) schedule(static) num_threads(threads) \
default(none) shared(transition, obs, alpha, beta, scales, \
emission, ksii, gamma, nSymbols)
for (int k = 0; k < obs.n_slices; k++) {
if (obs.n_cols > 1) {
for (unsigned int j = 0; j < emission.n_rows; j++) {
for (unsigned int i = 0; i < emission.n_rows; i++) {
if (transition(i, j) > 0.0) {
for (unsigned int t = 0; t < (obs.n_cols - 1); t++) {
double tmp = alpha(i, t, k) * transition(i, j) * beta(j, t + 1, k)
/ scales(t + 1, k);
for (unsigned int r = 0; r < obs.n_rows; r++) {
tmp *= emission(j, obs(r, t + 1, k), r);
}
#pragma omp atomic
ksii(i, j) += tmp;
}
}
}
}
}
for (unsigned int r = 0; r < emission.n_slices; r++) {
for (int l = 0; l < nSymbols(r); l++) {
for (unsigned int i = 0; i < emission.n_rows; i++) {
if (emission(i, l, r) > 0.0) {
for (unsigned int t = 0; t < obs.n_cols; t++) {
if (l == (obs(r, t, k))) {
#pragma omp atomic
gamma(i, l, r) += alpha(i, t, k) * beta(i, t, k);
}
}
}
}
}
}
}
if (obs.n_cols > 1) {
ksii.each_col() /= sum(ksii, 1);
transition = ksii;
}
for (unsigned int r = 0; r < emission.n_slices; r++) {
gamma.slice(r).cols(0, nSymbols(r) - 1).each_col() /= sum(
gamma.slice(r).cols(0, nSymbols(r) - 1), 1);
emission.slice(r).cols(0, nSymbols(r) - 1) = gamma.slice(r).cols(0, nSymbols(r) - 1);
}
delta /= arma::as_scalar(arma::accu(delta));
init = delta;
internalForward(transition, emission, init, obs, alpha, scales, threads);
if(!scales.is_finite()) {
return List::create(Named("error") = 1);
}
internalBackward(transition, emission, obs, beta, scales, threads);
if(!beta.is_finite()) {
return List::create(Named("error") = 2);
}
double min_sf = scales.min();
if (min_sf < 1e-150) {
Rcpp::warning("Smallest scaling factor was %e, results can be numerically unstable.", min_sf);
}
ll = sum(log(scales));
double tmp = sum(ll);
change = (tmp - sumlogLik) / (std::abs(sumlogLik) + 0.1);
sumlogLik = tmp;
if (trace > 1) {
Rcout << "iter: " << iter;
Rcout << " logLik: " << sumlogLik;
Rcout << " relative change: " << change << std::endl;
}
}
if (trace > 0) {
if (iter == itermax) {
Rcpp::Rcout << "EM algorithm stopped after reaching the maximum number of " << iter
<< " iterations." << std::endl;
} else {
Rcpp::Rcout << "EM algorithm stopped after reaching the relative change of " << change;
Rcpp::Rcout << " after " << iter << " iterations." << std::endl;
}
Rcpp::Rcout << "Final log-likelihood: " << sumlogLik << std::endl;
}
return List::create(Named("initialProbs") = wrap(init),
Named("transitionMatrix") = wrap(transition), Named("emissionArray") = wrap(emission),
Named("logLik") = sumlogLik, Named("iterations") = iter, Named("change") = change, Named("error") = 0);
}
RcppExport SEXP xbrlProcessContexts(SEXP epaDoc) {
xmlDocPtr doc = (xmlDocPtr) R_ExternalPtrAddr(epaDoc);
xmlXPathContextPtr context = xmlXPathNewContext(doc);
xmlXPathObjectPtr context_res = xmlXPathEvalExpression((xmlChar*) "//*[local-name()='context']", context);
xmlNodeSetPtr context_nodeset = context_res->nodesetval;
int context_nodeset_ln = context_nodeset->nodeNr;
xmlXPathFreeContext(context);
CharacterVector contextId(context_nodeset_ln);
CharacterVector scheme(context_nodeset_ln);
CharacterVector identifier(context_nodeset_ln);
CharacterVector startDate(context_nodeset_ln);
CharacterVector endDate(context_nodeset_ln);
CharacterVector dimension1(context_nodeset_ln);
CharacterVector value1(context_nodeset_ln);
CharacterVector dimension2(context_nodeset_ln);
CharacterVector value2(context_nodeset_ln);
CharacterVector dimension3(context_nodeset_ln);
CharacterVector value3(context_nodeset_ln);
CharacterVector dimension4(context_nodeset_ln);
CharacterVector value4(context_nodeset_ln);
for (int i=0; i < context_nodeset_ln; i++) {
xmlNodePtr context_node = context_nodeset->nodeTab[i];
xmlChar *tmp_str;
if ((tmp_str = xmlGetProp(context_node, (xmlChar*) "id"))) {
contextId[i] = (char *) tmp_str;
xmlFree(tmp_str);
} else {
contextId[i] = NA_STRING;
}
scheme[i] = identifier[i] = startDate[i] = endDate[i] =
dimension1[i] = value1[i] = dimension2[i] = value2[i] =
dimension3[i] = value3[i] = dimension4[i] = value4[i] = NA_STRING;
xmlNodePtr child_node = context_node->xmlChildrenNode;
while (child_node) {
if (!xmlStrcmp(child_node->name, (xmlChar*) "entity")) {
xmlNodePtr gchild_node = child_node->xmlChildrenNode;
while (gchild_node) {
if (!xmlStrcmp(gchild_node->name, (xmlChar*) "identifier")) {
if ((tmp_str = xmlGetProp(gchild_node, (xmlChar*) "scheme"))) {
scheme[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
if ((tmp_str = xmlNodeListGetString(doc, gchild_node->xmlChildrenNode, 1))) {
identifier[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
} else if (!xmlStrcmp(gchild_node->name, (xmlChar*) "segment")) {
xmlNodePtr ggchild_node = gchild_node->xmlChildrenNode;
int dimn = 1;
while (ggchild_node) {
if (!xmlStrcmp(ggchild_node->name, (xmlChar*) "explicitMember")) {
if ((tmp_str = xmlGetProp(ggchild_node, (xmlChar*) "dimension"))) {
if (dimn == 1)
dimension1[i] = (char *) tmp_str;
else if (dimn == 2)
dimension2[i] = (char *) tmp_str;
else if (dimn == 3)
dimension3[i] = (char *) tmp_str;
else if (dimn == 4)
dimension4[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
if ((tmp_str = xmlNodeListGetString(doc, ggchild_node->xmlChildrenNode, 1))) {
if (dimn == 1)
value1[i] = (char *) tmp_str;
else if (dimn == 2)
value2[i] = (char *) tmp_str;
else if (dimn == 3)
value3[i] = (char *) tmp_str;
else if (dimn == 4)
value4[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
dimn++;
}
ggchild_node = ggchild_node->next;
}
}
gchild_node = gchild_node->next;
}
} else if (!xmlStrcmp(child_node->name, (xmlChar*) "period")) {
xmlNodePtr gchild_node = child_node->xmlChildrenNode;
while (gchild_node) {
if (!xmlStrcmp(gchild_node->name, (xmlChar*) "startDate")) {
if ((tmp_str = xmlNodeListGetString(doc, gchild_node->xmlChildrenNode, 1))) {
startDate[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
} else if (!xmlStrcmp(gchild_node->name, (xmlChar*) "endDate")) {
if ((tmp_str = xmlNodeListGetString(doc, gchild_node->xmlChildrenNode, 1))) {
endDate[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
} else if (!xmlStrcmp(gchild_node->name, (xmlChar*) "instant")) {
if ((tmp_str = xmlNodeListGetString(doc, gchild_node->xmlChildrenNode, 1))) {
endDate[i] = (char *) tmp_str;
xmlFree(tmp_str);
}
}
gchild_node = gchild_node->next;
}
}
child_node = child_node->next;
}
}
xmlXPathFreeObject(context_res);
return DataFrame::create(Named("contextId")=contextId,
Named("scheme")=scheme,
Named("identifier")=identifier,
Named("startDate")=startDate,
Named("endDate")=endDate,
Named("dimension1")=dimension1,
Named("value1")=value1,
Named("dimension2")=dimension2,
Named("value2")=value2,
Named("dimension3")=dimension3,
Named("value3")=value3,
Named("dimension4")=dimension4,
Named("value4")=value4);
}
// [[Rcpp::export]]
List rnegbinRw_rcpp_loop(vec const& y, mat const& X, vec const& betabar, mat const& rootA, double a, double b,
vec beta, double alpha, bool fixalpha,
mat const& betaroot, double alphacroot, int R, int keep, int nprint){
// Keunwoo Kim 11/02/2014
// Arguments:
// Data
// X is nobs X nvar matrix
// y is nobs vector
// Prior - list containing the prior parameters
// betabar, rootA - mean of beta prior, chol-root of inverse of variance covariance of beta prior
// a, b - parameters of alpha prior
// Mcmc - list containing
// R is number of draws
// keep is thinning parameter (def = 1)
// nprint - print estimated time remaining on every nprint'th draw (def = 100)
// betaroot - step size for beta RW
// alphacroot - step size for alpha RW
// beta - initial guesses for beta
// alpha - initial guess for alpha
// fixalpha - if TRUE, fix alpha and draw only beta
//
// Output:
//
// Model:
// (y|lambda,alpha) ~ Negative Binomial(Mean = lambda, Overdispersion par = alpha)
// ln(lambda) = X * beta
//
// Prior:
// beta ~ N(betabar, A^-1)
// alpha ~ Gamma(a,b) where mean = a/b and variance = a/(b^2)
//
vec betac;
double ldiff, acc, unif, logalphac, oldlpostalpha, oldlpostbeta, clpostbeta, clpostalpha;
int mkeep, rep;
int nvar = X.n_cols;
int nacceptbeta = 0;
int nacceptalpha = 0;
vec alphadraw(R/keep);
mat betadraw(R/keep, nvar);
if (nprint>0) startMcmcTimer();
//start main iteration loop
for (rep=0; rep<R; rep++){
// Draw beta
betac = beta + betaroot*vec(rnorm(nvar));
oldlpostbeta = lpostbeta(alpha, beta, X, y, betabar, rootA);
clpostbeta = lpostbeta(alpha, betac, X, y, betabar, rootA);
ldiff = clpostbeta - oldlpostbeta;
acc = exp(ldiff);
if (acc > 1) acc = 1;
if(acc < 1) {unif=runif(1)[0];} else {unif=0;} //runif returns a NumericVector, so using [0] allows for conversion to double by extracting the first element
if (unif <= acc){
beta = betac;
nacceptbeta = nacceptbeta + 1;
}
// Draw alpha
if (!fixalpha){
logalphac = log(alpha) + alphacroot*rnorm(1)[0]; //rnorm returns a NumericVector, so using [0] allows for conversion to double
oldlpostalpha = lpostalpha(alpha, beta, X, y, a, b);
clpostalpha = lpostalpha(exp(logalphac), beta, X, y, a, b);
ldiff = clpostalpha - oldlpostalpha;
acc = exp(ldiff);
if (acc > 1) acc = 1;
if(acc < 1) {unif=runif(1)[0];} else {unif=0;} //runif returns a NumericVector, so using [0] allows for conversion to double by extracting the first element
if (unif <= acc){
alpha = exp(logalphac);
nacceptalpha = nacceptalpha + 1;
}
}
if (nprint>0) if ((rep+1)%nprint==0) infoMcmcTimer(rep, R);
if((rep+1)%keep==0){
mkeep = (rep+1)/keep;
betadraw(mkeep-1, span::all) = trans(beta);
alphadraw[mkeep-1] = alpha;
}
}
if (nprint>0) endMcmcTimer();
return List::create(
Named("betadraw") = betadraw,
Named("alphadraw") = alphadraw,
Named("nacceptbeta") = nacceptbeta,
Named("nacceptalpha") = nacceptalpha);
}
RcppExport SEXP bbivDPM(SEXP arg1, SEXP arg2, SEXP arg3) {
// 3 arguments
// arg1 for parameters
// arg2 for data
// arg3 for Gibbs
// data
List list2(arg2);
const MatrixXd X=as< Map<MatrixXd> >(list2["X"]),
Z=as< Map<MatrixXd> >(list2["Z"]);
const VectorXi v1=as< Map<VectorXi> >(list2["tbin"]),
v2=as< Map<VectorXi> >(list2["ybin"]);
const int N=X.rows(), p=X.cols(), q=Z.cols(), r=p+q, s=p+r;
#ifdef DEBUG_NEAL8
List P, Phi, B;
VectorXi S, one;
one.setConstant(N, 1);
#endif
// parameters
List list1(arg1),
beta_info=list1["beta"],
rho_info=list1["rho"],
mu_info=list1["mu"],
theta_info=list1["theta"],
dpm_info=list1["dpm"], // DPM
alpha_info=dpm_info["alpha"], // alpha random
alpha_prior; // alpha random
const int m=as<int>(dpm_info["m"]); // DPM
// const double alpha=as<double>(dpm_info["alpha"]); // DPM
const int alpha_fixed=as<int>(alpha_info["fixed"]); // alpha random
double alpha=as<double>(alpha_info["init"]); // alpha random
if(alpha_fixed==0) alpha_prior=alpha_info["prior"]; // alpha random
VectorXi C=as< Map<VectorXi> >(dpm_info["C"]),
states=as< Map<VectorXi> >(dpm_info["states"]);
/* checks done in neal8
if(states.sum()!=N || C.size()!=N) { // limited reality check of C and states
C.setConstant(N, 0);
states.setConstant(1, N);
}
*/
// prior parameters
List beta_prior=beta_info["prior"],
// no prior parameters for rho
dpm_prior=dpm_info["prior"],
theta_prior=theta_info["prior"];
const double beta_prior_mean=as<double>(beta_prior["mean"]);
const double beta_prior_prec=as<double>(beta_prior["prec"]);
const VectorXd theta_prior_mean=as< Map<VectorXd> >(theta_prior["mean"]);
const MatrixXd theta_prior_prec=as< Map<MatrixXd> >(theta_prior["prec"]);
// initialize parameters
double beta =as<double>(beta_info["init"]);
double rho_init=as<double>(rho_info["init"]); // DPM
//int rho_MH =as<int>(rho_info["MH"]);
Vector2d mu_init=as< Map<VectorXd> >(mu_info["init"]); // DPM
VectorXd theta =as< Map<VectorXd> >(theta_info["init"]);
VectorXd rho(N); // DPM
/*
VectorXi C, states; // DPM
C.setConstant(N, 0); // DPM
states.setConstant(1, N); // DPM
*/
MatrixXd mu(N, 2), phi(1, 3); // DPM
phi(0, 0)=mu_init[0]; // DPM
phi(0, 1)=mu_init[1]; // DPM
phi(0, 2)=rho_init; // DPM
// Gibbs
List list3(arg3);
const int burnin=as<int>(list3["burnin"]), M=as<int>(list3["M"]),
thin=as<int>(list3["thin"]);
VectorXi quadrant(N);
VectorXd t(N), y(N); // latents
// prior parameter intermediate values
double beta_prior_prod=beta_prior_prec * beta_prior_mean;
VectorXd theta_prior_prod=theta_prior_prec * theta_prior_mean;
Matrix2d Sigma, Tprec, B_inverse;
B_inverse.setIdentity();
VectorXd gamma=theta.segment(0, p),
delta=theta.segment(p, q),
eta =theta.segment(r, p);
MatrixXd eps(N, 2), D(N, 2), theta_cond_var_root(s, s), W(2, s), A(N, r+4); // DPM semi
W.setZero();
MatrixXd theta_cond_prec(s, s);
VectorXd theta_cond_prod(s), w(r), mu_t(N), mu_y(N), sd_y(N);
Vector2d u, R, mu_u; // DPM
double beta_prec, beta_prod, beta_cond_var, beta_cond_mean, beta2; // DPM
int h=0, i, l;
List GS(M); //DPM
// assign quadrants
for(i=0; i<N; ++i) {
if(v1[i]==0 && v2[i]==0) quadrant[i] = 3;
else if(v1[i]==0 && v2[i]==1) quadrant[i] = 2;
else if(v1[i]==1 && v2[i]==0) quadrant[i] = 4;
else if(v1[i]==1 && v2[i]==1) quadrant[i] = 1;
}
// Gibbs loop
//for(int l=-burnin; l<=(M-1)*thin; ++l) {
l=-burnin;
do{
// populate mu/rho //DPM
for(i=0; i<N; ++i) {
mu(i, 0)=phi(C[i], 0);
mu(i, 1)=phi(C[i], 1);
rho[i]=phi(C[i], 2);
mu_t[i]=mu(i, 0);
mu_y[i]=mu(i, 1);
}
// generate latents
// mu_t = mu.col(0); //DPM
mu_t += (Z*delta + X*gamma);
// mu_y = mu.col(1); //DPM
mu_y += (beta*mu_t + X*eta);
beta2=pow(beta, 2.);
for(i=0; i<N; ++i) {
sd_y[i] = sqrt(beta2+2.*beta*rho[i]+1.); //DPM
mu_u[0]=mu_t[i];
mu_u[1]=mu_y[i]/sd_y[i]; //DPM
// z, quadrant, rho, burnin
u=rbvtruncnorm(mu_u, quadrant[i], (beta+rho[i])/sd_y[i], 10);
t[i]=u[0];
y[i]=sd_y[i]*u[1];
}
// sample beta
D.col(0) = (t - mu.col(0) - X*gamma - Z*delta); //DPM
D.col(1) = (y - mu.col(1) - X*eta); //DPM
beta_prec=0.;
beta_prod=0.;
for(i=0; i<N; ++i) {
double Sigma_det=1.-pow(rho[i], 2.); //DPM
beta_prec += pow(t[i], 2.)/Sigma_det; //DPM
beta_prod += -t[i]*(rho[i]*D(i, 0)-D(i, 1))/Sigma_det; //DPM
}
beta_cond_var=1./(beta_prec+beta_prior_prec);
beta_cond_mean=beta_cond_var*(beta_prod+beta_prior_prod);
beta=rnorm1d(beta_cond_mean, sqrt(beta_cond_var));
B_inverse(1, 0)=-beta;
// sample theta
theta_cond_prec=theta_prior_prec;
theta_cond_prod=theta_prior_prod;
for(i=0; i<N; ++i) {
double Sigma_det=1.-pow(rho[i], 2.); //DPM
Tprec(0, 0)=1./Sigma_det; Tprec(0, 1)=-rho[i]/Sigma_det; //DPM
Tprec(1, 0)=-rho[i]/Sigma_det; Tprec(1, 1)=1./Sigma_det; //DPM
mu_u[0]=mu(i, 0); //DPM
mu_u[1]=mu(i, 1); //DPM
W.block(0, 0, 1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.block(1, r, 1, p)=X.row(i);
theta_cond_prec += (W.transpose() * Tprec * W);
u[0]=t[i];
u[1]=y[i];
R=B_inverse*u-mu_u; //DPM
theta_cond_prod += (W.transpose() * Tprec * R);
}
theta_cond_var_root=inv_root_chol(theta_cond_prec);
theta=theta_cond_var_root*(rnormXd(s)+theta_cond_var_root.transpose()*theta_cond_prod);
gamma=theta.segment(0, p);
delta=theta.segment(p, q);
eta =theta.segment(r, p);
// sample mu and rho
// this for block should be placed in P0
// however, to keep changes minimal, we keep it here
for(i=0; i<N; ++i) {
W.block(0, 0, 1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.block(1, r, 1, p)=X.row(i);
u[0]=t[i];
u[1]=y[i];
eps.row(i) = (B_inverse*u - W*theta).transpose(); //DPM
}
/* semi block begins */
A.block(0, 0, N, 2)=eps;
A.col(2)=t;
A.col(3)=y;
A.block(0, 4, N, p)=X;
A.block(0, p+4, N, q)=Z;
List psi=List::create(Named("mu0")=as< Map<VectorXd> >(dpm_prior["mu0"]),
Named("T0")=as< Map<MatrixXd> >(dpm_prior["T0"]),
Named("S0")=as< Map<MatrixXd> >(dpm_prior["S0"]),
Named("beta")=beta,
Named("gamma")=gamma,
Named("delta")=delta,
Named("eta")=eta);
if(alpha_fixed==0)
alpha=bbiv_alpha(states.size(), N, alpha, alpha_prior); // alpha random
List dpm_step=neal8(A, C, phi, states, m, alpha, psi,
&bbivF, &bbivG0, &bbivP0);
/* semi block end */
/*
C=as< Map<VectorXi> >(dpm_step[0]);
phi=as< Map<MatrixXd> >(dpm_step[1]);
states=as< Map<VectorXi> >(dpm_step[2]);
*/
C=as< Map<VectorXi> >(dpm_step["C"]);
phi=as< Map<MatrixXd> >(dpm_step["phi"]);
states=as< Map<VectorXi> >(dpm_step["states"]);
#ifdef DEBUG_NEAL8
S=as< Map<VectorXi> >(dpm_step["S"]);
P=dpm_step["P"];
Phi=dpm_step["Phi"];
B=dpm_step["B"];
#endif
if(l>=0 && l%thin == 0) {
h = (l/thin);
#ifdef DEBUG_NEAL8
GS[h]=List::create(Named("beta")=beta, Named("theta")=theta,
Named("C")=C+one, Named("phi")=phi,
Named("states")=states, Named("alpha")=alpha,
Named("S")=S+one, Named("P")=P,
Named("Phi")=Phi, Named("B")=B);
#else
if(alpha_fixed==0) // alpha random
GS[h]=List::create(Named("beta")=beta, Named("theta")=theta,
Named("C")=C, Named("phi")=phi,
Named("states")=states, Named("alpha")=alpha);
else GS[h]=List::create(Named("beta")=beta, Named("theta")=theta,
Named("C")=C, Named("phi")=phi, Named("states")=states);
#endif
// GS[h]=List::create(Named("beta")=beta, Named("theta")=theta,
// Named("C")=C, Named("phi")=phi, Named("states")=states,
// Named("m")=m, Named("alpha")=alpha, Named("psi")=psi);
}
l++;
} while (l<=(M-1)*thin);
return wrap(GS);
}
List objectivex(const arma::mat& transition, NumericVector emissionArray,
const arma::vec& init, IntegerVector obsArray, const arma::imat& ANZ,
IntegerVector emissNZ, const arma::ivec& INZ, const arma::ivec& nSymbols,
const arma::mat& coef, const arma::mat& X, arma::ivec& numberOfStates,
int threads) {
IntegerVector eDims = emissionArray.attr("dim"); //m,p,r
IntegerVector oDims = obsArray.attr("dim"); //k,n,r
arma::cube emission(emissionArray.begin(), eDims[0], eDims[1], eDims[2], false, true);
arma::icube obs(obsArray.begin(), oDims[0], oDims[1], oDims[2], false, true);
arma::icube BNZ(emissNZ.begin(), emission.n_rows, emission.n_cols - 1, emission.n_slices, false, true);
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::math::inf());
return List::create(Named("objective") = arma::math::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::cube alpha(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k
arma::cube beta(emission.n_rows, obs.n_cols, obs.n_slices); //m,n,k
arma::mat scales(obs.n_cols, obs.n_slices); //m,n,k
arma::sp_mat sp_trans(transition);
internalForwardx(sp_trans.t(), emission, initk, obs, alpha, scales, threads);
if (!scales.is_finite()) {
grad.fill(-arma::math::inf());
return List::create(Named("objective") = arma::math::inf(), Named("gradient") = wrap(grad));
}
internalBackwardx(sp_trans, emission, obs, beta, scales, threads);
if (!beta.is_finite()) {
grad.fill(-arma::math::inf());
return List::create(Named("objective") = arma::math::inf(), Named("gradient") = wrap(grad));
}
arma::ivec cumsumstate = arma::cumsum(numberOfStates);
arma::mat gradmat(
arma::accu(ANZ) + arma::accu(BNZ) + arma::accu(INZ) + (numberOfStates.n_elem- 1) * q,
obs.n_slices, arma::fill::zeros);
#pragma omp parallel for if(obs.n_slices >= threads) schedule(static) num_threads(threads) \
default(none) shared(q, alpha, beta, scales, gradmat, nSymbols, ANZ, BNZ, INZ, \
numberOfStates, cumsumstate, obs, init, initk, X, weights, transition, emission)
for (int k = 0; k < obs.n_slices; k++) {
int countgrad = 0;
// transitionMatrix
if (arma::accu(ANZ) > 0) {
for (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 (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 (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, k);
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, k) / scales(t + 1, k);
}
}
gradArow = gradA * gradArow;
gradmat.col(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 (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, k) / scales(0, k);
}
for (unsigned int t = 0; t < (obs.n_cols - 1); t++) {
if (obs(r, t + 1, k) == j) {
double tmp = beta(i, t + 1, k) / scales(t + 1, k);
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.slice(k).col(t), transition.col(i)) * tmp;
}
}
}
gradBrow = gradB * gradBrow;
gradmat.col(k).subvec(countgrad, countgrad + ind.n_elem - 1) = gradBrow.rows(ind);
countgrad += ind.n_elem;
}
}
}
}
if (arma::accu(INZ) > 0) {
for (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 (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, k) / scales(0, k);
}
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;
gradmat.col(k).subvec(countgrad, countgrad + ind.n_elem - 1) = gradIrow.rows(ind);
countgrad += ind.n_elem;
}
}
}
for (int jj = 1; jj < numberOfStates.n_elem; jj++) {
int ind_jj = (cumsumstate(jj) - numberOfStates(jj));
for (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))) {
gradmat.col(k).subvec(countgrad + q * (jj - 1), countgrad + q * jj - 1) += tmp
* beta(j, 0, k) / scales(0, k) * initk(j, k) * X.row(k).t() * (1.0 - weights(jj, k));
} else {
gradmat.col(k).subvec(countgrad + q * (jj - 1), countgrad + q * jj - 1) -= tmp
* beta(j, 0, k) / scales(0, k) * initk(j, k) * X.row(k).t() * weights(jj, k);
}
}
}
}
return List::create(Named("objective") = -arma::accu(log(scales)),
Named("gradient") = wrap(-sum(gradmat, 1)));
}
//[[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));
}
}
// [[Rcpp::export]]
List buildCellList( CharacterVector r, CharacterVector t, CharacterVector v) {
//Valid combinations
// r t v
// T F F
// T T T
// F F F
// T F T (must be a formula)
int n = r.size();
List cells(n);
LogicalVector hasV = !is_na(v);
LogicalVector hasR = !is_na(r);
LogicalVector hasT = !is_na(t);
for(int i=0; i < n; i++){
if(hasR[i]){
if(hasV[i]){
if(hasT[i]){
// r t v
// T T T (2)
cells[i] = CharacterVector::create(
Named("r") = r[i],
Named("t") = t[i],
Named("v") = v[i],
Named("f") = NA_STRING);
}else{
// r t f
// T T T (4 - formula)
cells[i] = CharacterVector::create(
Named("r") = r[i],
Named("t") = "str",
Named("v") = NA_STRING,
Named("f") = "<f>" + v[i] + "</f>");
}
}else{
// r t v
// T F F (1)
cells[i] = CharacterVector::create(
Named("r") = r[i],
Named("t") = NA_STRING,
Named("v") = NA_STRING,
Named("f") = NA_STRING);
}
}else{
// r t v
// F F F (3)
cells[i] = CharacterVector::create(
Named("r") = NA_STRING,
Named("t") = NA_STRING,
Named("v") = NA_STRING,
Named("f") = NA_STRING);
}
} // end of for loop
return wrap(cells) ;
}
