// Execute a single coordinate ascent update to maximize the variational
// lower bound for Bayesian variable selection in linear regression.
//
// [[Rcpp::export]]
void varbvsnormupdate_rcpp (const NumericMatrix& X, double sigma, double sa,
const NumericVector& logodds,
const NumericVector& xy, const NumericVector& d,
NumericVector& alpha, NumericVector& mu,
NumericVector& Xr, const IntegerVector& i) {
// Cycle through the coordinate ascent updates.
for (int iter = 0; iter < i.size(); iter++) {
// j is the coordinate we update in this iteration.
int j = i[iter];
// Compute the variational estimate of the posterior variance.
double s = sa*sigma/(sa*d[j] + 1);
// Update the variational estimate of the posterior mean.
double r = alpha[j] * mu[j];
mu[j] = s/sigma*(xy[j] + d[j]*r - sum(X.column(j) * Xr));
// Update the variational estimate of the posterior inclusion probability.
alpha[j] = sigmoid_rcpp(logodds[j] + (log(s/(sa*sigma)) +
mu[j]*mu[j]/s)/2);
// Update Xr = X*r.
Xr = Xr + (alpha[j] * mu[j] - r) * X.column(j);
}
}
// [[Rcpp::export]]
List runit_Row_Column_sugar( NumericMatrix x){
NumericVector r0 = x.row(0) ;
NumericVector c0 = x.column(0) ;
return List::create(
r0,
c0,
x.row(1),
x.column(1),
x.row(1) + x.column(1)
) ;
}
// [[Rcpp::export]]
List softmaxUnitCpp(NumericMatrix input)
{
int nrows = input.nrow();
int ncols = input.ncol();
NumericMatrix activations = transpose(input);
NumericMatrix derivatives(Dimension(ncols, nrows));
for (int i = 0; i < nrows; i++)
{
activations(_, i) = exp(activations.column(i) - max(activations.column(i)));
activations(_, i) = activations.column(i) / sum(activations.column(i));
derivatives(_, i) = activations.column(i) * (1 - activations.column(i));
}
return List::create(transpose(activations), transpose(derivatives));
}
// for multiple markers, but only for one traits input, for multiple traits using version 2 or
// cc <- lapply(all[c(2,3)], function(x) mylm(x,marker3))
// [[Rcpp::export]]
List mylm(NumericVector y, NumericMatrix x){
//int n = x.size(); //for a list
int n = x.ncol();
List out(n);
for(int i = 0; i < n; ++i) {
//NumericMatrix m1 = add1(x[i], y);
NumericMatrix m1 = add1(x(_,i), y);
NumericMatrix mm = wrap(cleanmat(m1)); //wrap for arma::mat to Rcpp::NumericMatrix
int m = mm.nrow();
// seems x.column(i) and x(_,i) can both extract columns
NumericVector y2 = mm.column(0);
NumericMatrix x2 (m, 2);
x2(_,0) = mm.column(1); x2(_,1) = mm.column(2);
out[i] = fastLm1(y2, x2);
//out[i] = x2;
}
return out;
}
// [[Rcpp::export]]
NumericMatrix runit_NumericMatrix_cumsum( NumericMatrix input ){
int nr = input.nrow(), nc = input.ncol() ;
NumericMatrix output(nr, nc) ;
NumericVector tmp( nr );
for( int i=0; i<nc; i++){
tmp = tmp + input.column(i) ;
NumericMatrix::Column target( output, i ) ;
std::copy( tmp.begin(), tmp.end(), target.begin() ) ;
}
return output ;
}
// [[Rcpp::export]]
List sigmoidUnitCpp(NumericMatrix input)
{
int nrows = input.nrow();
int ncols = input.ncol();
NumericMatrix activations(Dimension(nrows, ncols));
NumericMatrix derivatives(Dimension(nrows, ncols));
for (int i = 0; i < ncols; i++)
{
activations(_, i) = 1/(1 + exp(-input.column(i)));
derivatives(_, i) = activations.column(i) * (1 - activations.column(i));
}
return List::create(activations, derivatives);
}
NumericMatrix col_erase (NumericMatrix& x, IntegerVector& colID) {
colID = colID.sort();
NumericMatrix x2(Dimension(x.nrow(), x.ncol()- colID.size()));
int iter = 0;
int del = 1;
for (int i = 0; i < x.ncol(); i++) {
if (i != colID[del - 1]) {
x2.column(iter) = x.column(i);
iter++;
} else {
del++;
}
}
return x2;
}
// [[Rcpp::export]]
double runit_NumericMatrix_column( NumericMatrix m ){
NumericMatrix::Column col = m.column(0) ;
return std::accumulate( col.begin(), col.end(), 0.0 ) ;
}
// [[Rcpp::export]]
List cxxMixEM(NumericMatrix matrix_lik, NumericVector prior, NumericVector pi_init, double tol=0.0001, int maxiter=5000){//note: no default pi_init=NULL
int n=matrix_lik.nrow(), k=matrix_lik.ncol(), j=0;
bool converged=NA_LOGICAL;
NumericVector pi(k);
if(Rf_isNull(pi_init))
std::fill(pi.begin(), pi.end(), 1./(double)k);
else{
pi=clone(pi_init);
for (int i=0;i<k;i++)//set any estimates that are very small to be very small
pi[i]=std::max(1e-5, pi[i]);
pi=pi/sum(pi); //normalize pi
}
NumericMatrix m(n,k);
NumericVector m_rowsum(n);
NumericMatrix classprob(m);
std::vector<double> loglik, lpriordens, penloglik;
loglik.reserve(maxiter);
lpriordens.reserve(maxiter);
penloglik.reserve(maxiter);
for (int i=0;i<k;i++){
m.column(i)=pi[i]*matrix_lik.column(i);
m_rowsum=m_rowsum+m.column(i);
}
for (int i=0;i<k;i++)//can vectorize this with sugar?
classprob.column(i)=classprob.column(i)/m_rowsum;
loglik.push_back(sum(log(m_rowsum)));
lpriordens.push_back(sum((prior-1.)*log(pi)));
penloglik.push_back(sum(log(m_rowsum)) + sum((prior-1.)*log(pi)));
for(j=1;j<maxiter;j++){
//update pi
//to do: can vectorize this with sugar?
for (int i=0;i<k;i++)//set any estimates that are less than zero, which can happen with prior<1, to 0
pi[i]=std::max(1e-5, sum(classprob.column(i))+prior[i]-1.);
pi=pi/sum(pi); //normalize pi
//Now re-estimate pi
std::fill(m_rowsum.begin(), m_rowsum.end(), 0);
for (int i=0;i<k;i++){
m.column(i)=pi[i]*matrix_lik.column(i);
m_rowsum=m_rowsum+m.column(i);
}
for (int i=0;i<k;i++)
classprob.column(i)=classprob.column(i)/m_rowsum;
loglik.push_back(sum(log(m_rowsum)));
lpriordens.push_back(sum((prior-1.)*log(pi)));
penloglik.push_back(sum(log(m_rowsum)) + sum((prior-1.)*log(pi)));
converged=(bool) (std::abs(loglik[j]+lpriordens[j]-loglik[j-1]-lpriordens[j-1])<tol);
if(converged)
break;
}
if (j==maxiter)
j-=1;
return(List::create(Named("pihat")=pi,
Named("B")=loglik,
Named("penloglik")=penloglik,
Named("niter")=wrap(j+1),
Named("converged")=wrap(converged)));
}
// [[Rcpp::export]]
NumericMatrix viterbi_ths(NumericVector &theta, NumericMatrix &data,
NumericVector &integrControl) {
// theta lambda0, lambda1, lambda2, sigma, p
// data diff of t and x
int n = data.nrow(); int dim = data.ncol() - 1;
double lambda0 = theta[0], lambda1 = theta[1], lambda2 = theta[2];
double p = theta[4];
if (lambda1 < lambda2) return NA_REAL;
double ps0 = 1. / lambda0 / (1. / lambda0 + p / lambda1 + (1 - p) / lambda2);
double ps1 = p / lambda1 / (1. / lambda0 + p / lambda1 + (1 - p) / lambda2);
double ps2 = (1 - p) / lambda2 / (1. / lambda0 + p / lambda1 + (1 - p) / lambda2);
NumericVector tt = data.column(0);
NumericMatrix x = data(Range(0, n - 1), Range(1, dim));
// result matrix: three cols stand for Viterbi prob of state 0,1,2
// at current time points. For numerical reason,
// the log-prob is returned.
NumericMatrix result(n + 1, 3);
result(0, 0) = log(ps0); result(0, 1) = log(ps1); result(0, 2) = log(ps2);
NumericVector cartV = result.row(0);
NumericVector cartW(3);
// calculate all h functions
NumericVector
hresult00 = ths_h00(x, tt, theta, integrControl),
hresult01 = ths_h01(x, tt, theta, integrControl),
hresult02 = ths_h02(x, tt, theta, integrControl),
hresult10 = ths_h10(x, tt, theta, integrControl),
hresult11 = ths_h11(x, tt, theta, integrControl),
hresult12 = ths_h12(x, tt, theta, integrControl),
hresult20 = ths_h20(x, tt, theta, integrControl),
hresult21 = ths_h21(x, tt, theta, integrControl),
hresult22 = ths_h22(x, tt, theta, integrControl);
for (int i = 0; i < n; i++) {
NumericVector crow = x.row(i);
if (is_true(all(crow == 0.))) {
hresult00[i] = 0.;
hresult01[i] = 0.;
hresult02[i] = 0.;
hresult10[i] = 0.;
hresult11[i] = exp(-lambda1 * tt[i]);
hresult12[i] = 0.;
hresult20[i] = 0.;
hresult21[i] = 0.;
hresult22[i] = exp(-lambda2 * tt[i]);
}
}
// calculate Viterbi path
for (int i = 1; i <= n; i++) {
cartW[0] = cartV[0] + log(hresult00[i - 1]);
cartW[1] = cartV[1] + log(hresult10[i - 1]);
cartW[2] = cartV[2] + log(hresult20[i - 1]);
result(i, 0) = max(cartW);
cartW[0] = cartV[0] + log(hresult01[i - 1]);
cartW[1] = cartV[1] + log(hresult11[i - 1]);
cartW[2] = cartV[2] + log(hresult21[i - 1]);
result(i, 1) = max(cartW);
cartW[0] = cartV[0] + log(hresult02[i - 1]);
cartW[1] = cartV[1] + log(hresult12[i - 1]);
cartW[2] = cartV[2] + log(hresult22[i - 1]);
result(i, 2) = max(cartW);
cartV = result.row(i);
}
return result;
}
// [[Rcpp::export]]
NumericMatrix partial_viterbi_ths(NumericVector &theta, NumericMatrix &data,
NumericVector &integrControl,
int &startpoint, int &pathlength){
// theta lambda0, lambda1, lambda2, sigma, p
// data diff of t and x
// startpoint the start time point, note that
// the first time point in data is t0
// pathlength the length of partial viterbi path
int n = data.nrow(); int dim = data.ncol() - 1;
double lambda0 = theta[0], lambda1 = theta[1], lambda2 = theta[2];
double p = theta[4];
double ps0 = 1. / lambda0 / (1. / lambda0 + p / lambda1 + (1 - p) / lambda2);
double ps1 = p / lambda1 / (1. / lambda0 + p / lambda1 + (1 - p) / lambda2);
double ps2 = (1 - p) / lambda2 / (1. / lambda0 + p / lambda1 + (1 - p) / lambda2);
NumericVector tt = data.column(0);
NumericMatrix x = data(Range(0, n - 1), Range(1, dim));
// bf_result matrix: frist three col for forward
// last three col for backward
NumericMatrix bf_result(n + 1, 6);
bf_result(0, 0) = ps0; bf_result(0, 1) = ps1; bf_result(0, 2) = ps2;
bf_result(n, 3) = 1; bf_result(n, 4) = 1; bf_result(n, 5) = 1;
NumericVector dx(n);
// result matrix: three cols stand for Viterbi prob of state 0,1,2
// at current time points. For numerical reason,
// the log-prob is returned.
NumericMatrix result(pathlength, 3);
NumericVector cartV(3);
NumericVector cartW(3);
// calculate all h functions
NumericVector
hresult00 = ths_h00(x, tt, theta, integrControl),
hresult01 = ths_h01(x, tt, theta, integrControl),
hresult02 = ths_h02(x, tt, theta, integrControl),
hresult10 = ths_h10(x, tt, theta, integrControl),
hresult11 = ths_h11(x, tt, theta, integrControl),
hresult12 = ths_h12(x, tt, theta, integrControl),
hresult20 = ths_h20(x, tt, theta, integrControl),
hresult21 = ths_h21(x, tt, theta, integrControl),
hresult22 = ths_h22(x, tt, theta, integrControl);
for (int i = 0; i < n; i++) {
NumericVector crow = x.row(i);
if (is_true(all(crow == 0.))) {
hresult00[i] = 0.;
hresult01[i] = 0.;
hresult02[i] = 0.;
hresult10[i] = 0.;
hresult11[i] = exp(-lambda1 * tt[i]);
hresult12[i] = 0.;
hresult20[i] = 0.;
hresult21[i] = 0.;
hresult22[i] = exp(-lambda2 * tt[i]);
}
}
// forward algorithm
for (int i = 0; i < n; i++) {
double sumf0 = bf_result(i, 0) * hresult00[i] + bf_result(i, 1) * hresult10[i] + bf_result(i, 2) * hresult20[i];
double sumf1 = bf_result(i, 0) * hresult01[i] + bf_result(i, 1) * hresult11[i] + bf_result(i, 2) * hresult21[i];
double sumf2 = bf_result(i, 0) * hresult02[i] + bf_result(i, 1) * hresult12[i] + bf_result(i, 2) * hresult22[i];
dx[i] = sumf0 + sumf1 + sumf2;
bf_result(i + 1, 0) = sumf0 / dx[i];
bf_result(i + 1, 1) = sumf1 / dx[i];
bf_result(i + 1, 2) = sumf2 / dx[i];
}
// backward algorithm
for (int i = 0; i < n; i++) {
double sumb0 = bf_result(n-i, 3) * hresult00[n-i-1] + bf_result(n-i, 4) * hresult01[n-i-1] + bf_result(n-i, 5) * hresult02[n-i-1];
double sumb1 = bf_result(n-i, 3) * hresult10[n-i-1] + bf_result(n-i, 4) * hresult11[n-i-1] + bf_result(n-i, 5) * hresult12[n-i-1];
double sumb2 = bf_result(n-i, 3) * hresult20[n-i-1] + bf_result(n-i, 4) * hresult21[n-i-1] + bf_result(n-i, 5) * hresult22[n-i-1];
bf_result(n-i-1, 3) = sumb0 / dx[n-i-1];
bf_result(n-i-1, 4) = sumb1 / dx[n-i-1];
bf_result(n-i-1, 5) = sumb2 / dx[n-i-1];
}
// prepare for viterbi path
result(0, 0) = log(bf_result(startpoint, 0));
result(0, 1) = log(bf_result(startpoint, 1));
result(0, 2) = log(bf_result(startpoint, 2));
cartV = result.row(0);
int ite_stop = startpoint + pathlength - 2;
// viterbi algorithm
for (int i = startpoint; i < ite_stop; i++) {
cartW[0] = cartV[0] + log(hresult00[i]);
cartW[1] = cartV[1] + log(hresult10[i]);
cartW[2] = cartV[2] + log(hresult20[i]);
result(i - startpoint + 1, 0) = max(cartW);
cartW[0] = cartV[0] + log(hresult01[i]);
cartW[1] = cartV[1] + log(hresult11[i]);
cartW[2] = cartV[2] + log(hresult21[i]);
result(i - startpoint + 1, 1) = max(cartW);
cartW[0] = cartV[0] + log(hresult02[i]);
cartW[1] = cartV[1] + log(hresult12[i]);
cartW[2] = cartV[2] + log(hresult22[i]);
result(i - startpoint + 1, 2) = max(cartW);
cartV = result.row(i - startpoint + 1);
}
// last step of viterbi algorithm
cartW[0] = cartV[0] + log(hresult00[ite_stop]) + log(bf_result(ite_stop + 1, 3));
cartW[1] = cartV[1] + log(hresult10[ite_stop]) + log(bf_result(ite_stop + 1, 3));
cartW[2] = cartV[2] + log(hresult20[ite_stop]) + log(bf_result(ite_stop + 1, 3));
result(pathlength - 1, 0) = max(cartW);
cartW[0] = cartV[0] + log(hresult01[ite_stop]) + log(bf_result(ite_stop + 1, 4));
cartW[1] = cartV[1] + log(hresult11[ite_stop]) + log(bf_result(ite_stop + 1, 4));
cartW[2] = cartV[2] + log(hresult21[ite_stop]) + log(bf_result(ite_stop + 1, 4));
result(pathlength - 1, 1) = max(cartW);
cartW[0] = cartV[0] + log(hresult02[ite_stop]) + log(bf_result(ite_stop + 1, 5));
cartW[1] = cartV[1] + log(hresult12[ite_stop]) + log(bf_result(ite_stop + 1, 5));
cartW[2] = cartV[2] + log(hresult22[ite_stop]) + log(bf_result(ite_stop + 1, 5));
result(pathlength - 1, 2) = max(cartW);
return result;
}
// [[Rcpp::export]]
NumericMatrix fwd_bwd_ths(NumericVector &theta, NumericMatrix &data,
NumericVector &integrControl) {
// theta lambda0, lambda1, lambda2, sigma, p
// data diff of t and x
int n = data.nrow(); int dim = data.ncol() - 1;
double lambda0 = theta[0], lambda1 = theta[1], lambda2 = theta[2];
double p = theta[4];
if (lambda1 < lambda2) return NA_REAL;
double ps0 = 1. / lambda0 / (1. / lambda0 + p / lambda1 + (1 - p) / lambda2);
double ps1 = p / lambda1 / (1. / lambda0 + p / lambda1 + (1 - p) / lambda2);
double ps2 = (1 - p) / lambda2 / (1. / lambda0 + p / lambda1 + (1 - p) / lambda2);
NumericVector tt = data.column(0);
NumericMatrix x = data(Range(0, n - 1), Range(1, dim));
// result matrix: frist three col for forward
// last three col for backward
NumericMatrix result(n + 1, 6);
result(0, 0) = ps0; result(0, 1) = ps1; result(0, 2) = ps2;
result(n, 3) = 1; result(n, 4) = 1; result(n, 5) = 1;
NumericVector dx(n);
// calculate all h functions
NumericVector
hresult00 = ths_h00(x, tt, theta, integrControl),
hresult01 = ths_h01(x, tt, theta, integrControl),
hresult02 = ths_h02(x, tt, theta, integrControl),
hresult10 = ths_h10(x, tt, theta, integrControl),
hresult11 = ths_h11(x, tt, theta, integrControl),
hresult12 = ths_h12(x, tt, theta, integrControl),
hresult20 = ths_h20(x, tt, theta, integrControl),
hresult21 = ths_h21(x, tt, theta, integrControl),
hresult22 = ths_h22(x, tt, theta, integrControl);
for (int i = 0; i < n; i++) {
NumericVector crow = x.row(i);
if (is_true(all(crow == 0.))) {
hresult00[i] = 0.;
hresult01[i] = 0.;
hresult02[i] = 0.;
hresult10[i] = 0.;
hresult11[i] = exp(-lambda1 * tt[i]);
hresult12[i] = 0.;
hresult20[i] = 0.;
hresult21[i] = 0.;
hresult22[i] = exp(-lambda2 * tt[i]);
}
}
// forward algorithm
for (int i = 0; i < n; i++) {
double sumf0 = result(i, 0) * hresult00[i] + result(i, 1) * hresult10[i] + result(i, 2) * hresult20[i];
double sumf1 = result(i, 0) * hresult01[i] + result(i, 1) * hresult11[i] + result(i, 2) * hresult21[i];
double sumf2 = result(i, 0) * hresult02[i] + result(i, 1) * hresult12[i] + result(i, 2) * hresult22[i];
dx[i] = sumf0 + sumf1 + sumf2;
result(i + 1, 0) = sumf0 / dx[i];
result(i + 1, 1) = sumf1 / dx[i];
result(i + 1, 2) = sumf2 / dx[i];
}
//backward algorithm
for (int i = 0; i < n; i++) {
double sumb0 = result(n-i, 3) * hresult00[n-i-1] + result(n-i, 4) * hresult01[n-i-1] + result(n-i, 5) * hresult02[n-i-1];
double sumb1 = result(n-i, 3) * hresult10[n-i-1] + result(n-i, 4) * hresult11[n-i-1] + result(n-i, 5) * hresult12[n-i-1];
double sumb2 = result(n-i, 3) * hresult20[n-i-1] + result(n-i, 4) * hresult21[n-i-1] + result(n-i, 5) * hresult22[n-i-1];
result(n-i-1, 3) = sumb0 / dx[n-i-1];
result(n-i-1, 4) = sumb1 / dx[n-i-1];
result(n-i-1, 5) = sumb2 / dx[n-i-1];
}
return result;
}
//' Viterbi algorithm
//'
//' Standard viterbi algorithm in the log space
//' @param initP matrix of initial probabilities: each column corresponds to a sequence
//' @param trans transition matrix (rows are previous state, columns are next state)
//' @param lliks matrix with emission probabilities for each datapoint and each state.
//' Columns are datapoints and rows are states.
//' @param seqlens length of each subsequence of datapoints (set this to ncol(lliks)
//' if there is only one sequence).
//' @return a list with the following arguments:
//' \item{vpath}{viterbi path}
//' \item{vllik}{log-likelihood of the viterbi path}
//' @export
// [[Rcpp::export]]
List viterbi(NumericMatrix initP, NumericMatrix trans, NumericMatrix lliks, NumericVector seqlens){
int nmod = initP.nrow();
double totlen = Rcpp::sum(seqlens);
if (nmod != trans.nrow() || nmod != trans.ncol() || nmod != lliks.nrow()) Rcpp::stop("Unable to figure out the number of models");
if (((double) lliks.ncol()) != totlen) Rcpp::stop("Sequence lengths don't match with the provided matrix");
int ncol = lliks.ncol();
IntegerVector vpath(ncol);
IntegerMatrix backtrack(nmod, max(seqlens));
std::vector<long double> scores(nmod);
std::vector<long double> new_scores(nmod);
/* log-transform the transition probabilities */
NumericMatrix ltrans(nmod,nmod);
for (diter curr = ltrans.begin(), currt = trans.begin(); curr < ltrans.end(); ++curr, ++currt){
*curr = log(*currt);
}
/* Viterbi independently on each chunk */
double tot_maxscore = 0;
for (int o = 0, chunk_start = 0; o < seqlens.length(); chunk_start += seqlens[o], ++o){
int chunk_end = chunk_start + seqlens[o];
/* dynamic programming */
{
MatrixColumn<REALSXP> llikcol = lliks.column(chunk_start);
MatrixColumn<REALSXP> curr_initP = initP.column(o);
for (int t = 0; t < nmod; ++t){
scores[t] = llikcol[t] + log(curr_initP[t]);
}
}
for (int i = chunk_start + 1; i < chunk_end; ++i){
MatrixColumn<REALSXP> llikcol = lliks.column(i);
MatrixColumn<INTSXP> backtrackcol = backtrack.column(i-chunk_start);
for (int t = 0; t < nmod; ++t){
int maxs = 0;
long double maxscore = scores[0] + ltrans(0, t);
for (int s = 1; s < nmod; ++s){
long double currscore = scores[s] + ltrans(s,t);
if (currscore > maxscore){
maxscore = currscore;
maxs = s;
}
}
backtrackcol[t] = maxs;
new_scores[t] = llikcol[t] + maxscore;
}
memcpy(scores.data(), new_scores.data(), sizeof(long double)*nmod);
}
/* backtracking */
int maxp = 0;
double maxscore = scores[0];
for (int p = 1; p < nmod; ++p){
if (scores[p] > maxscore){
maxscore = scores[p];
maxp = p;
}
}
tot_maxscore += maxscore;
vpath[chunk_end - 1] = maxp + 1;
for (int i = chunk_end - 2; i >= chunk_start; --i){
maxp = backtrack(maxp, i - chunk_start + 1);
vpath[i] = maxp + 1; //in R indices are 1-based
}
}
return List::create(_("vpath")=vpath, _("vllik")=tot_maxscore);
}
