NumericVector inclusionProb(const NumericVector& prob, const int& size) {
// prob ... vector of initial probability weights
// size ... sample size
// check initial result
int i; // index for loops
int nneg = 0; // number of negative values
int N = prob.size(); // number of observations
double sum = 0.0; // sum of probability weights
NumericVector result(N); // inclusion probabilities
for(i = 0; i < N; i++) {
if(prob[i] < 0.0) {
result[i] = 0.0; // set negative values to 0
nneg++; // count negative values
} else {
result[i] = prob[i];
if(prob[i] > 0.0) {
sum += prob[i]; // add current element to sum
}
}
}
if(nneg > 0) warning("negative probability weights are set to 0");
// compute inclusion probabilities
if(sum > 0.0) {
int ngeq1 = 0; // number of values >= 1
for(i = 0; i < N; i++) {
if(result[i] > 0.0) {
result[i] = result[i] * size / sum; // initial adjustment
if(result[i] >= 1.0) ngeq1++; // count values >= 1
}
}
// values >= 1 are set to 1 and the others are readjusted
if(ngeq1 > 0) {
int nset = 0; // ???
// I think this results in an infinite loop
while(ngeq1 != nset) {
// compute sum of values less than 1
sum = 0.0; // reset sum
for(i = 0; i < N; i++) {
if(result[i] > 0.0 && result[i] < 1.0) {
sum += result[i]; // add current element to sum
}
}
// readjust values
if(sum > 0.0) {
for(i = 0; i < N; i++) {
if(result[i] > 0.0 && result[i] < 1.0) {
result[i] = result[i] * (size-ngeq1) / sum;
}
}
}
nset = ngeq1;
// recount values >= 1 and set them to 1
ngeq1 = 0;
for(i = 0; i < N; i++) {
if(result[i] >= 1.0) {
result[i] = 1.0;
ngeq1++; // count values >= 1
}
}
}
}
}
return result;
}
// [[Rcpp::export]]
double sample_beta_scalar(NumericVector y, List x, NumericMatrix groups,
NumericMatrix beta, List gamma, NumericVector delta,
NumericMatrix z, double alpha, double sigma2,
List bs_beta, double s2_beta, int p_id, int k_id) {
double out;
NumericVector params(2);
double sum_term = 0.0;
double sum_term2 = 0.0;
double sum_term2a = 0.0;
double sum_term2b = 0.0;
double sum_term3 = 0.0;
double sum_term4 = 0.0;
NumericMatrix x_tmp = x(k_id);
NumericMatrix bs_beta_tmp = bs_beta(k_id);
for (int i = 0; i < y.size(); i++) {
double term = 0.0;
for (int j = 0; j < x_tmp.ncol(); j++) {
term += bs_beta_tmp(j, p_id) * x_tmp(i, j);
}
sum_term += term * term;
sum_term2 += y[i] * term;
sum_term2a += alpha * term;
for (int k = 0; k < z.ncol(); k++) {
sum_term2b += term * delta[k] * z(i, k);
}
for (int q = 0; q < gamma.size(); q++) {
NumericVector gamma_q = gamma[q];
int group_set = groups(i, q);
sum_term3 += gamma_q[group_set] * term;
}
for (int k2 = 0; k2 < beta.nrow(); k2++) {
NumericMatrix bs_beta_k = bs_beta[k2];
NumericMatrix x_k = x[k2];
if (k2 != k_id) {
for (int s = 0; s < beta.ncol(); s++) {
for (int j = 0; j < x_k.ncol(); j++) {
sum_term4 += term * beta(k2, s) * bs_beta_k(j, s) * x_k(i, j);
}
}
} else {
for (int s = 0; s < beta.ncol(); s++) {
if (s != p_id) {
for (int j = 0; j < x_k.ncol(); j++) {
sum_term4 += term * beta(k2, s) * bs_beta_k(j, s) * x_k(i, j);
}
}
}
}
}
}
//Calculate params[1]
params[1] = (sigma2 * s2_beta) / (s2_beta * sum_term + sigma2);
//Calculate params[0]
params[0] = params[1] * (-1.0 / (2.0 * sigma2)) * (-2.0 * sum_term2 + 2.0 * sum_term2a +
2.0 * sum_term2b + 2.0 * sum_term4 +
2.0 * sum_term3);
//Calculate loglik
out = rnorm(1, params[0], sqrt(params[1]))[0];
return out;
}
// [[Rcpp::export]]
List naive_cluster(NumericVector D, IntegerVector K, double threshold) {
int M = K.size();
std::vector<std::vector<int> > result(M);
std::vector<std::vector<double> > result_distances(M);
std::vector<pair_dist> dst(D.size());
std::map<int, std::set<topic_index> > clusters;
// initialization
int c = 0;
for (int m = 0; m < M; ++m) {
result[m].resize(K[m]);
result_distances[m].resize(K[m]);
for (int k = 0; k < K[m]; ++k) {
result[m][k] = c;
clusters[c].insert(topic_index(m, k));
++c;
}
}
// brute force: we'll just write down which index in D
// corresponds to which pair of topics, copying over D like space
// is cheap or something. D is assumed to go block-by-block row-wise
// along a block-upper-triangular matrix whose (I, J) block is the
// K_I x K_J matrix of distances between topics in models I and J.
// Within each block D runs rowwise along the block.
// Zero blocks are omitted.
int d = 0; // runs along D
for (int m1 = 0; m1 < M - 1; ++m1) {
for (int m2 = m1 + 1; m2 < M; ++m2) {
for (int k1 = 0; k1 < K[m1]; ++k1) {
for (int k2 = 0; k2 < K[m2]; ++k2) {
if (d >= dst.size()) {
stop("The length of D is not consistent with K");
}
dst[d].d = D[d];
dst[d].t1.first = m1;
dst[d].t1.second = k1;
dst[d].t2.first = m2;
dst[d].t2.second = k2;
d += 1;
}
}
}
}
if (d != D.size()) {
stop("The length of D is not consistent with K");
}
pair_dist_cmp pdc;
std::sort(dst.begin(), dst.end(), pdc);
int r1, r2;
std::set<int> sect;
bool allow;
for (std::vector<pair_dist>::iterator d = dst.begin();
d != dst.end(); ++d) {
if (d->d > threshold) { // then we're done
break;
}
#ifdef __NAIVE_CLUSTER_LOG__
Rcout << d->t1.first << " ";
Rcout << d->t1.second << " | ";
Rcout << d->t2.first << " ";
Rcout << d->t2.second << " [";
Rcout << d->d << "]";
#endif
// get current cluster assignments
r1 = result[d->t1.first][d->t1.second];
r2 = result[d->t2.first][d->t2.second];
if (r1 == r2) {
#ifdef __NAIVE_CLUSTER_LOG__
Rcout << "...already merged." << std::endl;
#endif
continue; // they're already merged
}
if (r1 > r2) {
std::swap(r1, r2); // guarantee r1 < r2
}
std::set<topic_index> &c1 = clusters[r1];
std::set<topic_index> &c2 = clusters[r2];
if (c1.size() == M || c2.size() == M) {
// if either cluster is full, merge is impossible
#ifdef __NAIVE_CLUSTER_LOG__
Rcout << "...cluster full." << std::endl;
#endif
continue;
}
// Check whether the two clusters share topics from the same model
sect.clear();
allow = true;
#ifdef __NAIVE_CLUSTER_LOG__
Rcout << " c1 " << "(" << r1 << "):";
#endif
for (std::set<topic_index>::iterator t = c1.begin();
t != c1.end(); ++t) {
#ifdef __NAIVE_CLUSTER_LOG__
Rcout << " " << t->first;
#endif
sect.insert(t->first);
}
#ifdef __NAIVE_CLUSTER_LOG__
Rcout << " c2:" << "(" << r2 << "):";
#endif
for (std::set<topic_index>::iterator t = c2.begin();
t != c2.end() && allow; ++t) {
// if same model: cluster disallowed
#ifdef __NAIVE_CLUSTER_LOG__
Rcout << " " << t->first;
#endif
allow = (sect.count(t->first) == 0);
}
if (!allow) {
#ifdef __NAIVE_CLUSTER_LOG__
Rcout << "...disallowed." << std::endl;
#endif
continue;
}
#ifdef __NAIVE_CLUSTER_LOG__
Rcout << "...merge." << std::endl;
#endif
// otherwise: merge
for (std::set<topic_index>::iterator t = c2.begin();
t != c2.end(); ++t) {
c1.insert(*t);
result[t->first][t->second] = r1;
result_distances[t->first][t->second] = d->d;
}
clusters.erase(r2); // also deletes the associated set object
}
return List::create(
_["clusters"] = wrap(result),
_["distances"] = wrap(result_distances)
);
}
// [[Rcpp::export]]
List SDP_single_foreq(int tmax, NumericVector res_bs, int cons_bs, int xc, NumericVector rep_gain,
NumericMatrix f_m, NumericVector mort, List dec_ls, NumericVector rho_vec, NumericMatrix c_learn,
NumericVector g_forage, NumericVector c_forage, List W_nr, List istar_nr, int N_init, int tsim,
double alpha, double beta, double comp) {
//Note:
//Here, state variables are in standard format
double xc_state = (double) xc; //state
//To use a state variable X as an INDEX, it must be an INTEGER, and X=X-1
xc = xc - 1; //Index
//Book-keeping
//Establish iniital variables required for the SDP
int num_res = res_bs.size();
//How many decisions? Count columns on first decision matrix
NumericMatrix dec_ex = dec_ls(0);
//int num_dec = dec_ex.ncol();
int max_enc = f_m.nrow(); //Rows = encounters; Columns = resources
//This is a state, not an index, so should equal cons_bs
double xmax = (double) cons_bs;
//Vectors for output
IntegerVector pop_size(tsim);
IntegerVector recruit_size(tsim);
//OTHERS
//Number of starting individuals
int N = N_init;
//Initialize the record-keeping of states
//Record the state vector for each individual
//Which of these individuals are alive (they all start out alive)
IntegerVector alive(N);
for (int n=0; n<N; n++) {
alive(n) = 1;
}
int num_alive = sum(alive); //so num_alive = N at first
//This records the energetic state of each individual... values will change over time
IntegerVector state_v(N);
for (int i=0; i<N; i++) {
state_v(i) = xmax; //The initial state is full health
}
//Record the time vector for each individual
IntegerVector time_v(N);
for (int i=0; i<N; i++) {
time_v(i) = 1; //tmax-1;
}
//Record the current resource for each individual
IntegerVector res_v(N);
for (int i=0; i<N; i++) {
NumericVector rdraw_v = runif(1);
double rdraw = as<double>(rdraw_v);
//The initial resource is randomly drawn for each individual
//Random draw is between 0 and num_res-1... so already 'indexed'
res_v(i) = (int) floor(rdraw*(num_res));
}
//What are the optimal decisions for the current individual-level states?
IntegerVector dec_v(N);
for (int i=0; i<N; i++) {
//res_v is already indexed
//state_v and time_v are states, not indices, so alter by -1
IntegerMatrix istar_t = istar_nr(res_v(i)); //Grab the istar for the focal resource
dec_v(i) = istar_t(state_v(i)-1,time_v(i)-1); //Grab the decision for a given state and time t=0;
}
//TO EXPORT
//Record initial pop size
pop_size(0) = num_alive;
recruit_size(0) = 0;
List trophic_int(tsim);
List energetic_state(tsim);
List temporal_state(tsim);
List decision_state(tsim);
List fitness(tsim);
trophic_int(0) = res_v;
energetic_state(0) = state_v;
temporal_state(0) = time_v;
decision_state(0) = dec_v;
NumericVector ind_fit(N);
for (int i=0; i<N; i++) {
NumericMatrix W_matrix = W_nr(res_v(i));
ind_fit(i) = W_matrix(state_v(i)-1,time_v(i)-1);
}
fitness(0) = ind_fit;
Rcpp::Rcout << "I got here " << num_alive << std::endl;
//Begin time iteration (this is the simulation time)
//Sim time iterations stop at tsim - 1
for (int t=0; t<(tsim-1); t++) {
//Rcpp::Rcout << "tsim = " << t << std::endl;
//Book-keeping
//Reset metrics (first iteration will be repetitive, but oh well)
//How many individuals are currently alive?
int N = num_alive;
//Create vector to record reproductive events (1,0)
IntegerVector rep_success(N);
//To save the spawning stock biomass
IntegerVector SSB_v(N);
//To save the 'next' values for the energetic vector
NumericVector x_next_rd(N);
//To save the 'next' resouce consumed
IntegerVector res_next(N);
//To save the 'next' values for the time vector
//IntegerVector t_next(N);
//Individual fitness values
NumericVector ind_fit(N);
//Begin Individual iterations... Note: N will change with each t
for (int n=0; n<N; n++) {
//Rcpp::Rcout << "N = " << n << std::endl;
//Define states for the individual
//Current energetic state (state)
int ind_x = state_v(n);
//Current temporal state (state)
//int ind_t = time_v(n);
//Current (focal) resource (index)
int ind_r = res_v(n);
//Decision matrix associated with current resource (state)
int ind_d = dec_v(n);
//Reporting
//Rcpp::Rcout << "n = " << n << std::endl;
//Rcpp::Rcout << "ind_r = " << ind_r << std::endl;
//Rcpp::Rcout << "ind_d = " << ind_d << std::endl;
//Rcpp::Rcout << "ind_x = " << ind_x << std::endl;
//REPRODUCTION
//What is the probability that the individual will reproduce?
double rep_prob = rep_gain(ind_x-1);
//Does the individual reproduce in this timestep?
//Take care of reproduction after n iterations... to include density dependence
NumericVector rdraw_v = runif(1);
double rdraw = as<double>(rdraw_v);
if (rdraw < rep_prob) {
rep_success(n) = 1;
SSB_v(n) = ind_x;
} else {
rep_success(n) = 0;
SSB_v(n) = 0;
}
//Longevity mortality + Stochastic mortality
//If the individual has not reached it's max longevity
int stochmort;
if (time_v(n) < tmax-1) {
double pr_stochmort = mort(ind_r); //ind_r is index already
NumericVector rdraw_stochmort_v = runif(1);
double rdraw_stochmort = as<double>(rdraw_stochmort_v);
if (rdraw_stochmort < pr_stochmort) {
//Individual dies
stochmort = 1;
} else {
//Individual survives
stochmort = 0;
}
} else {
stochmort = 1; //All individuals that reach tmax die
}
//The following steps are only relevant for surviving individuals
if (stochmort == 0) {
//Choose next resource as a function of the preference probability distribution
NumericMatrix pref_prob_m = dec_ls(ind_r); //ind_r is index already
NumericVector pref_prob(num_res);
IntegerVector pref_num(num_res);
IntegerVector num_prob(num_res);
for (int i=0;i<num_res; i++) {
pref_prob(i) = pref_prob_m(i,ind_d-1);
//The number of each 'resource index' to choose across
//Zeros will screw this up
pref_num(i) = (int) floor(pref_prob(i)*1000) + 1; //+1 to ensure no zeros
}
int tot_num = sum(pref_num);
//The p_bin starts at 0 and ends at num_res-1... so it is already an index
IntegerVector p_bin(tot_num);
int tic = 0;
for (int i=0; i<num_res; i++) {
int num = pref_num(i);
for (int j=0; j<num; j++) {
p_bin(tic) = i;
tic = tic + 1;
}
}
NumericVector rdraw_v = runif(1);
double rdraw = as<double>(rdraw_v);
//Random draw between 0 and tot_num...
int draw = (int) floor(rdraw*(tot_num));
//This defines the next resource (the index for the next resource)
//NOTE: this is an index, as it has been for res
res_next(n) = p_bin(draw);
//How many of this resource is found?
NumericVector k_prob(max_enc+1);
IntegerVector k_num(max_enc+1);
for (int i=0; i<(max_enc+1); i++) { //there are max_enc+1 indices
k_prob(i) = f_m(i,res_next(n)); //res_next is already an index
//Zeros will screw this up
k_num(i) = (int) floor(k_prob(i)*1000) + 1; //+1 to ensure no zeros
}
tot_num = sum(k_num);
IntegerVector k_bin(tot_num);
tic = 0;
//These k values are not 'k', but the k index
//This index will grab the appropriate value in the rho vector
for (int i=0; i<(max_enc+1); i++) {
int num = k_num(i);
for (int j=0; j<num; j++) {
k_bin(tic) = i;
tic = tic + 1;
}
}
rdraw_v = runif(1);
rdraw = as<double>(rdraw_v);
draw = (int) floor(rdraw*tot_num);
//This defines the index for the resource amt / rho
int k = k_bin(draw);
//What is the probability of catching the resource: rho_vec(k)
//Rcpp::Rcout << "k= " << k << std::endl;
//Must be k-1 because k is a state, and needs to be used as an index
double rho = rho_vec(k-1);
//Is the prey capture successfull?
//Energetic dynamics
rdraw_v = runif(1);
double x_next; //state
double d_ind_x = (double) ind_x; //double current state
rdraw = as<double>(rdraw_v);
if (rdraw < rho) {
//If food is captured (res_next is an index)
x_next = d_ind_x + g_forage(res_next(n)) - c_forage(res_next(n));
} else {
//If food is not captured
x_next = d_ind_x - c_forage(res_next(n));
}
//Turn state x_next into nearest integer
x_next_rd(n) = (double) round(x_next);
//Boundary conditions and determine whether individual dies
if (x_next_rd(n) < xc_state) {
x_next_rd(n) = 0;
alive(n) = 0;
}
//Rcpp::Rcout << "Made it here; t = " << t << std::endl;
if (x_next_rd(n) > xmax) {
x_next_rd(n) = xmax;
alive(n) = 1;
}
//If individual suffers stochastic mortality
} else {
x_next_rd(n) = 0;
alive(n) = 0;
} //end stochmort if statement
//Record individual fitness value
NumericMatrix W_matrix = W_nr(res_next(n));
ind_fit(n) = W_matrix(x_next_rd(n)-1,time_v(n)-1);
//Next individual time integer
//Shouldn't matter if we advance time for dead individuals. Culling occurs later
//t_next(n) = time_v(n) + 1;
} //end individual iterations
num_alive = sum(alive);
//Density-dependent Reproduction :: TODO
//Must add on new individuals to the current state vectors
//This is the sum of biomass that is reproducing in this timestep
//Regardless of mortality
double SSB = sum(SSB_v);
double recruitB = (alpha*SSB) / (1 + beta*pow(SSB,1/comp));
//The number of new individuals: Recruit biomass / mass of individual
int num_recruits = (int) round(recruitB/xmax);
//int num_recruits = 0;
//Total individual count = surviving individuals + recruits
int new_N = num_alive + num_recruits;
//Rcpp::Rcout << "num_alive = " << num_alive << std::endl;
//Rcpp::Rcout << "recruit = " << num_recruits << std::endl;
//Rcpp::Rcout << "Total = " << new_N << std::endl;
//Add on new individuals
IntegerVector new_alive(new_N);
IntegerVector new_state_v(new_N);
IntegerVector new_res_v(new_N);
IntegerVector new_dec_v(new_N);
IntegerVector new_time_v(new_N);
NumericVector new_ind_fit(new_N);
//Transcribe over values for states at NEXT time interval
if (num_alive > 0) {
int tic = 0;
for (int i=0; i<N; i++) {
//only do this for surviving individuals
if (alive(i) == 1) {
new_alive(tic) = alive(i);
new_state_v(tic) = x_next_rd(i); //state
new_res_v(tic) = res_next(i); //index
new_time_v(tic) = time_v(i) + 1; //advance time interval
IntegerMatrix istar_t = istar_nr(new_res_v(tic)); //Grab the istar for the focal resource
new_dec_v(tic) = istar_t(new_state_v(tic)-1,new_time_v(tic)-1);
new_ind_fit(tic) = ind_fit(i);
tic = tic + 1;
}
}
}
//Export metrics :: These are for surviving individuals (not counting recruits)
//Distribution of individuals consuming each resource at time t
trophic_int(t+1) = new_res_v;
//Distribution of individual energetic states over time (distribution)
energetic_state(t+1) = new_state_v;
//Distribution of individuals at each ind_timestep at time t (distribution)
temporal_state(t+1) = new_time_v;
//Distribution of decisions at time t
decision_state(t+1) = new_dec_v;
//Distribution of fitness values at time t
fitness(t+1) = new_ind_fit;
//Exports
//Initiate new values for recruits
if (num_recruits > 0) {
int tic = 0; //just for the rdraw_v index
for (int i=num_alive; i<new_N; i++) {
new_alive(i) = 1; //Recruits are all alive
new_state_v(i) = xmax; //Initial energetic state is xmax
new_time_v(i) = 1;
//Randomly draw initial resource
NumericVector rdraw_v = runif(1);
double rdraw = as<double>(rdraw_v);
new_res_v(i) = (int) floor(rdraw*(num_res));
IntegerMatrix istar_t = istar_nr(new_res_v(i)); //Grab the istar for the focal resource
new_dec_v(i) = istar_t(new_state_v(i)-1,new_time_v(i)-1); //Grab the decision for a given state and time t=0;
tic = tic + 1;
}
}
//RESET
//How many individuals are there?
num_alive = sum(new_alive);
//Redefine states only for alive individuals
state_v = new_state_v;
time_v = new_time_v;
res_v = new_res_v;
dec_v = new_dec_v;
alive = new_alive;
//EXPORT
//Save variables
pop_size(t+1) = num_alive;
recruit_size(t+1) = num_recruits;
} //end simulation time iterations
List output(7);
output(0) = pop_size;
output(1) = energetic_state;
output(2) = temporal_state;
output(3) = decision_state;
output(4) = trophic_int;
output(5) = fitness;
output(6) = recruit_size;
//output(1) = ;
return output;
}
/* Function to run breadth-first search, returning only sets of connected
components that reside on the boundary of the districts */
List bsearch_boundary(List aList,
arma::vec boundary)
{
/* Inputs to function:
aList: adjacency list
boundary: vector of boundary element indicators (as arma)
*/
// Get indices of boundary units
arma::uvec boundary_indices = find(boundary == 1);
// Container - outputted of breadth search, a list
List bsearch;
// Container - partition vector, gets added to bsearch when queue is empty
NumericVector partition;
// Set mark vector - ledger of which indices have been reached
NumericVector mark(aList.size());
// Set queue vector
NumericVector q;
// Initialize breadth search with first element in boundary_indices
mark(boundary_indices(0)) = boundary_indices(0);
partition.push_back(boundary_indices(0));
q = aList(boundary_indices(0));
// Initialize objects inside loop
int u; bool in_part; NumericVector adj_u; int i; int v;
// Begin do{} loop - run until number of elements in boundary_indices is 0
do{
// Begin while{} loop - run until q is empty
while(q.size() > 0){
// Dequeue first element in queue
u = q(0);
// Mark that element in ledger
mark(u) = u;
// Check if element is in the partition - add to partition if false
in_part = is_true(any(partition == u));
if(in_part == false){
partition.push_back(u);
}
// Get adjacency vector for unit u
adj_u = aList(u);
// Loop through elements of adj_u, add to queue and mark if not reached
if(adj_u.size() > 0){
// Start loop
for(i = 0; i < adj_u.size(); i++){
// Reach element v
v = adj_u(i);
/* Check if already reached - if false, mark, add to partition, and
add to queue */
if(is_true(any(mark == v)) == FALSE){
mark(v) = v;
partition.push_back(v);
q.push_back(v);
}
}
}
// Erase dequeued element from queue when done searching
q.erase(q.begin());
}
// Handling an empty queue
if(q.size() == 0){
/* First, find boundary units that are in the reached partition and
remove them from boundary_units vector */
for(i = boundary_indices.n_elem - 1; i >= 0; i--){
if(is_true(any(partition == boundary_indices(i))) == TRUE){
boundary_indices.shed_row(i);
}
}
// Store the partition, clear partition vector
bsearch.push_back(partition);
partition.erase(partition.begin(), partition.end());
// Re-initialize breadth search from new starting value if nonempty
if(boundary_indices.n_elem > 0){
q = aList(boundary_indices(0));
mark(boundary_indices(0)) = boundary_indices(0);
partition.push_back(boundary_indices(0));
}
}
}while(boundary_indices.n_elem > 0);
// Get breadth search size
int bsearch_size = bsearch.size();
// Get weight_boundary vector
double weight_boundary = (double)countpartitions(aList) / bsearch_size;
List out;
out["bsearch"] = bsearch;
out["npartitions"] = bsearch_size;
out["weight_boundary"] = weight_boundary;
return out;
}
// [[Rcpp::export]]
double g(NumericVector x) {
return x.size();
}
// just an R interface to the coxfit routine, for regression testing purposes.
SEXP
cpp_coxfit(SEXP R_interface)
{
// ---------------
// get R objects:
// extract survival times
R_interface = CDR(R_interface);
SEXP R_survTimes = CAR(R_interface);
// censoring status
R_interface = CDR(R_interface);
SEXP R_censInd = CAR(R_interface);
// offsets
R_interface = CDR(R_interface);
SEXP R_offsets = CAR(R_interface);
// design matrix
R_interface = CDR(R_interface);
SEXP R_X= CAR(R_interface);
// and the tie method
R_interface = CDR(R_interface);
SEXP R_method = CAR(R_interface);
// ---------------
// unpack R objects:
// survival times
const NumericVector n_survTimes = R_survTimes;
//const AVector survTimes(n_survTimes.begin(), n_survTimes.size(),
// false);
// errors with const and stuff... what if we copy into new memory?
const AVector survTimes(n_survTimes.begin(), n_survTimes.size());
// censoring status
const IntVector censInd = as<IntVector>(R_censInd);
// offsets
const AVector offsets = as<NumericVector>(R_offsets);
// design matrix
const NumericMatrix n_X = R_X;
//const AMatrix X(n_X.begin(), n_X.nrow(),
// n_X.ncol(), false);
//Same issue as above L717:721
const AMatrix X(n_X.begin(), n_X.nrow(),
n_X.ncol());
// tie method
const int method = as<int>(R_method);
// ---------------
// assign remaining arguments for Coxfit
const int nObs = survTimes.size();
const AVector weights = arma::ones<AVector>(nObs);
// ---------------
// get new Coxfit object
Coxfit cox(survTimes,
censInd,
X,
weights,
offsets,
method);
// do the fitting
const int nIter = cox.fit();
// get results: need to do that first!
CoxfitResults fit = cox.finalizeAndGetResults();
// check results
cox.checkResults();
// pack results into R list and return that
return List::create(_["coef"] = fit.coefs,
_["imat"] = fit.imat,
_["loglik"] = fit.loglik,
_["nIter"] = nIter);
}
// [[Rcpp::export]]
NumericVector cumsum3(NumericVector x) {
NumericVector res(x.size());
std::partial_sum(x.begin(), x.end(), res.begin());
return res;
}
//[[Rcpp::export]]
List quasiTR(NumericVector start,
Function fn,
Function gr,
const List control) {
using Eigen::VectorXi;
using Eigen::Map;
typedef MatrixXd optHessType;
typedef LLT<optHessType> optPrecondType;
int nvars = start.size();
double rad = as<double>(control["start.trust.radius"]);
const double min_rad = as<double>(control["stop.trust.radius"]);
const double tol = as<double>(control["cg.tol"]);
const double prec = as<double>(control["prec"]);
const int report_freq = as<int>(control["report.freq"]);
const int report_level = as<int>(control["report.level"]);
const int report_precision = as<int>(control["report.precision"]);
const int maxit = as<int>(control["maxit"]);
const double contract_factor = as<double>(control["contract.factor"]);
const double expand_factor = as<double>(control["expand.factor"]);
const double contract_threshold = as<double>(control["contract.threshold"]);
const double expand_threshold_rad = as<double>(control["expand.threshold.radius"]);
const double expand_threshold_ap = as<double>(control["expand.threshold.ap"]);
const double function_scale_factor = as<double>(control["function.scale.factor"]);
const int precond_refresh_freq = as<int>(control["precond.refresh.freq"]);
const int precond_ID = as<int>(control["preconditioner"]);
const int quasi_newton_method = as<int>(control["quasi.newton.method"]);
const int trust_iter = as<int>(control["trust.iter"]);
std::string method_string;
if (quasi_newton_method==1) {
method_string = "SR1";
} else {
method_string = "BFGS";
}
Rfunc func(nvars, fn, gr);
Map<VectorXd> startX(start.begin(),nvars);
// Control parameters for optimizer
Trust_CG_Optimizer<Map<VectorXd>, Rfunc,
optHessType, optPrecondType> opt(func,
startX, rad, min_rad, tol,
prec, report_freq,
report_level,
report_precision,
maxit, contract_factor,
expand_factor,
contract_threshold,
expand_threshold_rad,
expand_threshold_ap,
function_scale_factor,
precond_refresh_freq,
precond_ID,
quasi_newton_method,
trust_iter);
opt.run();
// collect results and return
VectorXd P(nvars);
VectorXd grad(nvars);
// return sparse hessian information in CSC format
double fval, radius;
int iterations;
MB_Status status;
status = opt.get_current_state(P, fval, grad,
iterations, radius);
List res;
res = List::create(Rcpp::Named("fval") = Rcpp::wrap(fval),
Rcpp::Named("solution") = Rcpp::wrap(P),
Rcpp::Named("gradient") = Rcpp::wrap(grad),
Rcpp::Named("iterations") = Rcpp::wrap(iterations),
Rcpp::Named("status") = Rcpp::wrap((std::string) MB_strerror(status)),
Rcpp::Named("trust.radius") = Rcpp::wrap(radius),
Rcpp::Named("method") = Rcpp::wrap(method_string),
Rcpp::Named("hessian.update.method") = Rcpp::wrap(quasi_newton_method)
);
return(res);
}
NumericVector sqrtCpp(const NumericVector & orig) {
NumericVector vec(orig.size()); // create a target vector of the same size
std::transform(orig.begin(), orig.end(), vec.begin(), sqrt_double);
return(vec);
}
// [[Rcpp::export]]
List wasserstein_auto_(NumericVector p_, NumericVector q_, NumericMatrix cost_matrix_,
double epsilon, double desired_alpha){
// compute distance between p and q
// p corresponds to the weights of a N-sample
// each q corresponds to the weights of a M-sample
// Thus cost_matrix must be a N x M cost matrix
// epsilon is a regularization parameter, equal to 1/lambda in some references
int N = p_.size();
int M = q_.size();
Map<VectorXd> p(as<Map<VectorXd> >(p_));
Map<VectorXd> q(as<Map<VectorXd> >(q_));
Map<MatrixXd> cost_matrix(as<Map<MatrixXd> >(cost_matrix_));
// avoid to take exp(k) when k is less than -500,
// as K then contains zeros, and then the upcoming computations divide by zero
MatrixXd K = (cost_matrix.array() * (-1./epsilon)); // K = exp(- M / epsilon)
for (int i = 0; i < N; i++){
for (int j = 0; j < M; j++){
if (K(i,j) < -500){
K(i,j) = exp(-500);
} else {
K(i,j) = exp(K(i,j));
}
}
}
MatrixXd K_transpose = K.transpose();
MatrixXd K_tilde = p.array().inverse().matrix().asDiagonal() * K; // diag(1/p) %*% K
VectorXd u = VectorXd::Constant(N, 1./N);
//
VectorXd marginal1, marginal2;
MatrixXd transportmatrix;
VectorXd v;
double alpha = 0;
double beta = 0;
int niterations_max = 1000;
int iteration = 0;
// for (int iteration = 0; iteration < niterations; iteration ++){
while ((iteration < niterations_max) and (alpha < desired_alpha)){
iteration ++;
u = 1. / (K_tilde * (q.array() / (K_transpose * u).array()).matrix()).array();
if (iteration % 10 == 1){
// check if criterion is satisfied
v = q.array() / (K_transpose * u).array();
transportmatrix = u.col(0).asDiagonal() * K * v.col(0).asDiagonal();
marginal1 = transportmatrix.rowwise().sum();
marginal2 = transportmatrix.colwise().sum();
alpha = 10;
for (int i = 0; i < N; i++){
beta = std::min(p(i) / marginal1(i), q(i) / marginal2(i));
alpha = std::min(alpha, beta);
}
// cerr << "alpha = " << alpha << endl;
}
}
v = q.array() / (K_transpose * u).array();
// compute the optimal transport matrix between p and the first q
transportmatrix = u.col(0).asDiagonal() * K * v.col(0).asDiagonal();
// MatrixXd uXIv = u.array() * ((K.array() * cost_matrix.array()).matrix() * v).array();
// NumericVector d = wrap(uXIv.colwise().sum());
return List::create(Named("transportmatrix") = wrap(transportmatrix),
Named("u") = wrap(u),
Named("v") = wrap(v),
Named("iteration") = iteration);
}
// [[Rcpp::depends(RcppArmadillo)]]
// [[Rcpp::export]]
List inseq(mat M, bool adjust=true)
{
int i, m, trun;
mat mu=mean(M);
//center the rows
M.each_row() -= mu;
int n=M.n_rows, p=M.n_cols;
//Dtm is the vector of det(Sig)'s
NumericVector Dtm;
//gam_0 and gam_1 are for gam_2m and gam_2m+1, resp.
mat gam0(p,p), gam1(p,p), Gam(p,p), Sig(p,p), Sig1(p,p), Gamadj(p,p), eigvec(p,p);
//for adjustment, set initial increment in Gam=0
Gamadj.zeros();
//store the eigenvalues and eigenvectors of each Gam
vec eigval(p),eigvalneg(p);
double dtm;
int sn= n/2;
for (m=0; m<n/2; m++)
{
gam0.zeros(); gam1.zeros();
//calculate gam_2m (gam0) and gam_2m+1 (gam1)
for(i=0; i<(n-2*m);i++) gam0+=trans(M.row(i))*M.row(i+2*m);
gam0=gam0/n;
for(i=0; i<(n-2*m-1);i++) gam1+=trans(M.row(i))*M.row(i+2*m+1);
gam1=gam1/n;
//Gam_m=gam_2m+gam_2m+1, then symmetrize
Gam=gam0+gam1; Gam=(Gam+Gam.t())/2;
if (m==0) Sig=-gam0+2*Gam;
else Sig=Sig+2*Gam;
if (eig_sym(Sig)(0)>0)
{
sn=m;
break;
}
}
if (sn>n/2-1)
{
stop("Not enough samples.");
}
Dtm=det(Sig);
for (m=sn+1; m<n/2; m++)
{
gam0.zeros(); gam1.zeros();
//calculate gam_2m (gam0) and gam_2m+1 (gam1)
for(i=0; i<(n-2*m);i++) gam0+=trans(M.row(i))*M.row(i+2*m);
gam0=gam0/n;
for(i=0; i<(n-2*m-1);i++) gam1+=trans(M.row(i))*M.row(i+2*m+1);
gam1=gam1/n;
//Gam_m=gam_2m+gam_2m+1, then symmetrize
Gam=gam0+gam1; Gam=(Gam+Gam.t())/2;
//Sig_m=Sig_m-1+2Gam_m
Sig1=Sig+2*Gam;
dtm=det(Sig1);
//if dtm1>dtm, continue
if (dtm<=Dtm(m-sn-1)) break;
//update Sig
Sig=Sig1;
//record dtm
Dtm.push_back(dtm);
//to adjust the original Sig, subtract the negative part of Gam
if (adjust)
{
//calculate eigenvalues and eigenvectors of Gam
eig_sym(eigval,eigvec,Gam);
eigvalneg=eigval;
eigvalneg.elem(find(eigvalneg>0)).zeros();
Gamadj-=eigvec*diagmat(eigvalneg)*eigvec.t();
}
}
trun = Dtm.size()-1+sn;
List res; res["Sig"]=Sig; res["Dtm"]=Dtm; res["trunc"]= trun; res["sn"]=sn;
if (adjust) res["Sigadj"]=Sig+2*Gamadj;
return res;
}
// [[Rcpp::export]]
List rocUtilsPerfsAllC(NumericVector thresholds, NumericVector controls, NumericVector cases, std::string direction) {
NumericVector se(thresholds.size());
NumericVector sp(thresholds.size());
long tp, tn;
long i; // iterator over cases & controls
if (direction == ">") {
for (long t = 0; t < thresholds.size(); t++) {
if (t % 100 == 0) Rcpp::checkUserInterrupt();
double threshold = thresholds(t);
tp = 0;
for (i = 0; i < cases.size(); i++) {
if (cases(i) <= threshold) {
tp++;
}
}
se(t) = (double)tp / cases.size();
tn = 0;
for (i = 0; i < controls.size(); i++) {
if (controls(i) > threshold) {
tn++;
}
}
sp(t) = (double)tn / controls.size();
}
}
else {
for (long t = 0; t < thresholds.size(); t++) {
if (t % 100 == 0) Rcpp::checkUserInterrupt();
double threshold = thresholds(t);
tp = 0;
for (i = 0; i < cases.size(); i++) {
if (cases(i) >= threshold) {
tp++;
}
}
se(t) = (double)tp / cases.size();
long tn = 0;
for (i = 0; i < controls.size(); i++) {
if (controls(i) < threshold) {
tn++;
}
}
sp(t) = (double)tn / controls.size();
}
}
List ret;
ret["se"] = se;
ret["sp"] = sp;
return(ret);
}
SEXP
cpp_sampleGlm(SEXP r_interface)
{
// ----------------------------------------------------------------------------------
// extract arguments
// ----------------------------------------------------------------------------------
r_interface = CDR(r_interface);
List rcpp_model(CAR(r_interface));
r_interface = CDR(r_interface);
List rcpp_data(CAR(r_interface));
r_interface = CDR(r_interface);
List rcpp_fpInfos(CAR(r_interface));
r_interface = CDR(r_interface);
List rcpp_ucInfos(CAR(r_interface));
r_interface = CDR(r_interface);
List rcpp_fixInfos(CAR(r_interface));
r_interface = CDR(r_interface);
List rcpp_distribution(CAR(r_interface));
r_interface = CDR(r_interface);
List rcpp_searchConfig(CAR(r_interface));
r_interface = CDR(r_interface);
List rcpp_options(CAR(r_interface));
r_interface = CDR(r_interface);
List rcpp_marginalz(CAR(r_interface));
// ----------------------------------------------------------------------------------
// unpack the R objects
// ----------------------------------------------------------------------------------
// data:
const NumericMatrix n_x = rcpp_data["x"];
const AMatrix x(n_x.begin(), n_x.nrow(),
n_x.ncol());
const NumericMatrix n_xCentered = rcpp_data["xCentered"];
const AMatrix xCentered(n_xCentered.begin(), n_xCentered.nrow(),
n_xCentered.ncol());
const NumericVector n_y = rcpp_data["y"];
const AVector y(n_y.begin(), n_y.size());
const IntVector censInd = as<IntVector>(rcpp_data["censInd"]);
// FP configuration:
// vector of maximum fp degrees
const PosIntVector fpmaxs = as<PosIntVector>(rcpp_fpInfos["fpmaxs"]);
// corresponding vector of fp column indices
const PosIntVector fppos = rcpp_fpInfos["fppos"];
// corresponding vector of power set cardinalities
const PosIntVector fpcards = rcpp_fpInfos["fpcards"];
// names of fp terms
const StrVector fpnames = rcpp_fpInfos["fpnames"];
// UC configuration:
const PosIntVector ucIndices = rcpp_ucInfos["ucIndices"];
List rcpp_ucColList = rcpp_ucInfos["ucColList"];
std::vector<PosIntVector> ucColList;
for (R_len_t i = 0; i != rcpp_ucColList.length(); ++i)
{
ucColList.push_back(as<PosIntVector>(rcpp_ucColList[i]));
}
// fixed covariate configuration:
const PosIntVector fixIndices = rcpp_fixInfos["fixIndices"];
List rcpp_fixColList = rcpp_fixInfos["fixColList"];
std::vector<PosIntVector> fixColList;
for (R_len_t i = 0; i != rcpp_fixColList.length(); ++i)
{
fixColList.push_back(as<PosIntVector>(rcpp_fixColList[i]));
}
// distributions info:
const double nullModelLogMargLik = as<double>(rcpp_distribution["nullModelLogMargLik"]);
const double nullModelDeviance = as<double>(rcpp_distribution["nullModelDeviance"]);
S4 rcpp_gPrior = rcpp_distribution["gPrior"];
List rcpp_family = rcpp_distribution["family"];
const bool tbf = as<bool>(rcpp_distribution["tbf"]);
const bool doGlm = as<bool>(rcpp_distribution["doGlm"]);
const double empiricalMean = as<double>(rcpp_distribution["yMean"]);
const bool empiricalgPrior = as<bool>(rcpp_distribution["empiricalgPrior"]);
// model search configuration:
const bool useFixedc = as<bool>(rcpp_searchConfig["useFixedc"]);
// options:
const bool estimateMargLik = as<bool>(rcpp_options["estimateMargLik"]);
const bool verbose = as<bool>(rcpp_options["verbose"]);
const bool debug = as<bool>(rcpp_options["debug"]);
const bool isNullModel = as<bool>(rcpp_options["isNullModel"]);
const bool useFixedZ = as<bool>(rcpp_options["useFixedZ"]);
const double fixedZ = as<double>(rcpp_options["fixedZ"]);
#ifdef _OPENMP
const bool useOpenMP = as<bool>(rcpp_options["useOpenMP"]);
#endif
S4 rcpp_mcmc = rcpp_options["mcmc"];
const PosInt iterations = rcpp_mcmc.slot("iterations");
const PosInt burnin = rcpp_mcmc.slot("burnin");
const PosInt step = rcpp_mcmc.slot("step");
// z density stuff:
const RFunction logMarginalZdens(as<SEXP>(rcpp_marginalz["logDens"]));
const RFunction marginalZgen(as<SEXP>(rcpp_marginalz["gen"]));
// ----------------------------------------------------------------------------------
// further process arguments
// ----------------------------------------------------------------------------------
// data:
// only the intercept is always included, that is fixed, in the model
IntSet fixedCols;
fixedCols.insert(1);
// totalnumber is set to 0 because we do not care about it.
const DataValues data(x, xCentered, y, censInd, 0, fixedCols);
// FP configuration:
const FpInfo fpInfo(fpcards, fppos, fpmaxs, fpnames, x);
// UC configuration:
// determine sizes of the UC groups, and the total size == maximum size reached together by all
// UC groups.
PosIntVector ucSizes;
PosInt maxUcDim = 0;
for (std::vector<PosIntVector>::const_iterator cols = ucColList.begin(); cols != ucColList.end(); ++cols)
{
PosInt thisSize = cols->size();
maxUcDim += thisSize;
ucSizes.push_back(thisSize);
}
const UcInfo ucInfo(ucSizes, maxUcDim, ucIndices, ucColList);
// fix configuration:
// determine sizes of the fix groups, and the total size == maximum size reached together by all
// UC groups.
PosIntVector fixSizes;
PosInt maxFixDim = 0;
for (std::vector<PosIntVector>::const_iterator cols = fixColList.begin(); cols != fixColList.end(); ++cols)
{
PosInt thisSize = cols->size();
maxFixDim += thisSize;
fixSizes.push_back(thisSize);
}
const FixInfo fixInfo(fixSizes, maxFixDim, fixIndices, fixColList);
// model configuration:
GlmModelConfig config(rcpp_family, nullModelLogMargLik, nullModelDeviance, exp(fixedZ), rcpp_gPrior,
data.response, debug, useFixedc, empiricalMean, empiricalgPrior);
// model config/info:
const Model thisModel(ModelPar(rcpp_model["configuration"],
fpInfo),
GlmModelInfo(as<List>(rcpp_model["information"])));
// the options
const Options options(estimateMargLik,
verbose,
debug,
isNullModel,
useFixedZ,
tbf,
doGlm,
iterations,
burnin,
step);
// marginal z stuff
const MarginalZ marginalZ(logMarginalZdens,
marginalZgen);
// use only one thread if we do not want to use openMP.
#ifdef _OPENMP
if(! useOpenMP)
{
omp_set_num_threads(1);
} else {
omp_set_num_threads(omp_get_num_procs());
}
#endif
// ----------------------------------------------------------------------------------
// prepare the sampling
// ----------------------------------------------------------------------------------
Fitter fitter;
int nCoefs;
if(options.doGlm)
{
// construct IWLS object, which can be used for all IWLS stuff,
// and also contains the design matrix etc
fitter.iwlsObject = new Iwls(thisModel.par,
data,
fpInfo,
ucInfo,
fixInfo,
config,
config.linPredStart,
options.useFixedZ,
EPS,
options.debug,
options.tbf);
nCoefs = fitter.iwlsObject->nCoefs;
// check that we have the same answer about the null model as R
//assert(fitter.iwlsObject->isNullModel == options.isNullModel);
if(fitter.iwlsObject->isNullModel != options.isNullModel){
Rcpp::stop("sampleGlm.cpp:cpp_sampleGlm: isNullModel != options.isNullModel");
}
}
else
{
AMatrix design = getDesignMatrix(thisModel.par, data, fpInfo, ucInfo, fixInfo, false);
fitter.coxfitObject = new Coxfit(data.response,
data.censInd,
design,
config.weights,
config.offsets,
1);
// the number of coefficients (here it does not include the intercept!!)
nCoefs = design.n_cols;
// check that we do not have a null model here:
// assert(nCoefs > 0);
if(nCoefs <= 0){
Rcpp::stop("sampleGlm.cpp:cpp_sampleGlm: nCoefs <= 0");
}
}
// allocate sample container
Samples samples(nCoefs, options.nSamples);
// count how many proposals we have accepted:
PosInt nAccepted(0);
// at what z do we start?
double startZ = useFixedZ ? fixedZ : thisModel.info.zMode;
// start container with current things
Mcmc now(marginalZ, data.nObs, nCoefs);
if(doGlm)
{
// get the mode for beta given the mode of the approximated marginal posterior as z
// if TBF approach is used, this will be the only time the IWLS is used,
// because we only need the MLE and the Cholesky factor of its
// precision matrix estimate, which do not depend on z.
PosInt iwlsIterations = fitter.iwlsObject->startWithNewLinPred(40,
// this is the corresponding g
exp(startZ),
// and the start value for the linear predictor is taken from the Glm model config
config.linPredStart);
// echo debug-level message?
if(options.debug)
{
Rprintf("\ncpp_sampleGlm: Initial IWLS for high density point finished after %d iterations",
iwlsIterations);
}
// this is the current proposal info:
now.proposalInfo = fitter.iwlsObject->getResults();
// and this is the current parameters sample:
now.sample = Parameter(now.proposalInfo.coefs,
startZ);
if(options.tbf)
{
// we will not compute this in the TBF case:
now.logUnPosterior = R_NaReal;
// start to compute the variance of the intercept parameter:
// here the inverse cholesky factor of the precision matrix will
// be stored. First, it's the identity matrix.
AMatrix inverseQfactor = arma::eye(now.proposalInfo.qFactor.n_rows,
now.proposalInfo.qFactor.n_cols);
// do the inversion
trs(false,
false,
now.proposalInfo.qFactor,
inverseQfactor);
// now we can compute the variance of the intercept estimate:
const AVector firstCol = inverseQfactor.col(0);
const double interceptVar = arma::dot(firstCol, firstCol);
// ok, now alter the qFactor appropriately to reflect the
// independence assumption between the intercept estimate
// and the other coefficients estimates
now.proposalInfo.qFactor.col(0) = arma::zeros<AVector>(now.proposalInfo.qFactor.n_rows);
now.proposalInfo.qFactor(0, 0) = sqrt(1.0 / interceptVar);
}
else
{
// compute the (unnormalized) log posterior of the proposal
now.logUnPosterior = fitter.iwlsObject->computeLogUnPosteriorDens(now.sample);
}
}
else
{
PosInt coxfitIterations = fitter.coxfitObject->fit();
CoxfitResults coxResults = fitter.coxfitObject->finalizeAndGetResults();
fitter.coxfitObject->checkResults();
// echo debug-level message?
if(options.debug)
{
Rprintf("\ncpp_sampleGlm: Cox fit finished after %d iterations",
coxfitIterations);
}
// we will not compute this in the TBF case:
now.logUnPosterior = R_NaReal;
// compute the Cholesky factorization of the covariance matrix
int info = potrf(false,
coxResults.imat);
// check that all went well
if(info != 0)
{
std::ostringstream stream;
stream << "dpotrf(coxResults.imat) got error code " << info << "in sampleGlm";
throw std::domain_error(stream.str().c_str());
}
// compute the precision matrix, using the Cholesky factorization
// of the covariance matrix
now.proposalInfo.qFactor = arma::eye(now.proposalInfo.qFactor.n_rows,
now.proposalInfo.qFactor.n_cols);
info = potrs(false,
coxResults.imat,
now.proposalInfo.qFactor);
// check that all went well
if(info != 0)
{
std::ostringstream stream;
stream << "dpotrs(coxResults.imat, now.proposalInfo.qFactor) got error code " << info << "in sampleGlm";
throw std::domain_error(stream.str().c_str());
}
// compute the Cholesky factorization of the precision matrix
info = potrf(false,
now.proposalInfo.qFactor);
// check that all went well
if(info != 0)
{
std::ostringstream stream;
stream << "dpotrf(now.proposalInfo.qFactor) got error code " << info << "in sampleGlm";
throw std::domain_error(stream.str().c_str());
}
// the MLE of the coefficients
now.proposalInfo.coefs = coxResults.coefs;
}
// so the parameter object "now" is then also the high density point
// required for the marginal likelihood estimate:
const Mcmc highDensityPoint(now);
// we accept this starting value, so initialize "old" with the same ones
Mcmc old(now);
// ----------------------------------------------------------------------------------
// start sampling
// ----------------------------------------------------------------------------------
// echo debug-level message?
if(options.debug)
{
if(tbf)
{
Rprintf("\ncpp_sampleGlm: Starting MC simulation");
}
else
{
Rprintf("\ncpp_sampleGlm: Starting MCMC loop");
}
}
// i_iter starts at 1 !!
for(PosInt i_iter = 1; i_iter <= options.iterations; ++i_iter)
{
// echo debug-level message?
if(options.debug)
{
Rprintf("\ncpp_sampleGlm: Starting iteration no. %d", i_iter);
}
// ----------------------------------------------------------------------------------
// store the proposal
// ----------------------------------------------------------------------------------
// sample one new log covariance factor z (other arguments than 1 are not useful
// with the current setup of the RFunction wrapper class)
now.sample.z = marginalZ.gen(1);
if(options.tbf)
{
if(options.isNullModel)
{
// note that we do not encounter this in the Cox case
// assert(options.doGlm);
if(!options.doGlm){
Rcpp::stop("sampleGlm.cpp:cpp_sampleGlm: options.doGlm should be TRUE");
}
// draw the proposal coefs, which is here just the intercept
now.sample.coefs = drawNormalVector(now.proposalInfo.coefs,
now.proposalInfo.qFactor);
}
else
{ // here we have at least one non-intercept coefficient
// get vector from N(0, I)
AVector w = drawNormalVariates(now.proposalInfo.coefs.n_elem,
0.0,
1.0);
// then solve L' * ret = w, and overwrite w with the result:
trs(false,
true,
now.proposalInfo.qFactor,
w);
// compute the shrinkage factor t = g / (g + 1)
const double g = exp(now.sample.z);
//Previously used g directly, but if g=inf we need to use the limit
// const double shrinkFactor = g / (g + 1.0);
const double shrinkFactor = isinf(g) ? 1 : g / (g + 1.0);
// scale the variance of the non-intercept coefficients
// with this factor.
// In the Cox case: no intercept present, so scale everything
int startCoef = options.doGlm ? 1 : 0;
w.rows(startCoef, w.n_rows - 1) *= sqrt(shrinkFactor);
// also scale the mean of the non-intercept coefficients
// appropriately:
// In the Cox case: no intercept present, so scale everything
now.sample.coefs = now.proposalInfo.coefs;
now.sample.coefs.rows(startCoef, now.sample.coefs.n_rows - 1) *= shrinkFactor;
// so altogether we have:
now.sample.coefs += w;
}
++nAccepted;
}
else // the generalized hyper-g prior case
{
// do 1 IWLS step, starting from the last linear predictor and the new z
// (here the return value is not very interesting, as it must be 1)
fitter.iwlsObject->startWithNewCoefs(1,
exp(now.sample.z),
now.sample.coefs);
// get the results
now.proposalInfo = fitter.iwlsObject->getResults();
// draw the proposal coefs:
now.sample.coefs = drawNormalVector(now.proposalInfo.coefs,
now.proposalInfo.qFactor);
// compute the (unnormalized) log posterior of the proposal
now.logUnPosterior = fitter.iwlsObject->computeLogUnPosteriorDens(now.sample);
// ----------------------------------------------------------------------------------
// get the reverse jump normal density
// ----------------------------------------------------------------------------------
// copy the old Mcmc object
Mcmc reverse(old);
// do again 1 IWLS step, starting from the sampled linear predictor and the old z
fitter.iwlsObject->startWithNewCoefs(1,
exp(reverse.sample.z),
now.sample.coefs);
// get the results for the reverse jump Gaussian:
// only the proposal has changed in contrast to the old container,
// the sample stays the same!
reverse.proposalInfo = fitter.iwlsObject->getResults();
// ----------------------------------------------------------------------------------
// compute the proposal density ratio
// ----------------------------------------------------------------------------------
// first the log of the numerator, i.e. log(f(old | new)):
double logProposalRatioNumerator = reverse.computeLogProposalDens();
// second the log of the denominator, i.e. log(f(new | old)):
double logProposalRatioDenominator = now.computeLogProposalDens();
// so the log proposal density ratio is
double logProposalRatio = logProposalRatioNumerator - logProposalRatioDenominator;
// ----------------------------------------------------------------------------------
// compute the posterior density ratio
// ----------------------------------------------------------------------------------
double logPosteriorRatio = now.logUnPosterior - old.logUnPosterior;
// ----------------------------------------------------------------------------------
// accept or reject proposal
// ----------------------------------------------------------------------------------
double acceptanceProb = exp(logPosteriorRatio + logProposalRatio);
if(unif() < acceptanceProb)
{
old = now;
++nAccepted;
}
else
{
now = old;
}
}
// ----------------------------------------------------------------------------------
// store the sample?
// ----------------------------------------------------------------------------------
// if the burnin was passed and we are at a multiple of step beyond that, then store
// the sample.
if((i_iter > options.burnin) &&
(((i_iter - options.burnin) % options.step) == 0))
{
// echo debug-level message
if(options.debug)
{
Rprintf("\ncpp_sampleGlm: Storing samples of iteration no. %d", i_iter);
}
// store the current parameter sample
samples.storeParameters(now.sample);
// ----------------------------------------------------------------------------------
// compute marginal likelihood terms
// ----------------------------------------------------------------------------------
// compute marginal likelihood terms and save them?
// (Note that the tbf bool is just for safety here,
// the R function sampleGlm will set estimateMargLik to FALSE
// when tbf is TRUE.)
if(options.estimateMargLik && (! options.tbf))
{
// echo debug-level message?
if(options.debug)
{
Rprintf("\ncpp_sampleGlm: Compute marginal likelihood estimation terms");
}
// ----------------------------------------------------------------------------------
// compute next term for the denominator
// ----------------------------------------------------------------------------------
// draw from the high density point proposal distribution
Mcmc denominator(highDensityPoint);
denominator.sample.z = marginalZ.gen(1);
fitter.iwlsObject->startWithNewLinPred(1,
exp(denominator.sample.z),
highDensityPoint.proposalInfo.linPred);
denominator.proposalInfo = fitter.iwlsObject->getResults();
denominator.sample.coefs = drawNormalVector(denominator.proposalInfo.coefs,
denominator.proposalInfo.qFactor);
// get posterior density of the sample
denominator.logUnPosterior = fitter.iwlsObject->computeLogUnPosteriorDens(denominator.sample);
// get the proposal density at the sample
double denominator_logProposalDensity = denominator.computeLogProposalDens();
// then the reverse stuff:
// first we copy again the high density point
Mcmc revDenom(highDensityPoint);
// but choose the new sampled coefficients as starting point
fitter.iwlsObject->startWithNewCoefs(1,
exp(revDenom.sample.z),
denominator.sample.coefs);
revDenom.proposalInfo = fitter.iwlsObject->getResults();
// so the reverse proposal density is
double revDenom_logProposalDensity = revDenom.computeLogProposalDens();
// so altogether the next term for the denominator is the following acceptance probability
double denominatorTerm = denominator.logUnPosterior - highDensityPoint.logUnPosterior +
revDenom_logProposalDensity - denominator_logProposalDensity;
denominatorTerm = exp(fmin(0.0, denominatorTerm));
// ----------------------------------------------------------------------------------
// compute next term for the numerator
// ----------------------------------------------------------------------------------
// compute the proposal density of the current sample starting from the high density point
Mcmc numerator(now);
fitter.iwlsObject->startWithNewLinPred(1,
exp(numerator.sample.z),
highDensityPoint.proposalInfo.linPred);
numerator.proposalInfo = fitter.iwlsObject->getResults();
double numerator_logProposalDensity = numerator.computeLogProposalDens();
// then compute the reverse proposal density of the high density point when we start from the current
// sample
Mcmc revNum(highDensityPoint);
fitter.iwlsObject->startWithNewCoefs(1,
exp(revNum.sample.z),
now.sample.coefs);
revNum.proposalInfo = fitter.iwlsObject->getResults();
double revNum_logProposalDensity = revNum.computeLogProposalDens();
// so altogether the next term for the numerator is the following guy:
double numeratorTerm = exp(fmin(revNum_logProposalDensity,
highDensityPoint.logUnPosterior - now.logUnPosterior +
numerator_logProposalDensity));
// ----------------------------------------------------------------------------------
// finally store both terms
// ----------------------------------------------------------------------------------
samples.storeMargLikTerms(numeratorTerm, denominatorTerm);
}
}
// ----------------------------------------------------------------------------------
// echo progress?
// ----------------------------------------------------------------------------------
// echo debug-level message?
if(options.debug)
{
Rprintf("\ncpp_sampleGlm: Finished iteration no. %d", i_iter);
}
if((i_iter % std::max(static_cast<int>(options.iterations / 100), 1) == 0) &&
options.verbose)
{
// display computation progress at each percent
Rprintf("-");
} // end echo progress
} // end MCMC loop
// echo debug-level message?
if(options.debug)
{
if(tbf)
{
Rprintf("\ncpp_sampleGlm: Finished MC simulation");
}
else
{
Rprintf("\ncpp_sampleGlm: Finished MCMC loop");
}
}
// ----------------------------------------------------------------------------------
// build up return list for R and return that.
// ----------------------------------------------------------------------------------
return List::create(_["samples"] = samples.convert2list(),
_["nAccepted"] = nAccepted,
_["highDensityPointLogUnPosterior"] = highDensityPoint.logUnPosterior);
} // end cpp_sampleGlm
// [[Rcpp::export]]
List or_gdp_em(NumericVector ryo, NumericMatrix rxo, SEXP ralpha, SEXP reta){
//Define Variables//
int p=rxo.ncol();
int no=rxo.nrow();
double eta=Rcpp::as<double >(reta);
double alpha=Rcpp::as<double >(ralpha);
//Create Data//
arma::mat xo(rxo.begin(), no, p, false);
arma::colvec yo(ryo.begin(), ryo.size(), false);
yo-=mean(yo);
//Pre-Processing//
Col<double> xoyo=xo.t()*yo;
Col<double> B=xoyo/no;
Col<double> Babs=abs(B);
Mat<double> xoxo=xo.t()*xo;
Mat<double> D=eye(p,p);
Mat<double> Ip=eye(p,p);
double yoyo=dot(yo,yo);
double deltaB;
double deltaphi;
double phi=no/dot(yo-xo*B,yo-xo*B);
double lp;
//Create Trace Matrices
Mat<double> B_trace(p,20000);
Col<double> phi_trace(20000);
Col<double> lpd_trace(20000);
//Run EM Algorithm//
cout << "Beginning EM Algorithm" << endl;
int t=0;
B_trace.col(t)=B;
phi_trace(t)=phi;
lpd_trace(t)=or_gdp_log_posterior_density(no,p,alpha,eta,yo,xo,B,phi);
do{
t=t+1;
Babs=abs(B);
D=diagmat(sqrt(((eta+sqrt(phi)*Babs)%(sqrt(phi)*Babs))/(alpha+1)));
B=D*solve(D*xoxo*D+Ip,D*xoyo);
phi=(no+p-3)/(yoyo-dot(xoyo,B));
//Store Values//
B_trace.col(t)=B;
phi_trace(t)=phi;
lpd_trace(t)=or_gdp_log_posterior_density(no,p,alpha,eta,yo,xo,B,phi);
deltaB=dot(B_trace.col(t)-B_trace.col(t-1),B_trace.col(t)-B_trace.col(t-1));
deltaphi=phi_trace(t)-phi_trace(t-1);
} while((deltaB>0.00001 || deltaphi>0.00001) && t<19999);
cout << "EM Algorithm Converged in " << t << " Iterations" << endl;
//Resize Trace Matrices//
B_trace.resize(p,t);
phi_trace.resize(t);
lpd_trace.resize(t);
return Rcpp::List::create(
Rcpp::Named("B") = B,
Rcpp::Named("B_trace") = B_trace,
Rcpp::Named("phi") = phi,
Rcpp::Named("phi_trace") = phi_trace,
Rcpp::Named("lpd_trace") = lpd_trace
) ;
}
//[[Rcpp::export]]
List sparseTR(NumericVector start,
Function fn,
Function gr,
Function hs,
const List control) {
// use this version when the user supplies his own Hessian function.
// Hessian function must return a Matrix of class dgCMatrix
using Eigen::VectorXi;
using Eigen::Map;
typedef SparseMatrix<double> optHessType;
typedef SimplicialLLT<optHessType> optPrecondType;
int nvars = start.size();
if (nvars<=0) throw MyException("Number of variables (starting values) must be positive\n",__FILE__, __LINE__);
// Control parameters for optimizer
double rad = as<double>(control["start.trust.radius"]);
const double min_rad = as<double>(control["stop.trust.radius"]);
const double tol = as<double>(control["cg.tol"]);
const double prec = as<double>(control["prec"]);
const int report_freq = as<int>(control["report.freq"]);
const int report_level = as<int>(control["report.level"]);
const int report_precision = as<int>(control["report.precision"]);
const int maxit = as<int>(control["maxit"]);
const double contract_factor = as<double>(control["contract.factor"]);
const double expand_factor = as<double>(control["expand.factor"]);
const double contract_threshold = as<double>(control["contract.threshold"]);
const double expand_threshold_rad = as<double>(control["expand.threshold.radius"]);
const double expand_threshold_ap = as<double>(control["expand.threshold.ap"]);
const double function_scale_factor = as<double>(control["function.scale.factor"]);
const int precond_refresh_freq = as<int>(control["precond.refresh.freq"]);
const int precond_ID = as<int>(control["preconditioner"]);
const int trust_iter = as<int>(control["trust.iter"]);
Map<VectorXd> startX(start.begin(),nvars);
Rcpp::S4 sh_ = hs(startX);
Map<SparseMatrix<double> > sh = Rcpp::as<Map<SparseMatrix<double>>>(sh_);
int nnz = (sh.nonZeros() + nvars)/2;
RfuncHess func(nvars, nnz, fn, gr, hs);
Trust_CG_Sparse<Map<VectorXd>, RfuncHess,optHessType, optPrecondType>
opt(func, startX, rad, min_rad, tol, prec,
report_freq, report_level, report_precision,
maxit, contract_factor, expand_factor,
contract_threshold, expand_threshold_rad,
expand_threshold_ap, function_scale_factor,
precond_refresh_freq, precond_ID, trust_iter);
opt.run();
// collect results and return
VectorXd P(nvars);
VectorXd grad(nvars);
optHessType hess(nvars,nvars);
hess.reserve(nnz);
double fval, radius;
int iterations;
MB_Status status;
status = opt.get_current_state(P, fval, grad, hess, iterations, radius);
List res;
res = List::create(Rcpp::Named("fval") = Rcpp::wrap(fval),
Rcpp::Named("solution") = Rcpp::wrap(P),
Rcpp::Named("gradient") = Rcpp::wrap(grad),
Rcpp::Named("hessian") = Rcpp::wrap(hess),
Rcpp::Named("iterations") = Rcpp::wrap(iterations),
Rcpp::Named("status") = Rcpp::wrap((std::string) MB_strerror(status)),
Rcpp::Named("trust.radius") = Rcpp::wrap(radius),
Rcpp::Named("nnz") = Rcpp::wrap(nnz),
Rcpp::Named("method") = Rcpp::wrap("Sparse")
);
return(res);
}
//' Simulates the model when it is written as a C++ function using stl containers
//' @export
// [[Rcpp::export]]
NumericMatrix ida_Cpp_stl(NumericVector times, NumericVector states_,
NumericVector derivatives_,
NumericVector parameters_, List forcings_data_,
List settings, SEXP model_, SEXP jacobian_) {
// Wrap the pointer to the model function with the correct signature
dae_in_Cpp_stl* model = (dae_in_Cpp_stl *) R_ExternalPtrAddr(model_);
// Wrap the pointer to the jacobian function with the correct signature
jac_in_Cpp_stl* jacobian = nullptr;
if(as<int>(settings["jacobian"]) == 1)
jacobian = (jac_in_Cpp_stl *) R_ExternalPtrAddr(jacobian_);
// Store all inputs in the data struct, prior conversion to stl and Armadillo classes
int neq = states_.size();
vector<double> parameters{as<vector<double>>(parameters_)};
vector<double> states{as<vector<double>>(states_)};
vector<double> derivatives{as<vector<double>>(derivatives_)};
vector<mat> forcings_data(forcings_data_.size());
if(forcings_data_.size() > 0)
for(int i = 0; i < forcings_data_.size(); i++)
forcings_data[i] = as<mat>(forcings_data_[i]);
data_ida_Cpp_stl data_model{parameters, forcings_data, neq, model, jacobian};
/*
*
Initialize IDA and pass all initial inputs
*
*/
N_Vector y = nullptr;
y = N_VNew_Serial(neq);
for(int i = 0; i < neq; i++) {
NV_Ith_S(y,i) = states[i];
}
N_Vector yp = nullptr;
yp = N_VNew_Serial(neq);
for(int i = 0; i < neq; i++) {
NV_Ith_S(yp,i) = derivatives[i];
}
void *ida_mem = IDACreate();
// Shut up Sundials (errors not printed to the screen)
int flag = IDASetErrFile(ida_mem, NULL);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASetErrFile function");
}
// Initialize the Sundials solver. Here we pass initial N_Vector, the interface function and the initial time
flag = IDAInit(ida_mem, ida_to_Cpp_stl, times[0], y, yp);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDAInit function");
}
// Tell Sundials the tolerance settings for error control
flag = IDASStolerances(ida_mem, settings["rtol"], settings["atol"]);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASStolerances function");
}
// Tell Sundials the number of state variables, so that I can allocate memory for the Jacobian
flag = IDADense(ida_mem, neq);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDADense function");
}
// Give Sundials a pointer to the struct where all the user data is stored. It will be passed (untouched) to the interface as void pointer
flag = IDASetUserData(ida_mem, &data_model);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASetUserData function");
}
// Correct initial values
flag = IDACalcIC(ida_mem, IDA_Y_INIT, times[1]);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDACalcIC function");
}
// Set maximum number of steps
flag = IDASetMaxNumSteps(ida_mem, settings["maxsteps"]);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASetMaxNumSteps function");
}
// Set maximum order of the integration
flag = IDASetMaxOrd(ida_mem, settings["maxord"]);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASetMaxOrd function");
}
// Set the initial step size
flag = IDASetInitStep(ida_mem, settings["hini"]);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASetInitStep function");
}
// Set the maximum step size
flag = IDASetMaxStep(ida_mem, settings["hmax"]);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASetMaxStep function");
}
// Set the maximum number of error test fails
flag = IDASetMaxErrTestFails(ida_mem, settings["maxerr"]);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASetMaxErrTestFails function");
}
// Set the maximum number of nonlinear iterations per step
flag = IDASetMaxNonlinIters(ida_mem, settings["maxnonlin"]);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASetMaxNonlinIters function");
}
// Set the maximum number of convergence failures
flag = IDASetMaxConvFails(ida_mem, settings["maxconvfail"]);
if(flag < 0.0) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Error in the IDASetMaxConvFails function");
}
/*
*
Make a first call to the model to check that everything is ok and retrieve the number of observed variables
*
*/
vector<double> forcings(forcings_data.size());
if(forcings_data.size() > 0) forcings = interpolate_list(forcings_data, times[0]);
std::array<vector<double>, 2> first_call;
try {
first_call = model(times[0], states, derivatives, parameters, forcings);
} catch(std::exception &ex) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
forward_exception_to_r(ex);
} catch(...) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("c++ exception (unknown reason)");
}
// Check length of time derivatives against the information passed through settings
if(first_call[0].size() != neq) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Length of time derivatives returned by the model does not coincide with the number of state variables.");
}
/*
*
Fill up the output matrix with the values for the initial time
*
*/
vector<double> observed;
int nder = 0;
if(first_call.size() == 2) {
vector<double> temp = first_call[1];
observed.resize(temp.size());
observed = temp;
nder = observed.size();
}
vector<int> extract_states = as<vector<int>>(settings["which_states"]);
vector<int> extract_observed = as<vector<int>>(settings["which_observed"]);
mat output(times.size(), extract_states.size() + extract_observed.size() + 1);
output.at(0,0) = times[0];
//for(auto i = 0; i < neq; i++) {
// output(0,i+1) = states[i];
for(auto it = extract_states.begin(); it != extract_states.end(); it++) {
if(*it > NV_LENGTH_S(y)) {
Rcout << "The index " << *it << " exceeds the number of state variables of the model" << '\n';
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Simulation exited because of error in extracting state variables");
}
output.at(0,*it) = NV_Ith_S(y,*it - 1);
}
if(extract_observed.size() > 0) {
//for(auto i = 0; i < nder; i++)
// output(0,i + 1 + neq) = observed[i];
for(auto it = extract_observed.begin(); it != extract_observed.end(); it++) {
if(*it > observed.size()) {
Rcout << "The index " << *it << " exceeds the number of observed variables returned by the model" << '\n';
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("Simulation exited because of error in extracting observed variables");
}
output.at(0,*it + extract_states.size()) = observed[*it - 1];
}
}
/*
*
Main time loop. Each timestep call cvode. Handle exceptions and fill up output
*
*/
double t = times[0];
for(unsigned i = 1; i < times.size(); i++) {
try {
flag = IDASolve(ida_mem, times[i], &t, y, yp, IDA_NORMAL);
for(auto h = 0; h < neq; h++) {
if(as<bool>(settings["positive"])) {
if(NV_Ith_S(y,h) < as<double>(settings["minimum"])) {
Rcout << "The state variable at positon " << h << " became smaller than minimum: " << NV_Ith_S(y,h) << '\n';
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("At least one of the states became smaller than minimum");
}
}
}
if(flag < 0.0) {
switch(flag) {
case -1:
throw std::runtime_error("The solver took mxstep internal steps but could not reach tout."); break;
case -2:
throw std::runtime_error("The solver could not satisfy the accuracy demanded by the user for some internal step"); break;
case -3:
throw std::runtime_error("Error test failures occured too many times during one internal time step or minimum step size was reached"); break;
case -4:
throw std::runtime_error("Convergence test failures occurred too many times during one internal time step or minimum step size was reached."); break;
case -5:
throw std::runtime_error("The linear solver’s initialization function failed."); break;
case -6:
throw std::runtime_error("The linear solver’s setup function failed in an unrecoverable manner"); break;
case -7:
throw std::runtime_error("The linear solver’s solve function failed in an unrecoverable manner"); break;
case -8:
throw std::runtime_error("The right hand side function failed in an unrecoverable manner"); break;
case -9:
throw std::runtime_error("The right-hand side function failed at the first call."); break;
case -10:
throw std::runtime_error("The right-hand side function had repeated recoverable errors."); break;
case -11:
throw std::runtime_error("The right-hand side function had a recoverable errors but no recovery is possible."); break;
case -25:
throw std::runtime_error("The time t is outside the last step taken."); break;
case -26:
throw std::runtime_error("The output derivative vector is NULL."); break;
case -27:
throw std::runtime_error("The output and initial times are too close to each other."); break;
}
}
} catch(std::exception &ex) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
forward_exception_to_r(ex);
} catch(...) {
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
::Rf_error("c++ exception (unknown reason)");
}
// Write to the output matrix the new values of state variables and time
output.at(i,0) = times[i];
//for(auto h = 0; h < neq; h++) output(i,h + 1) = NV_Ith_S(y,h);
for(auto it = extract_states.begin(); it != extract_states.end(); it++) {
output.at(i,*it) = NV_Ith_S(y,*it - 1);
}
}
// If we have observed variables we call the model function again
if(extract_observed.size() > 0 && flag >= 0.0) {
for(unsigned i = 1; i < times.size(); i++) {
// Get forcings values at time 0.
if(forcings_data.size() > 0) forcings = interpolate_list(forcings_data, times[i]);
// Get the simulate state variables
for(auto j = 0; j < neq; j++) states[j] = output(i,j + 1);
// Call the model function to retrieve total number of outputs and initial values for derived variables
std::array<vector<double>, 2> model_call = model(times[i], states, derivatives, parameters, forcings);
observed = model_call[1];
// Derived variables already stored by the interface function
//for(auto j = 0; j < nder; j++) output(i,j + 1 + neq) = observed[j];
for(auto it = extract_observed.begin(); it != extract_observed.end(); it++) {
output.at(i,*it + extract_states.size()) = observed[*it - 1];
}
}
}
// De-allocate the N_Vector and the ida_mem structures
if(y == nullptr) {free(y);} else {N_VDestroy_Serial(y);}
if(ida_mem == nullptr) {free(ida_mem);} else {IDAFree(&ida_mem);}
return wrap(output);
}
// [[Rcpp::export]]
NumericVector pdistC2(double x, NumericVector ys) {
NumericVector ans(ys.size());
ans = sqrt(pow(x - ys, 2));
return ans;
}
NumericVector dbinom_glmb( NumericVector x, NumericVector N, NumericVector means, int lg){
int n = x.size() ;
NumericVector res(n) ;
for( int i=0; i<n; i++) res[i] = R::dbinom( round(x[i]*N[i]),round(N[i]), means[i], lg ) ;
return res ;
}
List EnelmC(List PITEMLL, List NODW, List Yl, List NU1) {
// PITEMLL - item parameter estimates
// NODW - quadrature nodes and weights
// Yl - response matrices for each group in List
// NU1 - null1 matrices for each group in List
int ngru = PITEMLL.size();
// create return list
List riqv_querG(ngru);
List fiqG(ngru);
// the group loop
for(int gru = 0; gru < ngru; gru++)
{
// extract everything out of the Lists
List PITEML = PITEMLL[gru];
List nodeswei = NODW[gru];
Rcpp::IntegerMatrix Y = Yl[gru];
Rcpp::IntegerMatrix nu1m = NU1[gru];
NumericVector nodes = nodeswei[0];
NumericVector weights = nodeswei[1];
int listlength = PITEML.size(); // number of items
int ysi = Y.nrow(); // number of observations per item (including NA's)
int lno = nodes.size(); // number of quadrature nodes
// create matrix outside the loop
Rcpp::NumericMatrix ENDm(lno,ysi); // matrix with proper dimensions for multiplication
ENDm.fill(1); // write 1 in each cell
for(int l = 0; l < listlength; l++)
{ // loops all items
Rcpp::NumericVector PITEM = PITEML[l]; // take out parameters for the l-th item
IntegerVector y = Y(_,l); // response vector of l-th items
int lpi = PITEM.size()/2; // number of categories
int lpim1 = lpi - 1;
//arma::mat x(lno,lpi);
Rcpp::NumericMatrix x(lno,lpi);
// das hier ist zeile 40 bis 44 des nrm Estep
for(int o = 0; o < lno; o++)
{
double gessum = 0;
double z2plv = 0;
double tplf = 0;
for(int q = 0; q < lpi; q++)
{
int lpi2 = q+lpi;
if(q == 0)
{ // hier muss jetzt das 2pl Modell rein
// exp(Km %*% abpar) / (1 + exp(Km %*% abpar))
// x(o,q) = exp(PITEM(q) + nodes(o)*PITEM(lpi2)) / ( 1+ exp(PITEM(q) + nodes(o)*PITEM(lpi2))); // 2pl
z2plv = exp(PITEM(q) + nodes(o)*PITEM(lpi2)) / ( 1+ exp(PITEM(q) + nodes(o)*PITEM(lpi2)));
tplf = 1 - z2plv; // 1-P
//std::cout << "Return" << tplf << " \n ";
} else {
x(o,q) = exp(PITEM(q) + nodes(o)*PITEM(lpi2)) * tplf; // mit 1-P multiplizieren
gessum += exp(PITEM(q) + nodes(o)*PITEM(lpi2)); // new
}
}
x(o,_) = x(o,_) / gessum;
x(o,0) = z2plv;
//std::cout << "z2plv:" << z2plv << " \n ";
//std::cout << "inmattrix: " << x(o,0) << " \n ";
}
Rcpp::NumericMatrix z(lno,ysi);
for(int i = 0; i < ysi; i++)
{
int whichE = y(i);
// if there is NOT a missing value, make standard procedure
// else (missing value is there) multiply with 1 - that means make a copy of what was there before
//if(!NumericVector::is_na(whichE))
if(!IntegerVector::is_na(whichE))
{
z(_,i) = x(_,whichE) * ENDm(_,i); // at the end ENDm will be the product again
} else {
z(_,i) = ENDm(_,i);
}
}
ENDm = z;
}
NumericVector colmw;
for(int col = 0; col < ysi; col++)
{
colmw = ENDm(_,col) * weights;
ENDm(_,col) = colmw / sum(colmw); // normalize
} // das muss ja fiq sein
///////
arma::mat Anu1m = Rcpp::as<arma::mat>(nu1m);
arma::mat AENDm = Rcpp::as<arma::mat>(ENDm);
//arma::mat riqv_quer = Anu1m * trans(AENDm);
arma::mat riqv_quer = trans(Anu1m) * trans(AENDm);
riqv_querG[gru] = riqv_quer; // save in list
//NumericVector fiq(lno);
// calculate fiq which is the expected number of persons on each node
IntegerMatrix fivor(ysi,listlength);
// write 0 if missing value, 1 if valid response
for(int ww = 0; ww < listlength; ww++)
{
fivor(_,ww) = ifelse(is_na(Y(_,ww)),0,1);
}
arma::mat Afivor = Rcpp::as<arma::mat>(fivor);
arma::mat fiq = AENDm * Afivor;
fiqG[gru] = fiq;
//
} // end of group loop
// ENDm nachher wieder entfernen! es wird nur das letzte rausgeschrieben!
return List::create(_["riqv_querG"] = riqv_querG, _["fiqG"] = fiqG);
//return riqv_querG;
}
arma::vec armaU(int n){
NumericVector x = runif(n,0,1);
arma::vec out(x.begin(), x.size(), false);
return out;
}
//[[Rcpp::export]]
IntegerVector cleanNA(NumericVector x) {
int n = x.size();
IntegerVector y = seq_len(n);//(x.begin(), x.end());
IntegerVector z = y[is_na(x)];
return z;
}
NumericVector RcppSample(NumericVector sample, int n)
{
return sample[round(runif(n)*(sample.size()-1.0), 0)];
}
// simulate genotypes given observed marker data
// [[Rcpp::export(".sim_geno")]]
IntegerVector sim_geno(const String& crosstype,
const IntegerMatrix& genotypes, // columns are individuals, rows are markers
const IntegerMatrix& founder_geno, // columns are markers, rows are founder lines
const bool is_X_chr,
const LogicalVector& is_female, // length n_ind
const IntegerMatrix& cross_info, // columns are individuals
const NumericVector& rec_frac, // length nrow(genotypes)-1
const IntegerVector& marker_index, // length nrow(genotypes)
const double error_prob,
const int n_draws) // number of imputations
{
const int n_ind = genotypes.cols();
const int n_pos = marker_index.size();
const int n_mar = genotypes.rows();
QTLCross* cross = QTLCross::Create(crosstype);
// check inputs
if(is_female.size() != n_ind)
throw std::range_error("length(is_female) != ncol(genotypes)");
if(cross_info.cols() != n_ind)
throw std::range_error("ncols(cross_info) != ncol(genotypes)");
if(rec_frac.size() != n_pos-1)
throw std::range_error("length(rec_frac) != length(marker_index)-1");
if(error_prob < 0.0 || error_prob > 1.0)
throw std::range_error("error_prob out of range");
for(int i=0; i<rec_frac.size(); i++) {
if(rec_frac[i] < 0 || rec_frac[i] > 0.5)
throw std::range_error("rec_frac must be >= 0 and <= 0.5");
}
if(!cross->check_founder_geno_size(founder_geno, n_mar))
throw std::range_error("founder_geno is not the right size");
// end of checks
const int mat_size = n_pos*n_draws;
IntegerVector draws(mat_size*n_ind); // output object
for(int ind=0; ind<n_ind; ind++) {
Rcpp::checkUserInterrupt(); // check for ^C from user
// possible genotypes for this individual
IntegerVector poss_gen = cross->possible_gen(is_X_chr, is_female[ind], cross_info(_,ind));
const int n_poss_gen = poss_gen.size();
NumericVector probs(n_poss_gen);
// backward equations
NumericMatrix beta = backwardEquations(cross, genotypes(_,ind), founder_geno, is_X_chr, is_female[ind],
cross_info(_,ind), rec_frac, marker_index, error_prob,
poss_gen);
// simulate genotypes
for(int draw=0; draw<n_draws; draw++) {
// first draw
// calculate first prob (on log scale)
probs[0] = cross->init(poss_gen[0], is_X_chr, is_female[ind], cross_info(_,ind)) + beta(0,0);
if(marker_index[0] >= 0)
probs[0] += cross->emit(genotypes(marker_index[0],ind), poss_gen[0], error_prob,
founder_geno(_, marker_index[0]), is_X_chr, is_female[ind], cross_info(_,ind));
double sumprobs = probs[0]; // to contain log(sum(probs))
// calculate rest of probs
for(int g=1; g<n_poss_gen; g++) {
probs[g] = cross->init(poss_gen[g], is_X_chr, is_female[ind], cross_info(_,ind)) + beta(g,0);
if(marker_index[0] >= 0)
probs[g] += cross->emit(genotypes(marker_index[0],ind), poss_gen[g], error_prob,
founder_geno(_, marker_index[0]), is_X_chr, is_female[ind], cross_info(_,ind));
sumprobs = addlog(sumprobs, probs[g]);
}
// re-scale probs
for(int g=0; g<n_poss_gen; g++)
probs[g] = exp(probs[g] - sumprobs);
// make draw, returns a value from 1, 2, ..., n_poss_gen
int curgeno = random_int(probs);
draws[draw*n_pos + ind*mat_size] = poss_gen[curgeno];
// move along chromosome
for(int pos=1; pos<n_pos; pos++) {
// calculate probs
for(int g=0; g<n_poss_gen; g++) {
probs[g] = cross->step(poss_gen[curgeno], poss_gen[g], rec_frac[pos-1],
is_X_chr, is_female[ind], cross_info(_,ind)) +
beta(g,pos) - beta(curgeno, pos-1);
if(marker_index[pos] >= 0)
probs[g] += cross->emit(genotypes(marker_index[pos],ind), poss_gen[g], error_prob,
founder_geno(_, marker_index[pos]), is_X_chr, is_female[ind], cross_info(_,ind));
probs[g] = exp(probs[g]);
}
// make draw
curgeno = random_int(probs);
draws[pos + draw*n_pos + ind*mat_size] = poss_gen[curgeno];
} // loop over positions
} // loop over draws
} // loop over individuals
draws.attr("dim") = Dimension(n_pos, n_draws, n_ind);
delete cross;
return draws;
}
/* Function to count number of valid partitions to swap */
int count_valid(List aList, List boundarypart, NumericVector cdvec){
int cd_boundary; arma::vec part; int j; int i;
arma::uvec find_cds; int counter = 0;
for(i = 0; i < boundarypart.size(); i++){
// Get the partition
part = as<arma::vec>(boundarypart(i));
// Get the congressional district of the boundary
cd_boundary = cdvec(part(0));
// Find indices within that congressional district
find_cds = find(as<arma::vec>(cdvec) == cd_boundary);
// Remove elements in the partition from that cd
NumericVector cd_less_boundary;
for(j = 0; j < find_cds.n_elem; j++){
if(any(part == find_cds(j)) == false){
cd_less_boundary.push_back(find_cds(j));
}
}
// If cd_less_boundary empty, then continue
// Eliminates district so invalid partition
if(cd_less_boundary.size() == 0){
continue;
}
// Create new adjacency list
List newadj(cd_less_boundary.size());
for(j = 0; j < newadj.size(); j++){
// Extract vector from adjacency list
NumericVector getadjvec = aList(cd_less_boundary(j));
// Subset down to elements in cd_less_boundary
NumericVector getadjvec_sub;
for(int k = 0; k < getadjvec.size(); k++){
if(any(as<arma::vec>(cd_less_boundary) == getadjvec(k))){
getadjvec_sub.push_back(getadjvec(k));
}
}
// Change indices
NumericVector getadjvec_new;
for(int k = 0; k < getadjvec_sub.size(); k++){
arma::uvec ind = find(as<arma::vec>(cd_less_boundary) ==
getadjvec_sub(k));
getadjvec_new.push_back(ind(0));
}
// Add to newadj
newadj(j) = getadjvec_new;
}
// Calculate number of partitions
int nparts = countpartitions(newadj);
if(nparts == 1){
counter++;
}
}
return counter;
}
//' Compute most probable path with extended Viterbi algorithm.
//'
//' Viterbi algorithm for Hidden Markov Model with duration
//' @param aa_sample \code{character} vector representing single aminoacid sequence.
//' @param pipar probabilities of initial state in Markov Model.
//' @param tpmpar matrix of transition probabilities between states.
//' @param od matrix of response probabilities. Eg. od[1,2] is a probability of signal 2 in state 1.
//' @param params matrix of probability distribution for duration. Eg. params[10,2] is probability of duration of time 10 in state 2.
//' @export
//' @return A list of length four:
//' \itemize{
//' \item{path}{ a vector of most probable path}
//' \item{viterbi}{ values of probability in all intermediate points,}
//' \item{psi}{ matrix that gives for every signal and state the previous state in viterbi path,}
//' \item{duration}{ matrix that gives for every signal and state gives the duration in that state on viterbi path.}
//' }
//' @note All computations are on logarithms of probabilities.
// [[Rcpp::export]]
List duration_viterbi(NumericVector aa_sample, NumericVector pipar, NumericMatrix tpmpar, NumericMatrix od, NumericMatrix params) {
int maxDuration = params.nrow();
int nstates = pipar.length();
// for(int i=0; i<nstates; i++){
// Rprintf("%f ", pipar(i));
// }
// Rprintf("\n");
//
// for(int i=0; i<tpmpar.nrow(); i++){
// for(int j=0; j<tpmpar.ncol(); j++){
// Rprintf("%f ", tpmpar(i, j));
// }
// Rprintf("\n");
// }
//
// for(int i=0; i<params.nrow(); i++){
// for(int j=0; j<params.ncol(); j++){
// Rprintf("%f ", params[i, j]);
// }
// Rprintf("\n");
// }
NumericMatrix viterbi(aa_sample.length(), nstates); //probabiliy values for viterbi path that ends in specific state and signal
NumericMatrix psi(aa_sample.length(), nstates); //the previous state for viterbi path that ends in specific state and signal
NumericMatrix dura(aa_sample.length(), nstates); //the current duration for viterbi path that ends in specific state and signal
//first signal is treated seperately
for(unsigned int j=0; j<nstates; j++) {
viterbi(0,j) = log(pipar(j)) + log( od(j,aa_sample(0)) );
psi(0,j) = 0;
dura(0,j) = 0;
}
double previous;
double transition = 0.0;
for(int i=1; i<aa_sample.length(); i++) {
//For each state we will compute the probability of the viterbi path that ends in that state
for(int j=0; j<nstates; j++) {
double max = R_NegInf;
int maxInd = 0; //previous state that is maximising probability
int maximDura = 0; //duration that is maximising probability
for(int k=0; k<nstates; k++) {
int dMax=std::min(maxDuration-1, i);
for(int d=0; d<=dMax; d++) {
// for every possible previous state, and for every possible duration in current state
if (i-d==0) { //if duration is as long as number of signal considered
if(j == 0) { //only first state is accepted
previous = 1.0;
transition = 1.0;
} else { //other states are discarded with log-probability -Inf
previous = R_NegInf;
transition = 1.0;
}
} else { //there is some previous state
previous = viterbi(i-d-1, k); //previous probability on this viterbi path
transition = log(tpmpar(k, j)); //probability of transition to current state from prevois state
}
double duration = log(params(d, j)); //probability of duration that lasts time d
double responses = 0; //probability of generating d signal in current state
for(int l=i-d; l<=i; l++) {
responses += log(od(j, aa_sample[l]));
}
// if(j==1){
// Rprintf("i %d k %d d %d \n", i,k,d);
// Rprintf("The value of previous is %f\n", previous);
// Rprintf("The value of transition is %f\n", transition );
// Rprintf("The value of duration is %f\n", duration );
// Rprintf("The value of responses is %f\n", responses );
// }
if(previous + transition + duration + responses > max) {
//if that path is better than the best yet found store it
max = previous + transition + duration + responses;
maxInd = k;
maximDura = d;
}
}
}
//assign information about the best path that ends on signal i and state j
viterbi(i, j) = max;
psi(i, j) = maxInd;
dura(i, j) = maximDura;
}
}
//now we extract information about the path. We look for the most probable path
IntegerVector path(aa_sample.size());
//the last state
int seqLength = aa_sample.length();
NumericVector prob_path = viterbi(seqLength-1,_);
// for(int i=0; i<prob_path.length(); i++){
// Rprintf("%f ", prob_path(i));
// }
// Rprintf("\n %d \n", which_max(viterbi(seqLength-1,_)));
path(seqLength-1) = which_max(viterbi(seqLength-1,_));
int i = seqLength-2;
int last = seqLength-1;
while(i > 0) {
if(last - i <= dura(last, path[last])) { //we are still in the same state
path(i) = path(last);
}
else { //time to change the state for the previous, stored in matrix psi
path(i) = psi(last, path(last));
last = i;
}
i -= 1;
}
path(0) = 0;
return List::create(
_["path"] = path,
_["viterbi"] = viterbi,
_["psi"] = psi,
_["duration"] = dura
);
}
// [[Rcpp::export]]
NumericMatrix calc_bs_scalar(NumericVector x, NumericVector knots, int degree, NumericVector boundary_knots) {
int nk = knots.size();
int len_x = x.size();
double x_val, term, saved;
int order = degree + 1;
NumericMatrix basis(len_x, nk + degree);
NumericMatrix basis_j(len_x, order);
int kk_size = 2 * order + nk;
NumericVector kk(kk_size);
NumericVector rdel(degree);
NumericVector ldel(degree);
for (int k = 0; k < order; k++) {
kk[k] = boundary_knots[0];
kk[k + order + nk] = boundary_knots[1];
}
for (int k = 0; k < nk; k++) {
kk[k + order] = knots[k];
}
for (int j = 0; j < len_x; j++) {
x_val = x[j];
//calculate cursor point
int curs = -1;
for (int k = 0; k < kk_size; k++) {
if (kk[k] >= x_val) curs = k;
if (kk[k] > x_val) break;
}
if (curs > (kk_size - order)) {
int lastLegit = kk_size - order;
if (x_val == kk[lastLegit]) {
curs = lastLegit;
}
}
//calculate rdel and ldel
for (int k = 0; k < degree; k++) {
rdel[k] = kk[curs + k] - x_val;
ldel[k] = x_val - kk[curs - k - 1];
}
basis_j(j, 0) = 1.0;
for (int k = 1; k < order; k++) {
saved = 0.0;
for (int r = 0; r < k; r++) {
term = basis_j(j, r) / (rdel[r] + ldel[k - 1 - r]);
basis_j(j, r) = saved + rdel[r] * term;
saved = ldel[k - 1 - r] * term;
}
basis_j(j, k) = saved;
}
//convert basis_j to the correct size matrix
int offset = curs - order - 1;
for (int k = 0; k < order; k++) {
if ((k + offset) >= 0) {
basis(j, k + offset) = basis_j(j, k);
}
}
}
return(basis);
}
// [[Rcpp::export]]
List SDP_single(int tmax, NumericVector res_bs, int cons_bs, int xc, NumericVector rep_gain,
NumericMatrix f_m, NumericVector mort, List dec_ls, NumericVector rho_vec, NumericMatrix c_learn, NumericVector g_forage, NumericVector c_forage) {
//Establish iniital variables required for the SDP
int num_res = res_bs.size();
//How many decisions? Count columns on first decision matrix
NumericMatrix dec_ex = dec_ls(0);
int num_dec = dec_ex.ncol();
int max_enc = f_m.nrow(); //Rows = encounters; Columns = resources
double cons_bs_state = (double) cons_bs;
//Define xc_state as a double. This variable will be used for energetic calculations
double xc_state = (double) xc;
//Define xc, which will be used to locate the critical value in a matrix.
//Subtract one, because Cpp indices start at zero.
xc = xc - 1;
//Build Fitness List, Istar List, and terminal fitness values
List W_nr(num_res);
List istar_nr(num_res);
NumericMatrix W_xt(cons_bs,tmax);
//NumericMatrix istar_xt(cons_bs,tmax-1);
//Initiate terminal fitness values in W_xt matrix
//Don't forget that the matrix index BEGINS at 0.
for (int i=xc; i<cons_bs; i++) {
W_xt(i,tmax-1) = rep_gain(i); //tmax-1 because index starts at zero. So tmax-1 is the terminal time, as t=0 is initial time
}
//Place fitness matrix into each list element for future updating
for (int i=0; i<num_res; i++) {
W_nr(i) = W_xt;
//istar_nr(i) = istar_xt;
}
//Begin Backwards Equation
for (int r=0; r<num_res; r++) {
Rcpp::Rcout << "r = " << r << std::endl;
NumericMatrix dec_m = dec_ls(r);
NumericMatrix W_r = W_nr(r);
IntegerMatrix istar_r(cons_bs,tmax-1);
//Begin backwards calculations... start at tmax-1
for (int t=(tmax-1); t --> 0;) {
//Rcpp::Rcout << "t = " << t << std::endl;
//int t_state = t - 1;
for (int x=xc; x<cons_bs; x++) {
//Define the energetic state to be used in calculations
//Added one because the index starts at zero... but we care about the true energetic state, not the index
double x_state = (double) x;
x_state = x_state + 1;
NumericVector value(num_dec);
for (int i=0; i<num_dec; i++) {
//Build preference vector for ith decision
NumericVector pref_vec(num_res);
for (int j=0; j<num_res; j++) {
pref_vec(j) = dec_m(j,i);
}
//Loop over the changes in energetic reserves via consumption of different (t+1) resources
NumericMatrix xp(num_res,max_enc);
//xp high and low must be integers, because they are used as indices of the fitness matrices
IntegerMatrix xp_high(num_res,max_enc);
IntegerMatrix xp_low(num_res,max_enc);
//But these are not integer matrices
NumericMatrix q(num_res,max_enc);
NumericMatrix W(num_res,max_enc);
NumericVector Wk(num_res);
double Fx = 0; //Initialized at zero. Will be added/multiplied as dot product below
for (int rr=0; rr<num_res; rr++) {
for (int k=0; k<max_enc; k++) {
//Change in Energetic state
xp(rr,k) = x_state + rho_vec(k)*(g_forage(rr) - (c_forage(rr) + c_learn(r,rr))) - (1-rho_vec(k))*(c_forage(rr) + c_learn(r,rr));
//Establish Boundary conditions en route
//Lower boundary condition at x-critical
if (xp(rr,k) < xc_state) {xp(rr,k) = xc_state;}
//Higher boundary condition at xmax = cons_bs
if (xp(rr,k) > cons_bs_state) {xp(rr,k) = cons_bs_state;}
//Build xp_high, xp_low, and q matrices en route
//Estabish Fitness en route
if ((xp(rr,k) < cons_bs_state) && (xp(rr,k) > xc_state)) {
xp_low(rr,k) = (int) floor(xp(rr,k));
xp_high(rr,k) = (int) xp_low(rr,k) + 1;
//Make sure that we do not have an (integer - double)
double xp_h = (double) xp_high(rr,k);
q(rr,k) = xp_h - xp(rr,k);
//Prep for indexing
//Adjust xp_low and xp_high to signify indices rather than energetic values
xp_low(rr,k) = xp_low(rr,k) - 1;
xp_high(rr,k) = xp_high(rr,k) - 1;
W(rr,k) = q(rr,k)*W_r(xp_low(rr,k),t+1) + (1-q(rr,k))*W_r(xp_high(rr,k),t+1);
}
if (xp(rr,k) == xc_state) {
xp_low(rr,k) = (int) xc_state;
xp_high(rr,k) = (int) xc_state+1;
q(rr,k) = 1;
//Prep for indexing
//Adjust xp_low and xp_high to signify indices rather than energetic values
xp_low(rr,k) = xp_low(rr,k) - 1;
xp_high(rr,k) = xp_high(rr,k) - 1;
W(rr,k) = q(rr,k)*W_r(xp_low(rr,k),t+1) + (1-q(rr,k))*W_r(xp_high(rr,k),t+1);
}
if (xp(rr,k) == cons_bs_state) {
xp_low(rr,k) = (int) cons_bs_state - 1;
xp_high(rr,k) = (int) cons_bs_state;
q(rr,k) = 0;
//Prep for indexing
//Adjust xp_low and xp_high to signify indices rather than energetic values
xp_low(rr,k) = xp_low(rr,k) - 1;
xp_high(rr,k) = xp_high(rr,k) - 1;
W(rr,k) = q(rr,k)*W_r(xp_low(rr,k),t+1) + (1-q(rr,k))*W_r(xp_high(rr,k),t+1);
}
//Vector multiplication: fitness vector (over k) and probability of finding k resources (over k)
//Note that the values for the W and f.m matrices are transposed relative to each other
double vec = W(rr,k) * f_m(k,rr);
Wk(rr) += vec; // The same as Wk(rr) = Wk(rr) + vec
} // end k
//Vector multiplication over preference probabilities and Wk ** over rr **
double vec2 = pref_vec(rr) * (rep_gain(x) + (1-mort(rr))*Wk(rr));
Fx += vec2;
//Rcpp::Rcout << "Fx = " << Fx << std::endl;
} // end rr
//Record fitness value for decision i
value(i) = Fx;
} // end i (decision loop)
//Find maximum value
int istar = which_max(value);
istar_r(x,t) = istar + 1; //The +1 is there because we are going from 'index' to 'decision number'
W_r(x,t) = value(istar);
} //End x iterations
} //End t iterations
//Replace updated W_nr
//Update istar_nr list
W_nr(r) = W_r;
istar_nr(r) = istar_r;
} //End r iterations
List output(2);
output(0) = W_nr;
output(1) = istar_nr;
return (output);
} //End cpp function
void v_glogis(NumericVector x)
{
for(int i = 0; i < x.size(); i++)
v_glogis(&x[i]);
}
//' Update the parameter F (M-step in the EM-algorithm)
//'
//' @param vTheta theparameter Theta (converted to a vector)
//' @param vG the matrix of mutation feature data
//' @param fdim a vector specifying the number of possible values for each mutation signature
//' @param signatureNum the number of mutation signatures
//' @param sampleNum the number of cancer genomes
//' @param patternNum the number of possible combinations of all the mutation features
//' @param isBackground the logical value showing whether a background mutaiton features is included or not
//' @export
// [[Rcpp::export]]
NumericVector updateMstepFC(NumericVector vTheta, NumericVector vG,NumericVector fdim, int signatureNum, int sampleNum, int patternNum, bool isBackground) {
int variableSigNum;
if (isBackground) {
variableSigNum = signatureNum - 1;
} else {
variableSigNum = signatureNum;
}
NumericVector vF(variableSigNum * fdim.size() * max(fdim));
IntegerVector currentDigits(fdim.size());
NumericVector vG_Theta_sum(signatureNum * patternNum);
for (int m = 0; m < patternNum; m++) {
for (int n = 0; n < sampleNum; n++) {
for (int k = 0; k < signatureNum; k++) {
vG_Theta_sum[k + m * signatureNum] = vG_Theta_sum[k + m * signatureNum] + vG[n + m * sampleNum] * vTheta[n + k * sampleNum + m * sampleNum * signatureNum];
}
}
}
for (int l = 0; l < fdim.size(); l++) {
currentDigits[l] = 0;
}
for (int m = 0; m < patternNum; m++) {
for (int l = 0; l < fdim.size(); l++) {
for (int k = 0; k < variableSigNum; k++) {
vF[k + l * variableSigNum + currentDigits[l] * variableSigNum * fdim.size()] = vF[k + l * variableSigNum + currentDigits[l] * variableSigNum * fdim.size()] + vG_Theta_sum[k + m * signatureNum];
}
}
int tl = 0;
while(tl < fdim.size() and currentDigits[tl] + 1 >= fdim[tl]) {
currentDigits[tl] = 0;
tl = tl + 1;
}
if (tl < fdim.size()) {
currentDigits[tl] = currentDigits[tl] + 1;
}
}
double tempSum;
double invTempSum;
for (int k = 0; k < variableSigNum; k++) {
for (int l = 0; l < fdim.size(); l++) {
tempSum = 0;
for (int ll = 0; ll < max(fdim); ll++) {
tempSum = tempSum + vF[k + l * variableSigNum + ll * variableSigNum * fdim.size()];
}
invTempSum = 1 / tempSum;
for (int ll = 0; ll < max(fdim); ll++) {
vF[k + l * variableSigNum + ll * variableSigNum * fdim.size()] = vF[k + l * variableSigNum + ll * variableSigNum * fdim.size()] * invTempSum;
}
}
}
return(vF);
}
