// [[Rcpp::export]]
double lhoodcpp(SEXP eta,
SEXP beta,
SEXP doc_ct,
SEXP mu,
SEXP siginv){
Rcpp::NumericVector etav(eta);
arma::vec etas(etav.begin(), etav.size(), false);
Rcpp::NumericMatrix betam(beta);
arma::mat betas(betam.begin(), betam.nrow(), betam.ncol(), false);
Rcpp::NumericVector doc_ctv(doc_ct);
arma::vec doc_cts(doc_ctv.begin(), doc_ctv.size(), false);
Rcpp::NumericVector muv(mu);
arma::vec mus(muv.begin(), muv.size(), false);
Rcpp::NumericMatrix siginvm(siginv);
arma::mat siginvs(siginvm.begin(), siginvm.nrow(), siginvm.ncol(), false);
arma::rowvec expeta(etas.size()+1);
expeta.fill(1);
int neta = etav.size();
for(int j=0; j <neta; j++){
expeta(j) = exp(etas(j));
}
double ndoc = sum(doc_cts);
double part1 = arma::as_scalar(log(expeta*betas)*doc_cts - ndoc*log(sum(expeta)));
arma::vec diff = etas - mus;
double part2 = .5*arma::as_scalar(diff.t()*siginvs*diff);
double out = part2 - part1;
return out;
}
// [[Rcpp::export]]
arma::vec gradcpp(SEXP eta,
SEXP beta,
SEXP doc_ct,
SEXP mu,
SEXP siginv){
Rcpp::NumericVector etav(eta);
arma::vec etas(etav.begin(), etav.size(), false);
Rcpp::NumericMatrix betam(beta);
arma::mat betas(betam.begin(), betam.nrow(), betam.ncol());
Rcpp::NumericVector doc_ctv(doc_ct);
arma::vec doc_cts(doc_ctv.begin(), doc_ctv.size(), false);
Rcpp::NumericVector muv(mu);
arma::vec mus(muv.begin(), muv.size(), false);
Rcpp::NumericMatrix siginvm(siginv);
arma::mat siginvs(siginvm.begin(), siginvm.nrow(), siginvm.ncol(), false);
arma::colvec expeta(etas.size()+1);
expeta.fill(1);
int neta = etas.size();
for(int j=0; j <neta; j++){
expeta(j) = exp(etas(j));
}
betas.each_col() %= expeta;
arma::vec part1 = betas*(doc_cts/arma::trans(sum(betas,0))) - (sum(doc_cts)/sum(expeta))*expeta;
arma::vec part2 = siginvs*(etas - mus);
part1.shed_row(neta);
return part2-part1;
}
void write_tasks(transport::repository<>& repo, transport::step_mpi<>* model)
{
const double M_P = 1.0;
const double m = 1E-5 * M_P;
const double c = 0.0018;
const double d = 0.022 * M_P;
const double phi0 = 14.84 * M_P;
const double phi_init = 16.5 * M_P;
const double N_init = 0.0;
const double N_pre = 6.0;
const double N_max = 50.1;
transport::parameters<> params(M_P, { m, c, d, phi0 }, model);
transport::initial_conditions<> ics("step", params, { phi_init }, N_init, N_pre);
transport::basic_range<> times(N_init, N_max, 100, transport::spacing::linear);
transport::basic_range<> ks(exp(7.0), exp(11.5), 1000, transport::spacing::log_bottom);
transport::basic_range<> alphas(0.0, 0.0, 0, transport::spacing::linear);
transport::basic_range<> betas(1.0/3.0, 1.0/3.0, 0, transport::spacing::linear);
// construct a threepf task
transport::threepf_alphabeta_task<> tk3("step.threepf", ics, times, ks, alphas, betas);
tk3.set_collect_initial_conditions(true).set_adaptive_ics_efolds(5.0);
transport::zeta_threepf_task<> ztk3("step.threepf-zeta", tk3);
repo.commit(ztk3);
}
Rcpp::List HDP::save_state(){
Rcpp::NumericMatrix doc_states(save_doc_states());
Rcpp::NumericMatrix wods_state(hdp_state_->save_words_count_by_topic());
Rcpp::NumericVector betas(hdp_state_->save_betas());
return Rcpp::List::create(Rcpp::Named("topicPerDoc")= doc_states,
Rcpp::Named("wordsPerTopic")=wods_state,
Rcpp::Named("Betas")=betas);
}
// [[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);
}
// [[Rcpp::export]]
SEXP hpbcpp(SEXP eta,
SEXP beta,
SEXP doc_ct,
SEXP mu,
SEXP siginv,
SEXP sigmaentropy){
Rcpp::NumericVector etav(eta);
arma::vec etas(etav.begin(), etav.size(), false);
Rcpp::NumericMatrix betam(beta);
arma::mat betas(betam.begin(), betam.nrow(), betam.ncol());
Rcpp::NumericVector doc_ctv(doc_ct);
arma::vec doc_cts(doc_ctv.begin(), doc_ctv.size(), false);
Rcpp::NumericVector muv(mu);
arma::vec mus(muv.begin(), muv.size(), false);
Rcpp::NumericMatrix siginvm(siginv);
arma::mat siginvs(siginvm.begin(), siginvm.nrow(), siginvm.ncol(), false);
Rcpp::NumericVector sigmaentropym(sigmaentropy);
arma::vec entropy(sigmaentropym);
//Performance Nots from 3/6/2015
// I tried a few different variants and benchmarked this one as roughly twice as
// fast as the R code for a K=100 problem. Key to performance was not creating
// too many objects and being selective in how things were flagged as triangular.
// Some additional notes in the code below.
//
// Some things this doesn't have or I haven't tried
// - I didn't tweak the arguments much. sigmaentropy is a double, and I'm still
// passing beta in the same way. I tried doing a ", false" for beta but it didn't
// change much so I left it the same as in gradient.
// - I tried treating the factors for doc_cts and colSums(EB) as a diagonal matrix- much slower.
// Haven't Tried/Done
// - each_row() might be much slower (not sure but arma is column order). Maybe transpose in place?
// - depending on costs there are some really minor calculations that could be precomputed:
// - sum(doc_ct)
// - sqrt(doc_ct)
// More on passing by reference here:
// - Hypothetically we could alter beta (because hessian is last thing we do) however down
// the road we may want to explore treating nonPD hessians by optimization at which point
// we would need it again.
arma::colvec expeta(etas.size()+1);
expeta.fill(1);
int neta = etas.size();
for(int j=0; j <neta; j++){
expeta(j) = exp(etas(j));
}
arma::vec theta = expeta/sum(expeta);
//create a new version of the matrix so we can mess with it
arma::mat EB(betam.begin(), betam.nrow(), betam.ncol());
//multiply each column by expeta
EB.each_col() %= expeta; //this should be fastest as its column-major ordering
//divide out by the column sums
EB.each_row() %= arma::trans(sqrt(doc_cts))/sum(EB,0);
//Combine the pieces of the Hessian which are matrices
arma::mat hess = EB*EB.t() - sum(doc_cts)*(theta*theta.t());
//we don't need EB any more so we turn it into phi
EB.each_row() %= arma::trans(sqrt(doc_cts));
//Now alter just the diagonal of the Hessian
hess.diag() -= sum(EB,1) - sum(doc_cts)*theta;
//Drop the last row and column
hess.shed_row(neta);
hess.shed_col(neta);
//Now we can add in siginv
hess = hess + siginvs;
//At this point the Hessian is complete.
//This next bit of code is from http://arma.sourceforge.net/docs.html#logging
//It basically keeps arma from printing errors from chol to the console.
std::ostream nullstream(0);
arma::set_stream_err2(nullstream);
////
//Invert via cholesky decomposition
////
//Start by initializing an object
arma::mat nu = arma::mat(hess.n_rows, hess.n_rows);
//This version of chol generates a boolean which tells us if it failed.
bool worked = arma::chol(nu,hess);
if(!worked) {
//It failed! Oh Nos.
// So the matrix wasn't positive definite. In practice this means that it hasn't
// converged probably along some minor aspect of the dimension.
//Here we make it positive definite through diagonal dominance
arma::vec dvec = hess.diag();
//find the magnitude of the diagonal
arma::vec magnitudes = sum(abs(hess), 1) - abs(dvec);
//iterate over each row and set the minimum value of the diagonal to be the magnitude of the other terms
int Km1 = dvec.size();
for(int j=0; j < Km1; j++){
if(arma::as_scalar(dvec(j)) < arma::as_scalar(magnitudes(j))) dvec(j) = magnitudes(j); //enforce diagonal dominance
}
//overwrite the diagonal of the hessian with our new object
hess.diag() = dvec;
//that was sufficient to ensure positive definiteness so we now do cholesky
nu = arma::chol(hess);
}
//compute 1/2 the determinant from the cholesky decomposition
double detTerm = -sum(log(nu.diag()));
//Now finish constructing nu
nu = arma::inv(arma::trimatu(nu));
nu = nu * nu.t(); //trimatu doesn't do anything for multiplication so it would just be timesink to signal here.
//Precompute the difference since we use it twice
arma::vec diff = etas - mus;
//Now generate the bound and make it a scalar
double bound = arma::as_scalar(log(arma::trans(theta)*betas)*doc_cts + detTerm - .5*diff.t()*siginvs*diff - entropy);
// Generate a return list that mimics the R output
return Rcpp::List::create(
Rcpp::Named("phis") = EB,
Rcpp::Named("eta") = Rcpp::List::create(Rcpp::Named("lambda")=etas, Rcpp::Named("nu")=nu),
Rcpp::Named("bound") = bound
);
}
SwaptionVolCube1::Cube
SwaptionVolCube1::sabrCalibration(const Cube& marketVolCube) const {
const std::vector<Time>& optionTimes = marketVolCube.optionTimes();
const std::vector<Time>& swapLengths = marketVolCube.swapLengths();
const std::vector<Date>& optionDates = marketVolCube.optionDates();
const std::vector<Period>& swapTenors = marketVolCube.swapTenors();
Matrix alphas(optionTimes.size(), swapLengths.size(),0.);
Matrix betas(alphas);
Matrix nus(alphas);
Matrix rhos(alphas);
Matrix forwards(alphas);
Matrix errors(alphas);
Matrix maxErrors(alphas);
Matrix endCriteria(alphas);
const std::vector<Matrix>& tmpMarketVolCube = marketVolCube.points();
std::vector<Real> strikes(strikeSpreads_.size());
std::vector<Real> volatilities(strikeSpreads_.size());
for (Size j=0; j<optionTimes.size(); j++) {
for (Size k=0; k<swapLengths.size(); k++) {
Rate atmForward = atmStrike(optionDates[j], swapTenors[k]);
strikes.clear();
volatilities.clear();
for (Size i=0; i<nStrikes_; i++){
Real strike = atmForward+strikeSpreads_[i];
if(strike>=MINSTRIKE) {
strikes.push_back(strike);
volatilities.push_back(tmpMarketVolCube[i][j][k]);
}
}
const std::vector<Real>& guess = parametersGuess_.operator()(
optionTimes[j], swapLengths[k]);
const boost::shared_ptr<SABRInterpolation> sabrInterpolation =
boost::shared_ptr<SABRInterpolation>(new
SABRInterpolation(strikes.begin(), strikes.end(),
volatilities.begin(),
optionTimes[j], atmForward,
guess[0], guess[1],
guess[2], guess[3],
isParameterFixed_[0],
isParameterFixed_[1],
isParameterFixed_[2],
isParameterFixed_[3],
vegaWeightedSmileFit_,
endCriteria_,
optMethod_,
errorAccept_,
useMaxError_,
maxGuesses_));
sabrInterpolation->update();
Real rmsError = sabrInterpolation->rmsError();
Real maxError = sabrInterpolation->maxError();
alphas [j][k] = sabrInterpolation->alpha();
betas [j][k] = sabrInterpolation->beta();
nus [j][k] = sabrInterpolation->nu();
rhos [j][k] = sabrInterpolation->rho();
forwards [j][k] = atmForward;
errors [j][k] = rmsError;
maxErrors [j][k] = maxError;
endCriteria[j][k] = sabrInterpolation->endCriteria();
QL_ENSURE(endCriteria[j][k]!=EndCriteria::MaxIterations,
"global swaptions calibration failed: "
"MaxIterations reached: " << "\n" <<
"option maturity = " << optionDates[j] << ", \n" <<
"swap tenor = " << swapTenors[k] << ", \n" <<
"error = " << io::rate(errors[j][k]) << ", \n" <<
"max error = " << io::rate(maxErrors[j][k]) << ", \n" <<
" alpha = " << alphas[j][k] << "n" <<
" beta = " << betas[j][k] << "\n" <<
" nu = " << nus[j][k] << "\n" <<
" rho = " << rhos[j][k] << "\n"
);
QL_ENSURE(useMaxError_ ? maxError : rmsError < maxErrorTolerance_,
"global swaptions calibration failed: "
"option tenor " << optionDates[j] <<
", swap tenor " << swapTenors[k] <<
(useMaxError_ ? ": max error " : ": error") <<
(useMaxError_ ? maxError : rmsError) <<
" alpha = " << alphas[j][k] << "n" <<
" beta = " << betas[j][k] << "\n" <<
" nu = " << nus[j][k] << "\n" <<
" rho = " << rhos[j][k] << "\n" <<
(useMaxError_ ? ": error" : ": max error ") <<
(useMaxError_ ? rmsError :maxError)
);
}
}
Cube sabrParametersCube(optionDates, swapTenors,
optionTimes, swapLengths, 8);
sabrParametersCube.setLayer(0, alphas);
sabrParametersCube.setLayer(1, betas);
sabrParametersCube.setLayer(2, nus);
sabrParametersCube.setLayer(3, rhos);
sabrParametersCube.setLayer(4, forwards);
sabrParametersCube.setLayer(5, errors);
sabrParametersCube.setLayer(6, maxErrors);
sabrParametersCube.setLayer(7, endCriteria);
return sabrParametersCube;
}
